FS/FS/cust_main_Mixin.pm

   1 package FS::cust_main_Mixin;
   2
   3 use strict;
   4 use vars qw( $DEBUG $me );
   5 use Carp qw( confess carp cluck );
   6 use FS::UID qw(dbh);
   7 use FS::cust_main;
   8 use FS::Record qw( qsearch qsearchs );
   9 use FS::Misc qw( send_email generate_email );
  10 use HTML::Entities;
  11
  12 $DEBUG = 0;
  13 $me = '[FS::cust_main_Mixin]';
  14
  15 =head1 NAME
  16
  17 FS::cust_main_Mixin - Mixin class for records that contain fields from cust_main
  18
  19 =head1 SYNOPSIS
  20
  21 package FS::some_table;
  22 use vars qw(@ISA);
  23 @ISA = qw( FS::cust_main_Mixin FS::Record );
  24
  25 =head1 DESCRIPTION
  26
  27 This is a mixin class for records that contain fields from the cust_main table,
  28 for example, from a JOINed search.  See httemplate/search/ for examples.
  29
  30 =head1 METHODS
  31
  32 =over 4
  33
  34 =cut
  35
  36 sub cust_unlinked_msg { '(unlinked)'; }
  37 sub cust_linked { $_[0]->custnum; }
  38
  39 sub cust_main {
  40   my $self = shift;
  41   cluck ref($self). '->cust_main called' if $DEBUG;
  42   $self->cust_linked ? qsearchs('cust_main', {custnum => $self->custnum}) : '';
  43 }
  44
  45 =item display_custnum
  46
  47 Given an object that contains fields from cust_main (say, from a JOINed
  48 search; see httemplate/search/ for examples), returns the equivalent of the
  49 FS::cust_main I<name> method, or "(unlinked)" if this object is not linked to
  50 a customer.
  51
  52 =cut
  53
  54 sub display_custnum {
  55   my $self = shift;
  56   $self->cust_linked
  57     ? FS::cust_main::display_custnum($self)
  58     : $self->cust_unlinked_msg;
  59 }
  60
  61 =item name
  62
  63 Given an object that contains fields from cust_main (say, from a JOINed
  64 search; see httemplate/search/ for examples), returns the equivalent of the
  65 FS::cust_main I<name> method, or "(unlinked)" if this object is not linked to
  66 a customer.
  67
  68 =cut
  69
  70 sub name {
  71   my $self = shift;
  72   $self->cust_linked
  73     ? FS::cust_main::name($self)
  74     : $self->cust_unlinked_msg;
  75 }
  76
  77 =item ship_name
  78
  79 Given an object that contains fields from cust_main (say, from a JOINed
  80 search; see httemplate/search/ for examples), returns the equivalent of the
  81 FS::cust_main I<ship_name> method, or "(unlinked)" if this object is not
  82 linked to a customer.
  83
  84 =cut
  85
  86 sub ship_name {
  87   my $self = shift;
  88   $self->cust_linked
  89     ? FS::cust_main::ship_name($self)
  90     : $self->cust_unlinked_msg;
  91 }
  92
  93 =item contact
  94
  95 Given an object that contains fields from cust_main (say, from a JOINed
  96 search; see httemplate/search/ for examples), returns the equivalent of the
  97 FS::cust_main I<contact> method, or "(unlinked)" if this object is not linked
  98 to a customer.
  99
 100 =cut
 101
 102 sub contact {
 103   my $self = shift;
 104   $self->cust_linked
 105     ? FS::cust_main::contact($self)
 106     : $self->cust_unlinked_msg;
 107 }
 108
 109 =item ship_contact
 110
 111 Given an object that contains fields from cust_main (say, from a JOINed
 112 search; see httemplate/search/ for examples), returns the equivalent of the
 113 FS::cust_main I<ship_contact> method, or "(unlinked)" if this object is not
 114 linked to a customer.
 115
 116 =cut
 117
 118 sub ship_contact {
 119   my $self = shift;
 120   $self->cust_linked
 121     ? FS::cust_main::ship_contact($self)
 122     : $self->cust_unlinked_msg;
 123 }
 124
 125 =item country_full
 126
 127 Given an object that contains fields from cust_main (say, from a JOINed
 128 search; see httemplate/search/ for examples), returns the equivalent of the
 129 FS::cust_main I<country_full> method, or "(unlinked)" if this object is not
 130 linked to a customer.
 131
 132 =cut
 133
 134 sub country_full {
 135   my $self = shift;
 136   if ( $self->locationnum ) {  # cust_pkg has this
 137     my $location = FS::cust_location->by_key($self->locationnum);
 138     $location ? $location->country_full : '';
 139   } elsif ( $self->cust_linked ) {
 140     $self->cust_main->bill_country_full;
 141   }
 142 }
 143
 144 =item invoicing_list_emailonly
 145
 146 Given an object that contains fields from cust_main (say, from a JOINed
 147 search; see httemplate/search/ for examples), returns the equivalent of the
 148 FS::cust_main I<invoicing_list_emailonly> method, or "(unlinked)" if this
 149 object is not linked to a customer.
 150
 151 =cut
 152
 153 sub invoicing_list_emailonly {
 154   my $self = shift;
 155   warn "invoicing_list_email only called on $self, ".
 156        "custnum ". $self->custnum. "\n"
 157     if $DEBUG;
 158   $self->cust_linked
 159     ? FS::cust_main::invoicing_list_emailonly($self)
 160     : $self->cust_unlinked_msg;
 161 }
 162
 163 =item invoicing_list_emailonly_scalar
 164
 165 Given an object that contains fields from cust_main (say, from a JOINed
 166 search; see httemplate/search/ for examples), returns the equivalent of the
 167 FS::cust_main I<invoicing_list_emailonly_scalar> method, or "(unlinked)" if
 168 this object is not linked to a customer.
 169
 170 =cut
 171
 172 sub invoicing_list_emailonly_scalar {
 173   my $self = shift;
 174   warn "invoicing_list_emailonly called on $self, ".
 175        "custnum ". $self->custnum. "\n"
 176     if $DEBUG;
 177   $self->cust_linked
 178     ? FS::cust_main::invoicing_list_emailonly_scalar($self)
 179     : $self->cust_unlinked_msg;
 180 }
 181
 182 =item invoicing_list
 183
 184 Given an object that contains fields from cust_main (say, from a JOINed
 185 search; see httemplate/search/ for examples), returns the equivalent of the
 186 FS::cust_main I<invoicing_list> method, or "(unlinked)" if this object is not
 187 linked to a customer.
 188
 189 Note: this method is read-only.
 190
 191 =cut
 192
 193 #read-only
 194 sub invoicing_list {
 195   my $self = shift;
 196   $self->cust_linked
 197     ? FS::cust_main::invoicing_list($self)
 198     : ();
 199 }
 200
 201 =item status
 202
 203 Given an object that contains fields from cust_main (say, from a JOINed
 204 search; see httemplate/search/ for examples), returns the equivalent of the
 205 FS::cust_main I<status> method, or "(unlinked)" if this object is not linked to
 206 a customer.
 207
 208 =cut
 209
 210 sub cust_status {
 211   my $self = shift;
 212   return $self->cust_unlinked_msg unless $self->cust_linked;
 213   my $cust_main = $self->cust_main;
 214   return $self->cust_unlinked_msg unless $cust_main;
 215   return $cust_main->cust_status;
 216 }
 217
 218 =item ucfirst_cust_status
 219
 220 Given an object that contains fields from cust_main (say, from a JOINed
 221 search; see httemplate/search/ for examples), returns the equivalent of the
 222 FS::cust_main I<ucfirst_status> method, or "(unlinked)" if this object is not
 223 linked to a customer.
 224
 225 =cut
 226
 227 sub ucfirst_cust_status {
 228   my $self = shift;
 229   $self->cust_linked
 230     ? ucfirst( $self->cust_status(@_) )
 231     : $self->cust_unlinked_msg;
 232 }
 233
 234 =item cust_statuscolor
 235
 236 Given an object that contains fields from cust_main (say, from a JOINed
 237 search; see httemplate/search/ for examples), returns the equivalent of the
 238 FS::cust_main I<statuscol> method, or "000000" if this object is not linked to
 239 a customer.
 240
 241 =cut
 242
 243 sub cust_statuscolor {
 244   my $self = shift;
 245
 246   $self->cust_linked
 247     ? FS::cust_main::cust_statuscolor($self)
 248     : '000000';
 249 }
 250
 251 =item agent_name
 252
 253 =cut
 254
 255 sub agent_name {
 256   my $self = shift;
 257   $self->cust_linked
 258     ? $self->cust_main->agent_name
 259     : $self->cust_unlinked_msg;
 260 }
 261
 262 =item prospect_sql
 263
 264 =item active_sql
 265
 266 =item inactive_sql
 267
 268 =item suspended_sql
 269
 270 =item cancelled_sql
 271
 272 Class methods that return SQL framents, equivalent to the corresponding
 273 FS::cust_main method.
 274
 275 =cut
 276
 277 #      my \$self = shift;
 278 #      \$self->cust_linked
 279 #        ? FS::cust_main::${sub}_sql(\$self)
 280 #        : '0';
 281
 282 foreach my $sub (qw( prospect active inactive suspended cancelled )) {
 283   eval "
 284     sub ${sub}_sql {
 285       confess 'cust_main_Mixin ${sub}_sql called with object' if ref(\$_[0]);
 286       'cust_main.custnum IS NOT NULL AND '. FS::cust_main->${sub}_sql();
 287     }
 288   ";
 289   die $@ if $@;
 290 }
 291
 292 =item cust_search_sql
 293
 294 Returns a list of SQL WHERE fragments to search for parameters specified
 295 in HASHREF.  Valid parameters are:
 296
 297 =over 4
 298
 299 =item agentnum
 300
 301 =item status
 302
 303 =item payby
 304
 305 =back
 306
 307 =cut
 308
 309 sub cust_search_sql {
 310   my($class, $param) = @_;
 311
 312   if ( $DEBUG ) {
 313     warn "$me cust_search_sql called with params: \n".
 314          join("\n", map { "  $_: ". $param->{$_} } keys %$param ). "\n";
 315   }
 316
 317   my @search = ();
 318
 319   if ( $param->{'agentnum'} && $param->{'agentnum'} =~ /^(\d+)$/ ) {
 320     push @search, "cust_main.agentnum = $1";
 321   }
 322
 323   #status (prospect active inactive suspended cancelled)
 324   if ( grep { $param->{'status'} eq $_ } FS::cust_main->statuses() ) {
 325     my $method = $param->{'status'}. '_sql';
 326     push @search, $class->$method();
 327   }
 328
 329   #payby
 330   my @payby = ref($param->{'payby'})
 331                 ? @{ $param->{'payby'} }
 332                 : split(',', $param->{'payby'});
 333   @payby = grep /^([A-Z]{4})$/, @payby;
 334   if ( @payby ) {
 335     push @search, 'cust_main.payby IN ('. join(',', map "'$_'", @payby). ')';
 336   }
 337
 338   #here is the agent virtualization
 339   push @search,
 340     $FS::CurrentUser::CurrentUser->agentnums_sql( 'table' => 'cust_main' );
 341
 342   return @search;
 343
 344 }
 345
 346 =item email_search_result HASHREF
 347
 348 Emails a notice to the specified customers.  Customers without
 349 invoice email destinations will be skipped.
 350
 351 Parameters:
 352
 353 =over 4
 354
 355 =item job
 356
 357 Queue job for status updates.  Required.
 358
 359 =item search
 360
 361 Hashref of params to the L<FS::Record/search> method.  Required.
 362
 363 =item msgnum
 364
 365 Message template number (see L<FS::msg_template>).  Overrides all
 366 of the following options.
 367
 368 =item from
 369
 370 From: address
 371
 372 =item subject
 373
 374 Email Subject:
 375
 376 =item html_body
 377
 378 HTML body
 379
 380 =item text_body
 381
 382 Text body
 383
 384 =item to_contact_classnum
 385
 386 The customer contact class (or classes, as a comma-separated list) to send
 387 the message to. If unspecified, will be sent to any contacts that are marked
 388 as invoice destinations (the equivalent of specifying 'invoice').
 389
 390 =back
 391
 392 Returns an error message, or false for success.
 393
 394 If any messages fail to send, they will be queued as individual
 395 jobs which can be manually retried.  If the first ten messages
 396 in the job fail, the entire job will abort and return an error.
 397
 398 =cut
 399
 400 use Storable qw(thaw);
 401 use MIME::Base64;
 402 use Data::Dumper qw(Dumper);
 403 use Digest::SHA qw(sha1); # for duplicate checking
 404
 405 sub email_search_result {
 406   my($class, $param) = @_;
 407
 408   my $conf = FS::Conf->new;
 409   my $send_to_domain = $conf->config('email-to-voice_domain');
 410
 411   my $msgnum = $param->{msgnum};
 412   my $from = delete $param->{from};
 413   my $subject = delete $param->{subject};
 414   my $html_body = delete $param->{html_body};
 415   my $text_body = delete $param->{text_body};
 416   my $to_contact_classnum = delete $param->{to_contact_classnum};
 417   my $emailtovoice_name = delete $param->{emailtovoice_contact};
 418
 419   my $error = '';
 420
 421   my $to = $emailtovoice_name . '@' . $send_to_domain unless !$emailtovoice_name;
 422
 423   my $job = delete $param->{'job'}
 424     or die "email_search_result must run from the job queue.\n";
 425
 426   my $msg_template;
 427   if ( $msgnum ) {
 428     $msg_template = qsearchs('msg_template', { msgnum => $msgnum } )
 429       or die "msgnum $msgnum not found\n";
 430   }
 431
 432   my $sql_query = $class->search($param->{'search'});
 433   $sql_query->{'select'} = $sql_query->{'table'} . '.*';
 434
 435   my $count_query   = delete($sql_query->{'count_query'});
 436   my $count_sth = dbh->prepare($count_query)
 437     or die "Error preparing $count_query: ". dbh->errstr;
 438   $count_sth->execute
 439     or die "Error executing $count_query: ". $count_sth->errstr;
 440   my $count_arrayref = $count_sth->fetchrow_arrayref;
 441   my $num_cust = $count_arrayref->[0];
 442
 443   my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
 444   my @retry_jobs = ();
 445   my $dups = 0;
 446   my $success = 0;
 447   my %sent_to = ();
 448
 449   #eventually order+limit magic to reduce memory use?
 450   foreach my $obj ( qsearch($sql_query) ) {
 451
 452     #progressbar first, so that the count is right
 453     $num++;
 454     if ( time - $min_sec > $last ) {
 455       my $error = $job->update_statustext(
 456         int( 100 * $num / $num_cust )
 457       );
 458       die $error if $error;
 459       $last = time;
 460     }
 461
 462     my $cust_main = $obj->cust_main;
 463     tie my %message, 'Tie::IxHash';
 464     if ( !$cust_main ) {
 465       next; # unlinked object; nothing else we can do
 466     }
 467
 468     my %to = ( to => $to ) if $to;
 469
 470     if ( $msg_template ) {
 471       # Now supports other context objects.
 472       %message = $msg_template->prepare(
 473         'cust_main' => $cust_main,
 474         'object'    => $obj,
 475         'to_contact_classnum' => $to_contact_classnum,
 476         %to
 477       );
 478
 479     } else {
 480       # 3.x: false laziness with msg_template.pm; on 4.x, all email notices
 481       # are generated from templates and this case goes away
 482       my @classes;
 483       if ( $to_contact_classnum ) {
 484         @classes = ref($to_contact_classnum) ? @$to_contact_classnum : split(',', $to_contact_classnum);
 485       }
 486       if (!@classes) {
 487         @classes = ( 'invoice' );
 488       }
 489       my @to = $to ? split(',', $to) : $cust_main->contact_list_email(@classes);
 490       next if !@to;
 491
 492       %message = (
 493         'from'      => $from,
 494         'to'        => \@to,
 495         'subject'   => $subject,
 496         'html_body' => $html_body,
 497         'text_body' => $text_body,
 498         'custnum'   => $cust_main->custnum,
 499       );
 500     } #if $msg_template
 501
 502     # For non-cust_main searches, we avoid duplicates based on message
 503     # body text.
 504     my $unique = $cust_main->custnum;
 505     $unique .= sha1($message{'text_body'}) if $class ne 'FS::cust_main';
 506     if( $sent_to{$unique} ) {
 507       # avoid duplicates
 508       $dups++;
 509       next;
 510     }
 511
 512     $sent_to{$unique} = 1;
 513
 514     $error = send_email( generate_email( %message ) );
 515
 516     if($error) {
 517       # queue the sending of this message so that the user can see what we
 518       # tried to do, and retry if desired
 519       my $queue = new FS::queue {
 520         'job'        => 'FS::Misc::process_send_email',
 521         'custnum'    => $cust_main->custnum,
 522         'status'     => 'failed',
 523         'statustext' => $error,
 524       };
 525       $queue->insert(%message);
 526       push @retry_jobs, $queue;
 527     }
 528     else {
 529       $success++;
 530     }
 531
 532     if($success == 0 and
 533         (scalar(@retry_jobs) > 10 or $num == $num_cust)
 534       ) {
 535       # 10 is arbitrary, but if we have enough failures, that's
 536       # probably a configuration or network problem, and we
 537       # abort the batch and run away screaming.
 538       # We NEVER do this if anything was successfully sent.
 539       $_->delete foreach (@retry_jobs);
 540       return "multiple failures: '$error'\n";
 541     }
 542   } # foreach $obj
 543
 544   if(@retry_jobs) {
 545     # fail the job, but with a status message that makes it clear
 546     # something was sent.
 547     return "Sent $success, skipped $dups duplicate(s), failed ".scalar(@retry_jobs).". Failed attempts placed in job queue.\n";
 548   }
 549
 550   return '';
 551 }
 552
 553 sub process_email_search_result {
 554   my $job = shift;
 555   #warn "$me process_re_X $method for job $job\n" if $DEBUG;
 556
 557   my $param = thaw(decode_base64(shift));
 558   warn Dumper($param) if $DEBUG;
 559
 560   $param->{'job'} = $job;
 561
 562   $param->{'search'} = thaw(decode_base64($param->{'search'}))
 563     or die "process_email_search_result requires search params.\n";
 564
 565 #  $param->{'payby'} = [ split(/\0/, $param->{'payby'}) ]
 566 #    unless ref($param->{'payby'});
 567
 568   my $table = $param->{'table'}
 569     or die "process_email_search_result requires table.\n";
 570
 571   eval "use FS::$table;";
 572   die "error loading FS::$table: $@\n" if $@;
 573
 574   my $error = "FS::$table"->email_search_result( $param );
 575   dbh->commit; # save failed jobs before rethrowing the error
 576   die $error if $error;
 577
 578 }
 579
 580 =item conf
 581
 582 Returns a configuration handle (L<FS::Conf>) set to the customer's locale,
 583 if they have one.  If not, returns an FS::Conf with no locale.
 584
 585 =cut
 586
 587 sub conf {
 588   my $self = shift;
 589   return $self->{_conf} if (ref $self and $self->{_conf});
 590   my $cust_main = $self->cust_main;
 591   my $conf = new FS::Conf {
 592     'locale' => ($cust_main ? $cust_main->locale : '')
 593   };
 594   $self->{_conf} = $conf if ref $self;
 595   return $conf;
 596 }
 597
 598 =item mt TEXT [, ARGS ]
 599
 600 Localizes a text string (see L<Locale::Maketext>) for the customer's locale,
 601 if they have one.
 602
 603 =cut
 604
 605 sub mt {
 606   my $self = shift;
 607   return $self->{_lh}->maketext(@_) if (ref $self and $self->{_lh});
 608   my $cust_main = $self->cust_main;
 609   my $locale = $cust_main ? $cust_main->locale : '';
 610   my $lh = FS::L10N->get_handle($locale);
 611   $self->{_lh} = $lh if ref $self;
 612   return $lh->maketext(@_);
 613 }
 614
 615 =item time2str_local FORMAT, TIME[, ESCAPE]
 616
 617 Localizes a date (see L<Date::Language>) for the customer's locale.
 618
 619 FORMAT can be a L<Date::Format> string, or one of these special words:
 620
 621 - "short": the value of the "date_format" config setting for the customer's
 622   locale, defaulting to "%x".
 623 - "rdate": the same as "short" except that the default has a four-digit year.
 624 - "long": the value of the "date_format_long" config setting for the
 625   customer's locale, defaulting to "%b %o, %Y".
 626
 627 ESCAPE, if specified, is one of "latex" or "html", and will escape non-ASCII
 628 characters and convert spaces to nonbreaking spaces.
 629
 630 =cut
 631
 632 sub time2str_local {
 633   # renamed so that we don't have to change every single reference to
 634   # time2str everywhere
 635   my $self = shift;
 636   my ($format, $time, $escape) = @_;
 637   return '' unless $time > 0; # work around time2str's traditional stupidity
 638
 639   $self->{_date_format} ||= {};
 640   if (!exists($self->{_dh})) {
 641     my $cust_main = $self->cust_main;
 642     my $locale = $cust_main->locale  if $cust_main;
 643     $locale ||= 'en_US';
 644     my %info = FS::Locales->locale_info($locale);
 645     my $dh = eval { Date::Language->new($info{'name'}) } ||
 646              Date::Language->new(); # fall back to English
 647     $self->{_dh} = $dh;
 648   }
 649
 650   if ($format eq 'short') {
 651     $format = $self->{_date_format}->{short}
 652             ||= $self->conf->config('date_format') || '%x';
 653   } elsif ($format eq 'rdate') {
 654     $format = $self->{_date_format}->{rdate}
 655             ||= $self->conf->config('date_format') || '%m/%d/%Y';
 656   } elsif ($format eq 'long') {
 657     $format = $self->{_date_format}->{long}
 658             ||= $self->conf->config('date_format_long') || '%b %o, %Y';
 659   }
 660
 661   # actually render the date
 662   my $string = $self->{_dh}->time2str($format, $time);
 663
 664   if ($escape) {
 665     if ($escape eq 'html') {
 666       $string = encode_entities($string);
 667       $string =~ s/ +/&nbsp;/g;
 668     } elsif ($escape eq 'latex') { # just do nbsp's here
 669       $string =~ s/ +/~/g;
 670     }
 671   }
 672
 673   $string;
 674 }
 675
 676 =item unsuspend_balance
 677
 678 If conf I<unsuspend_balance> is set and customer's current balance is
 679 beneath the set threshold, unsuspends customer packages.
 680
 681 =cut
 682
 683 sub unsuspend_balance {
 684   my $self = shift;
 685   my $cust_main = $self->cust_main;
 686   my $conf = $self->conf;
 687   my $setting = $conf->config('unsuspend_balance');
 688   my $maxbalance;
 689   if ($setting eq 'Zero') {
 690     $maxbalance = 0;
 691
 692   # kind of a pain to load/check all cust_bill instead of just open ones,
 693   # but if for some reason payment gets applied to later bills before
 694   # earlier ones, we still want to consider the later ones as allowable balance
 695   } elsif ($setting eq 'Latest invoice charges') {
 696     my @cust_bill = $cust_main->cust_bill();
 697     my $cust_bill = $cust_bill[-1]; #always want the most recent one
 698     if ($cust_bill) {
 699       $maxbalance = $cust_bill->charged || 0;
 700     } else {
 701       $maxbalance = 0;
 702     }
 703   } elsif ($setting eq 'Charges not past due') {
 704     my $now = time;
 705     $maxbalance = 0;
 706     foreach my $cust_bill ($cust_main->cust_bill()) {
 707       next unless $now <= ($cust_bill->due_date || $cust_bill->_date);
 708       $maxbalance += $cust_bill->charged || 0;
 709     }
 710   } elsif (length($setting)) {
 711     warn "Unrecognized unsuspend_balance setting $setting";
 712     return;
 713   } else {
 714     return;
 715   }
 716   my $balance = $cust_main->balance || 0;
 717   if ($balance <= $maxbalance) {
 718     my @errors = $cust_main->unsuspend(
 719                    'reason_type' => $conf->config('unsuspend_reason_type')
 720                  );
 721     # side-fx with nested transactions?  upstack rolls back?
 722     warn "WARNING:Errors unsuspending customer ". $cust_main->custnum. ": ".
 723          join(' / ', @errors)
 724       if @errors;
 725   }
 726   return;
 727 }
 728
 729 =back
 730
 731 =head1 BUGS
 732
 733 =head1 SEE ALSO
 734
 735 L<FS::cust_main>, L<FS::Record>
 736
 737 =cut
 738
 739 1;
 740