}
-sub pkg_field_where {
- my( $self, $field, $speriod, $eperiod, $agentnum, %opt ) = @_;
- # someday this will use an aggregate query and return all the columns
- # at once
- # and I will drive a Tesla and have a live-in sushi chef who is also a
- # ninja bodyguard
- my @where = (
- $self->in_time_period_and_agent($speriod,
- $eperiod,
- $agentnum,
- "cust_pkg.$field",
- ),
- $self->with_refnum(%opt),
- $self->with_towernum(%opt),
- $self->with_zip(%opt),
- # can't use with_classnum here...
- );
- if ($opt{classnum}) {
- my $classnum = $opt{classnum};
- $classnum = [ $classnum ] if !ref($classnum);
- @$classnum = grep /^\d+$/, @$classnum;
- my $in = 'IN ('. join(',', @$classnum). ')';
- push @where, "COALESCE(part_pkg.classnum, 0) $in" if scalar @$classnum;
- }
+##### churn report #####
- ' WHERE ' . join(' AND ', grep $_, @where);
-}
-
-=item setup_pkg: The number of packages with setup dates in the period.
-
-This excludes packages created by package changes. Options:
+=item active_pkg: The number of packages that were active at the start of
+the period. The end date of the period is ignored. Options:
- refnum: Limit to customers with this advertising source.
- classnum: Limit to packages with this class.
Except for zip, any of these can be an arrayref to allow multiple values for
the field.
-=item susp_pkg: The number of suspended packages that were last suspended
-in the period. Options are as for setup_pkg.
+=item setup_pkg: The number of packages with setup dates in the period. This
+excludes packages created by package changes. Options are as for active_pkg.
+
+=item susp_pkg: The number of packages that were suspended in the period
+(and not canceled). Options are as for active_pkg.
+
+=item unsusp_pkg: The number of packages that were unsuspended in the period.
+Options are as for active_pkg.
=item cancel_pkg: The number of packages with cancel dates in the period.
Excludes packages that were canceled to be changed to a new package. Options
-are as for setup_pkg.
+are as for active_pkg.
=cut
+sub active_pkg {
+ my $self = shift;
+ $self->churn_pkg('active', @_);
+}
+
sub setup_pkg {
my $self = shift;
- my $sql = 'SELECT COUNT(*) FROM cust_pkg
- LEFT JOIN part_pkg USING (pkgpart)
- LEFT JOIN cust_main USING (custnum)'.
- $self->pkg_field_where('setup', @_) .
- ' AND change_pkgnum IS NULL';
+ $self->churn_pkg('setup', @_);
+}
- $self->scalar_sql($sql);
+sub cancel_pkg {
+ my $self = shift;
+ $self->churn_pkg('cancel', @_);
}
sub susp_pkg {
- # number of currently suspended packages that were suspended in the period
my $self = shift;
- my $sql = 'SELECT COUNT(*) FROM cust_pkg
- LEFT JOIN part_pkg USING (pkgpart)
- LEFT JOIN cust_main USING (custnum) '.
- $self->pkg_field_where('susp', @_);
+ $self->churn_pkg('susp', @_);
+}
- $self->scalar_sql($sql);
+sub unsusp_pkg {
+ my $self = shift;
+ $self->churn_pkg('unsusp', @_);
}
-sub cancel_pkg {
- # number of packages canceled in the period and not changed to another
- # package
+sub churn_pkg {
my $self = shift;
- my $sql = 'SELECT COUNT(*) FROM cust_pkg
- LEFT JOIN part_pkg USING (pkgpart)
- LEFT JOIN cust_main USING (custnum)
- LEFT JOIN cust_pkg changed_to_pkg ON(
- cust_pkg.pkgnum = changed_to_pkg.change_pkgnum
- ) '.
- $self->pkg_field_where('cancel', @_) .
- ' AND changed_to_pkg.pkgnum IS NULL';
+ my ( $status, $speriod, $eperiod, $agentnum, %opt ) = @_;
+ my ($from, @where) =
+ FS::h_cust_pkg->churn_fromwhere_sql( $status, $speriod, $eperiod);
+
+ push @where, $self->pkg_where(%opt, 'agentnum' => $agentnum);
+
+ my $sql = "SELECT COUNT(*) FROM $from
+ JOIN part_pkg ON (cust_pkg.pkgpart = part_pkg.pkgpart)
+ JOIN cust_main ON (cust_pkg.custnum = cust_main.custnum)";
+ $sql .= ' WHERE '.join(' AND ', @where)
+ if scalar(@where);
$self->scalar_sql($sql);
}
-#this is going to be harder..
-#sub unsusp_pkg {
-# my( $self, $speriod, $eperiod, $agentnum ) = @_;
-# $self->scalar_sql("
-# SELECT COUNT(*) FROM h_cust_pkg
-# WHERE
-#
-#}
+sub pkg_where {
+ my $self = shift;
+ my %opt = @_;
+ my @where = (
+ "part_pkg.freq != '0'",
+ $self->with_refnum(%opt),
+ $self->with_towernum(%opt),
+ $self->with_zip(%opt),
+ );
+ if ($opt{agentnum} =~ /^(\d+)$/) {
+ push @where, "cust_main.agentnum = $1";
+ }
+ if ($opt{classnum}) {
+ my $classnum = $opt{classnum};
+ $classnum = [ $classnum ] if !ref($classnum);
+ @$classnum = grep /^\d+$/, @$classnum;
+ my $in = 'IN ('. join(',', @$classnum). ')';
+ push @where, "COALESCE(part_pkg.classnum, 0) $in" if scalar @$classnum;
+ }
+ @where;
+}
+
+##### end of churn report stuff #####
sub in_time_period_and_agent {
my( $self, $speriod, $eperiod, $agentnum ) = splice(@_, 0, 4);
reason to do this. Now that we have C<indices> it's probably better to
use that.
+=item PROCESSING
+
+=item normalize: Set this to an item index to have all other items expressed
+as a percentage of that one. That item will then be omitted from the output.
+If the normalization item is zero in some period, all the values in that
+period will be undef.
+
=head1 RETURNED DATA
The C<data> method runs the report and returns a hashref of the following:
my $eperiod = timelocal(0,0,0,1,$smonth-1,$syear);
push @{$data{eperiod}}, $eperiod;
- my $col = 0;
+ my $col = 0; # a "column" here is the data corresponding to an item
my @items = @{$self->{'items'}};
my $i;
$data{'colors'} = $self->{'colors'};
$data{'links'} = $self->{'links'} || [];
- if ( !$self->{'cross_params'} and $self->{'remove_empty'} ) {
+ if ( defined $self->{'normalize'} ) {
+ my $norm_col = $self->{'normalize'};
+ my $norm_data = $data{data}->[$norm_col];
+
+ my $row = 0;
+ while ( exists $data{speriod}->[$row] ) {
+ my $col = 0;
+ while ( exists $data{items}->[$col ] ) {
+ if ( $col != $norm_col ) {
+ if ( $norm_data->[$row] == 0 ) {
+ $data{data}->[$col][$row] = undef;
+ } else {
+ $data{data}->[$col][$row] =
+ ( $data{data}->[$col][$row] * 100 / $norm_data->[$row] );
+ }
+ }
+ $col++;
+ }
+ $row++;
+ }
+ }
+
+ if ( !$self->{'cross_params'} ) {
+ # remove unnecessary rows
my $col = 0;
#these need to get generalized, sheesh
my @indices = ();
foreach my $item ( @{$self->{'items'}} ) {
+ # if remove_empty, then remove rows of zeroes
+ my $is_nonzero = scalar( grep { $_ != 0 } @{ $data{'data'}->[$col] });
+ next if ($self->{'remove_empty'} and $is_nonzero == 0);
+ # if normalizing, strip out the norm column
+ next if (defined($self->{'normalize'}) and $self->{'normalize'} == $col);
+
if ( grep { $_ != 0 } @{$data{'data'}->[$col]} ) {
push @newitems, $data{'items'}->[$col];
push @newlabels, $data{'item_labels'}->[$col];
push @newlinks, $data{'links'}->[$col];
push @indices, $col;
}
-
+ } continue {
$col++;
}
$data{'indices'} = \@indices;
}
+
# clean up after ourselves
#dbh->rollback;
# leave in until development is finished, for diagnostics
}
###
+ # parse refnum (advertising source)
+ ###
+
+ if ( exists($params->{'refnum'}) ) {
+ my @refnum;
+ if (ref $params->{'refnum'}) {
+ @refnum = @{ $params->{'refnum'} };
+ } else {
+ @refnum = ( $params->{'refnum'} );
+ }
+ my $in = join(',', grep /^\d+$/, @refnum);
+ push @where, "refnum IN($in)" if length $in;
+ }
+
+ ###
# parse package report options
###
($select, $where, $cacheobj, $as);
}
+=item sql_diff START_TIMESTAMP, END_TIMESTAMP[, WHERE]
+
+Returns a complete SQL statement to find all records that were changed
+between START_TIMESTAMP and END_TIMESTAMP. This finds only replacements,
+not new or deleted records.
+
+For each modified record, this will return I<one> row (not two rows as in
+the history table) with the primary key of the record, "old_historynum"
+(the historynum of the last modification before START_TIMESTAMP), and
+"new_historynum" (the last modification before END_TIMESTAMP). Join these
+back to the h_* table to retrieve the actual field values.
+
+Within the query, the last history records as of START and END are aliased
+as "old" and "new"; you can append a WHERE clause to take advantage of this.
+
+=cut
+
+sub sql_diff {
+ my $class = shift;
+ my $table = $class->table;
+ my ($real_table) = ($table =~ /^h_(\w+)$/);
+ my $pkey = dbdef->table($real_table)->primary_key;
+ my @fields = "FS::$real_table"->fields;
+
+ my ($sdate, $edate) = @_;
+ ($sdate, $edate) = ($edate, $sdate) if $edate < $sdate;
+
+ my @select = (
+ "old.$pkey",
+ 'old.historynum AS old_historynum',
+ 'new.historynum AS new_historynum',
+ );
+ my $new =
+ "SELECT DISTINCT ON ($pkey) * FROM $table
+ WHERE history_action = 'replace_new'
+ AND history_date >= $sdate AND history_date < $edate
+ ORDER BY $pkey ASC, history_date DESC";
+ my $old =
+ "SELECT DISTINCT ON ($pkey) * FROM $table
+ WHERE (history_action = 'replace_new' OR history_action = 'insert')
+ AND history_date < $sdate
+ ORDER BY $pkey ASC, history_date DESC";
+
+ my $from = "($new) AS new JOIN ($old) AS old USING ($pkey)";
+
+ return "SELECT ".join(',', @select)." FROM $from";
+}
+
+
=back
=head1 BUGS
# make some adjustments
$query->{'table'} = 'h_cust_pkg';
- foreach (qw(select addl_from extra_sql count_query)) {
+ foreach (qw(select addl_from extra_sql count_query order_by)) {
$query->{$_} =~ s/cust_pkg\b/h_cust_pkg/g;
$query->{$_} =~ s/cust_main\b/h_cust_main/g;
}
$query;
}
+=item churn_fromwhere_sql STATUS, START, END
+
+Returns SQL fragments to do queries related to "package churn". STATUS
+is one of "active", "setup", "cancel", "susp", or "unsusp". These do NOT
+correspond directly to package statuses. START and END define a date range.
+
+- active: limit to packages that were active on START. END is ignored.
+- setup: limit to packages that were set up between START and END, except
+those created by package changes.
+- cancel: limit to packages that were canceled between START and END, except
+those changed into other packages.
+- susp: limit to packages that were suspended between START and END.
+- unsusp: limit to packages that were unsuspended between START and END.
+
+The logic of these may change in the future, especially with respect to
+package changes. Watch this space.
+
+Returns a list of:
+- a fragment usable as a FROM clause (without the keyword FROM), in which
+ the package table is named or aliased to 'cust_pkg'
+- one or more conditions to include in the WHERE clause
+
+=cut
+
+sub churn_fromwhere_sql {
+ my ($self, $status, $speriod, $eperiod) = @_;
+
+ my ($from, @where);
+ if ( $status eq 'active' ) {
+ # for all packages that were setup before $speriod, find the pkgnum
+ # and the most recent update of the package before $speriod
+ my $setup_before = "SELECT DISTINCT ON (pkgnum) pkgnum, historynum
+ FROM h_cust_pkg
+ WHERE setup < $speriod
+ AND history_date < $speriod
+ AND history_action IN('insert', 'replace_new')
+ ORDER BY pkgnum ASC, history_date DESC";
+ # for each of these, exclude if the package was suspended or canceled
+ # in the most recent update before $speriod
+ $from = "h_cust_pkg AS cust_pkg
+ JOIN ($setup_before) AS setup_before USING (historynum)";
+ @where = ( 'susp IS NULL', 'cancel IS NULL' );
+ } elsif ( $status eq 'setup' ) {
+ # the simple case, because packages should only get set up once
+ # (but exclude those that were created due to a package change)
+ # XXX or should we include if they were created by a pkgpart change?
+ $from = "cust_pkg";
+ @where = (
+ "setup >= $speriod",
+ "setup < $eperiod",
+ "change_pkgnum IS NULL"
+ );
+ } elsif ( $status eq 'cancel' ) {
+ # also simple, because packages should only be canceled once
+ # (exclude those that were canceled due to a package change)
+ $from = "cust_pkg";
+ @where = (
+ "cust_pkg.cancel >= $speriod",
+ "cust_pkg.cancel < $eperiod",
+ "NOT EXISTS(SELECT 1 FROM cust_pkg AS changed_to_pkg ".
+ "WHERE cust_pkg.pkgnum = changed_to_pkg.change_pkgnum)",
+ );
+ } elsif ( $status eq 'susp' ) {
+ # more complicated
+ # find packages that were changed from susp = null to susp != null
+ my $susp_during = $self->sql_diff($speriod, $eperiod) .
+ ' WHERE old.susp IS NULL AND new.susp IS NOT NULL';
+ $from = "h_cust_pkg AS cust_pkg
+ JOIN ($susp_during) AS susp_during
+ ON (susp_during.new_historynum = cust_pkg.historynum)";
+ @where = ( 'cust_pkg.cancel IS NULL' );
+ } elsif ( $status eq 'unsusp' ) {
+ # similar to 'susp'
+ my $unsusp_during = $self->sql_diff($speriod, $eperiod) .
+ ' WHERE old.susp IS NOT NULL AND new.susp IS NULL';
+ $from = "h_cust_pkg AS cust_pkg
+ JOIN ($unsusp_during) AS unsusp_during
+ ON (unsusp_during.new_historynum = cust_pkg.historynum)";
+ @where = ( 'cust_pkg.cancel IS NULL' );
+ } else {
+ die "'$status' makes no sense";
+ }
+ return ($from, @where);
+}
=head1 BUGS
+churn_fromwhere_sql fails on MySQL.
+
=head1 SEE ALSO
L<FS::cust_pkg>, L<FS::h_Common>, L<FS::Record>, schema.html from the base
1;
-
+++ /dev/null
-<& elements/monthly.html,
- 'title' => $agentname. 'Package Churn',
- 'items' => \@items,
- 'labels' => \@labels,
- 'graph_labels' => \@labels,
- 'colors' => \@colors,
- 'links' => \@links,
- 'params' => \@params,
- 'agentnum' => $agentnum,
- 'sprintf' => '%u',
- 'disable_money' => 1,
- 'remove_empty' => (scalar(@group_keys) > 1 ? 1 : 0),
-&>
-<%init>
-
-#XXX use a different ACL for package churn?
-my $curuser = $FS::CurrentUser::CurrentUser;
-die "access denied"
- unless $curuser->access_right('Financial reports');
-
-#false laziness w/money_time.cgi, cust_bill_pkg.cgi
-
-#XXX or virtual
-my( $agentnum, $agent ) = ('', '');
-if ( $cgi->param('agentnum') =~ /^(\d+)$/ ) {
- $agentnum = $1;
- $agent = qsearchs('agent', { 'agentnum' => $agentnum } );
- die "agentnum $agentnum not found!" unless $agent;
-}
-
-my $agentname = $agent ? $agent->agent.' ' : '';
-
-my @base_items = qw( setup_pkg susp_pkg cancel_pkg );
-
-my %base_labels = (
- 'setup_pkg' => 'New orders',
- 'susp_pkg' => 'Suspensions',
-# 'unsusp' => 'Unsuspensions',
- 'cancel_pkg' => 'Cancellations',
-);
-
-my %base_colors = (
- 'setup_pkg' => '00cc00', #green
- 'susp_pkg' => 'ff9900', #yellow
- #'unsusp' => '', #light green?
- 'cancel_pkg' => 'cc0000', #red ? 'ff0000'
-);
-
-my %base_links = (
- 'setup_pkg' => { 'link' => "${p}search/cust_pkg.cgi?agentnum=$agentnum;",
- 'fromparam' => 'setup_begin',
- 'toparam' => 'setup_end',
- },
- 'susp_pkg' => { 'link' => "${p}search/cust_pkg.cgi?agentnum=$agentnum;",
- 'fromparam' => 'susp_begin',
- 'toparam' => 'susp_end',
- },
- 'cancel_pkg' => { 'link' => "${p}search/cust_pkg.cgi?agentnum=$agentnum;",
- 'fromparam' => 'cancel_begin',
- 'toparam' => 'cancel_end',
- },
-);
-
-my %filter_params = (
- # not agentnum, that's elsewhere
- 'refnum' => [ $cgi->param('refnum') ],
- 'classnum' => [ $cgi->param('classnum') ],
- 'towernum' => [ $cgi->param('towernum') ],
-);
-if ( $cgi->param('zip') =~ /^(\w+)/ ) {
- $filter_params{zip} = $1;
-}
-foreach my $link (values %base_links) {
- foreach my $key (keys(%filter_params)) {
- my $value = $filter_params{$key};
- if (ref($value)) {
- $value = join(',', @$value);
- }
- $link->{'link'} .= "$key=$value;" if length($value);
- }
-}
-
-
-# In order to keep this from being the same trainwreck as cust_bill_pkg.cgi,
-# we allow ONE breakdown axis, besides the setup/susp/cancel inherent in
-# the report.
-
-my $breakdown = $cgi->param('breakdown_by');
-my ($name_col, $table);
-if ($breakdown eq 'classnum') {
- $table = 'pkg_class';
- $name_col = 'classname';
-} elsif ($breakdown eq 'refnum') {
- $table = 'part_referral';
- $name_col = 'referral';
-} elsif ($breakdown eq 'towernum') {
- $table = 'tower';
- $name_col = 'towername';
-} elsif ($breakdown) {
- die "unknown breakdown column '$breakdown'\n";
-}
-
-my @group_keys;
-my @group_labels;
-if ( $table ) {
- my @groups;
- if ( $cgi->param($breakdown) ) {
- foreach my $key ($cgi->param($breakdown)) {
- next if $key =~ /\D/;
- push @groups, qsearch( $table, { $breakdown => $key });
- }
- } else {
- @groups = qsearch( $table );
- }
- foreach (@groups) {
- push @group_keys, $_->get($breakdown);
- push @group_labels, $_->get($name_col);
- }
-}
-
-my (@items, @labels, @colors, @links, @params);
-if (scalar(@group_keys) > 1) {
- my $hue = 180;
- foreach my $key (@group_keys) {
- # this gives a decent level of contrast as long as there aren't too many
- # result sets
- my $scheme = Color::Scheme->new
- ->scheme('triade')
- ->from_hue($hue)
- ->distance(0.5);
- my $label = shift @group_labels;
- my $i = 0; # item index
- foreach (@base_items) {
- # append the item
- push @items, $_;
- # and its parameters
- push @params, [
- %filter_params,
- $breakdown => $key
- ];
- # and a label prefixed with the group label
- push @labels, "$label - $base_labels{$_}";
- # and colors (?!)
- push @colors, $scheme->colorset->[$i]->[1];
- # and links...
- my %this_link = %{ $base_links{$_} };
- $this_link{link} .= "$breakdown=$key;";
- push @links, \%this_link;
- $i++;
- } #foreach (@base_items
- $hue += 35;
- } # foreach @group_keys
-} else {
- @items = @base_items;
- @labels = @base_labels{@base_items};
- @colors = @base_colors{@base_items};
- @links = @base_links{@base_items};
- @params = map { [ %filter_params ] } @base_items;
-}
-
-</%init>
--- /dev/null
+<& elements/monthly.html,
+ 'title' => $agentname. 'Package Churn',
+ 'items' => \@items,
+ 'labels' => \@labels,
+ 'graph_labels' => \@labels,
+ 'colors' => \@colors,
+ 'links' => \@links,
+ 'params' => \@params,
+ 'agentnum' => $agentnum,
+ 'sprintf' => ( $normalize ? '%0.1f%%' : '%u'),
+ 'normalize' => ( $normalize ? 0 : undef ),
+ 'disable_money' => 1,
+ 'remove_empty' => (scalar(@group_keys) > 1 ? 1 : 0),
+ 'nototal' => 1,
+ 'no_graph' => [ 1, 0, 0, 0, 0 ], # don't graph 'active'
+&>
+<%init>
+
+#XXX use a different ACL for package churn?
+my $curuser = $FS::CurrentUser::CurrentUser;
+die "access denied"
+ unless $curuser->access_right('Financial reports');
+
+#false laziness w/money_time.cgi, cust_bill_pkg.cgi
+
+#XXX or virtual
+my( $agentnum, $agent ) = ('', '');
+if ( $cgi->param('agentnum') =~ /^(\d+)$/ ) {
+ $agentnum = $1;
+ $agent = qsearchs('agent', { 'agentnum' => $agentnum } );
+ die "agentnum $agentnum not found!" unless $agent;
+}
+
+my $agentname = $agent ? $agent->agent.' ' : '';
+
+my @base_items = qw( active_pkg setup_pkg susp_pkg unsusp_pkg cancel_pkg );
+
+my %base_labels = (
+ 'active_pkg' => 'Active packages',
+ 'setup_pkg' => 'New orders',
+ 'susp_pkg' => 'Suspensions',
+ 'unsusp_pkg' => 'Unsuspensions',
+ 'cancel_pkg' => 'Cancellations',
+);
+
+my %base_colors = (
+ 'active_pkg' => '000000', #black
+ 'setup_pkg' => '00cc00', #green
+ 'susp_pkg' => 'ff9900', #yellow
+ 'unsusp_pkg' => '44ff44', #light green
+ 'cancel_pkg' => 'cc0000', #red
+);
+
+my %base_links;
+foreach my $status (qw(active setup cancel susp unsusp)) {
+ $base_links{$status.'_pkg'} =
+ "${p}search/cust_pkg_churn.html?agentnum=$agentnum;status=$status;";
+}
+
+my %filter_params = (
+ # not agentnum, that's elsewhere
+ 'refnum' => [ $cgi->param('refnum') ],
+ 'classnum' => [ $cgi->param('classnum') ],
+ 'towernum' => [ $cgi->param('towernum') ],
+);
+if ( $cgi->param('zip') =~ /^(\w+)/ ) {
+ $filter_params{zip} = $1;
+}
+foreach my $link (values %base_links) {
+ foreach my $key (keys(%filter_params)) {
+ my $value = $filter_params{$key};
+ if (ref($value)) {
+ $value = join(',', @$value);
+ }
+ $link .= "$key=$value;" if length($value);
+ }
+}
+
+
+# In order to keep this from being the same trainwreck as cust_bill_pkg.cgi,
+# we allow ONE breakdown axis, besides the setup/susp/cancel inherent in
+# the report.
+
+my $breakdown = $cgi->param('breakdown_by');
+my ($name_col, $table);
+if ($breakdown eq 'classnum') {
+ $table = 'pkg_class';
+ $name_col = 'classname';
+} elsif ($breakdown eq 'refnum') {
+ $table = 'part_referral';
+ $name_col = 'referral';
+} elsif ($breakdown eq 'towernum') {
+ $table = 'tower';
+ $name_col = 'towername';
+} elsif ($breakdown) {
+ die "unknown breakdown column '$breakdown'\n";
+}
+
+my @group_keys;
+my @group_labels;
+if ( $table ) {
+ my @groups;
+ if ( $cgi->param($breakdown) ) {
+ foreach my $key ($cgi->param($breakdown)) {
+ next if $key =~ /\D/;
+ push @groups, qsearch( $table, { $breakdown => $key });
+ }
+ } else {
+ @groups = qsearch( $table );
+ }
+ foreach (@groups) {
+ push @group_keys, $_->get($breakdown);
+ push @group_labels, $_->get($name_col);
+ }
+}
+
+my (@items, @labels, @colors, @links, @params);
+if (scalar(@group_keys) > 1) {
+ my $hue = 180;
+ foreach my $key (@group_keys) {
+ # this gives a decent level of contrast as long as there aren't too many
+ # result sets
+ my $scheme = Color::Scheme->new
+ ->scheme('triade')
+ ->from_hue($hue)
+ ->distance(0.5);
+ my $label = shift @group_labels;
+ my $i = 0; # item index
+ foreach (@base_items) {
+ # append the item
+ push @items, $_;
+ # and its parameters
+ push @params, [
+ %filter_params,
+ $breakdown => $key
+ ];
+ # and a label prefixed with the group label
+ push @labels, "$label - $base_labels{$_}";
+ # and colors (?!)
+ push @colors, $scheme->colorset->[$i]->[1];
+ # and links...
+ my $this_link = $base_links{$_};
+ $this_link .= "$breakdown=$key;";
+ push @links, $this_link;
+ $i++;
+ } #foreach (@base_items
+ $hue += 35;
+ } # foreach @group_keys
+} else {
+ @items = @base_items;
+ @labels = @base_labels{@base_items};
+ @colors = @base_colors{@base_items};
+ @links = @base_links{@base_items};
+ @params = map { [ %filter_params ] } @base_items;
+}
+
+my $normalize = $cgi->param('normalize');
+
+</%init>
'cust_classnum'=> $opt{'cust_classnum'},
'remove_empty' => $opt{'remove_empty'},
'doublemonths' => $opt{'doublemonths'},
+ 'normalize' => $opt{'normalize'},
);
warn Dumper({ 'REPORTOPTS' => \%reportopts }) if $opt{'debug'};
my @colors;
my @graph_labels;
my @no_graph;
-if ( $opt{'remove_empty'} ) {
+#if ( $opt{'remove_empty'} ) { # no, always do this
# then filter out per-item things for collapsed rows
- foreach my $i (@{ $data->{'indices'} }) {
- push @colors, $opt{'colors'}[$i];
- push @graph_labels, $opt{'graph_labels'}[$i];
- push @no_graph, $opt{'no_graph'}[$i];
- }
-} else {
- @colors = @{ $opt{'colors'} };
- @graph_labels = @{ $opt{'graph_labels'} };
- @no_graph = @{ $opt{'no_graph'} || [] };
+foreach my $i (@{ $data->{'indices'} }) {
+ push @colors, $opt{'colors'}[$i];
+ push @graph_labels, $opt{'graph_labels'}[$i];
+ push @no_graph, $opt{'no_graph'}[$i];
}
my @links;
% foreach ( @{ shift( @data ) } ) {
% $total += $_;
% $bottom_total[$col-1] += $_ unless $opt{no_graph}[$row];
-% $worksheet->write($row, $col++, sprintf($sprintf, $_) );
+% $worksheet->write_number($row, $col++, sprintf($sprintf, $_) );
% }
% if ( !$opt{'nototal'} ) {
% $bottom_total[$col-1] += $total unless $opt{no_graph}[$row];
-% $worksheet->write($row, $col++, sprintf($sprintf, $total) );
+% $worksheet->write_number($row, $col++, sprintf($sprintf, $total) );
% }
% }
%
% if ( $opt{'bottom_total'} ) {
% $row++;
% $worksheet->write($row, $col++, 'Total');
-% $worksheet->write($row, $col++, sprintf($sprintf, $_)) foreach @bottom_total;
+% $worksheet->write_number($row, $col++, sprintf($sprintf, $_)) foreach @bottom_total;
% }
%
% $workbook->close();# or die "Error creating .xls file: $!";
<% include('/elements/header.html', 'Package Churn Summary' ) %>
-<FORM ACTION="cust_pkg.cgi" METHOD="GET">
+<FORM ACTION="cust_pkg.html" METHOD="GET">
<TABLE BGCOLOR="#cccccc" CELLSPACING=0>
},
&>
+<& /elements/tr-checkbox.html,
+ 'field' => 'normalize',
+ 'value' => 1,
+ 'label' => 'Show percentages'
+&>
+
</TABLE>
<BR><INPUT TYPE="submit" VALUE="Display">
--- /dev/null
+<& elements/search.html,
+ 'title' => $title,
+ 'name' => 'packages',
+ 'query' => $sql_query,
+ 'count_query' => $count_query,
+ 'header' => [ emt('#'),
+ emt('Quantity'),
+ emt('Package'),
+ emt('Class'),
+ emt('Sales Person'),
+ emt('Ordered by'),
+ emt('Setup Fee'),
+ emt('Base Recur'),
+ emt('Freq.'),
+ emt('Setup'),
+ emt('Last bill'),
+ emt('Next bill'),
+ emt('Susp.'),
+ emt('Changed'),
+ emt('Cancel'),
+ #emt('Reason'), # hard to do this right
+ FS::UI::Web::cust_header(
+ $cgi->param('cust_fields')
+ ),
+ #emt('Services'), # even harder
+ ],
+ 'fields' => [
+ 'pkgnum',
+ 'quantity',
+ 'pkg',
+ 'classname',
+ 'salesperson',
+ 'otaker',
+ sub { sprintf( $money_char.'%.2f',
+ shift->part_pkg->option('setup_fee'),
+ );
+ },
+ sub { my $c = shift;
+ sprintf( $money_char.'%.2f',
+ $c->part_pkg->base_recur($c)
+ );
+ },
+ sub { FS::part_pkg::freq_pretty(shift); },
+
+ ( map { time_or_blank($_) }
+ qw( setup last_bill bill susp change_date cancel ) ),
+
+ \&FS::UI::Web::cust_fields,
+ ],
+ 'sort_fields' => [
+ 'cust_pkg.pkgnum',
+ ('') x 5, # can use as-is
+ ('') x 3, # can't use at all
+ # use the plain SQL column names
+ qw( setup last_bill bill susp change_date cancel ),
+ # cust_fields can take care of themselves
+ ],
+ 'color' => [
+ ('') x 15,
+ FS::UI::Web::cust_colors(),
+ ],
+ 'style' => [ ('') x 15,
+ FS::UI::Web::cust_styles() ],
+ 'size' => [ '', '', '', '', '-1' ],
+ 'align' => 'rrlcccrrlrrrrrr'. FS::UI::Web::cust_aligns(). 'r',
+ 'links' => [
+ $link,
+ $link,
+ $link,
+ ('') x 12,
+ ( map { $_ ne 'Cust. Status' ? $clink : '' }
+ FS::UI::Web::cust_header(
+ $cgi->param('cust_fields')
+ )
+ ),
+ ],
+&>
+<%once>
+my %title = (
+ 'active' => 'Active packages as of ',
+ 'setup' => 'Packages started between ',
+ 'cancel' => 'Packages canceled between ',
+ 'susp' => 'Packages suspended between ',
+ 'unsusp' => 'Packages unsuspended between ',
+);
+</%once>
+<%init>
+
+my $curuser = $FS::CurrentUser::CurrentUser;
+
+die "access denied"
+ unless $curuser->access_right('List packages');
+
+my $conf = new FS::Conf;
+my $money_char = $conf->config('money_char') || '$';
+
+my %search_hash = ();
+
+# pass a very limited set of parameters through
+#scalars
+for (qw( agentnum zip ))
+{
+ $search_hash{$_} = $cgi->param($_) if length($cgi->param($_));
+}
+
+#arrays / comma-separated lists
+for my $param (qw( pkgpart classnum refnum towernum )) {
+ my @values = map { split(',') } $cgi->param($param);
+ $search_hash{$param} = \@values if scalar(@values);
+}
+
+###
+# do not pass dates to FS::cust_pkg->search; use the special churn_fromwhere
+# logic.
+###
+
+my $pkg_query = FS::cust_pkg->search(\%search_hash);
+#warn Dumper $pkg_query;
+
+my($beginning, $ending) = FS::UI::Web::parse_beginning_ending($cgi);
+my $status = $cgi->param('status');
+
+my $title = emt($title{$status}) .
+ time2str('%b %o %Y', $beginning);
+if ($status ne 'active') {
+ $title .= emt(' to ') . time2str('%b %o %Y', $ending);
+}
+
+my ($from, @where) = FS::h_cust_pkg->churn_fromwhere_sql($status, $beginning, $ending);
+
+push @where, "freq != '0'";
+
+# split off the primary table name
+$from =~ s/^(\w+)(.*)$/$2/s;
+my $table = $1;
+
+# merge with $pkg_query
+$from .= ' ' . $pkg_query->{addl_from};
+
+my $extra_sql;
+if ($pkg_query->{extra_sql}) {
+ $extra_sql = $pkg_query->{extra_sql} . ' AND ';
+} else {
+ $extra_sql = 'WHERE ';
+}
+$extra_sql .= join(' AND ', @where);
+
+my $sql_query = {
+ 'table' => $table,
+ 'addl_from' => $from,
+ 'extra_sql' => $extra_sql,
+};
+warn (Dumper $sql_query) if $cgi->param('debug');
+
+my $count_query = "SELECT COUNT(*) FROM $table $from $extra_sql";
+
+my $show = $curuser->default_customer_view =~ /^(jumbo|packages)$/
+ ? ''
+ : ';show=packages';
+
+my $link = sub {
+ my $self = shift;
+ my $frag = 'cust_pkg'. $self->pkgnum; #hack for IE ignoring real #fragment
+ [ "${p}view/cust_main.cgi?custnum=".$self->custnum.
+ "$show;fragment=$frag#cust_pkg",
+ 'pkgnum'
+ ];
+};
+
+my $clink = sub {
+ my $cust_pkg = shift;
+ $cust_pkg->cust_main_custnum
+ ? [ "${p}view/cust_main.cgi?", 'custnum' ]
+ : '';
+};
+
+sub time_or_blank {
+ my $column = shift;
+ return sub {
+ my $record = shift;
+ my $value = $record->get($column); #mmm closures
+ $value ? time2str('%b %d %Y', $value ) : '';
+ };
+}
+
+</%init>
projects / freeside.git / commitdiff