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 prospect_sql
 252
 253 =item active_sql
 254
 255 =item inactive_sql
 256
 257 =item suspended_sql
 258
 259 =item cancelled_sql
 260
 261 Class methods that return SQL framents, equivalent to the corresponding
 262 FS::cust_main method.
 263
 264 =cut
 265
 266 #      my \$self = shift;
 267 #      \$self->cust_linked
 268 #        ? FS::cust_main::${sub}_sql(\$self)
 269 #        : '0';
 270
 271 foreach my $sub (qw( prospect active inactive suspended cancelled )) {
 272   eval "
 273     sub ${sub}_sql {
 274       confess 'cust_main_Mixin ${sub}_sql called with object' if ref(\$_[0]);
 275       'cust_main.custnum IS NOT NULL AND '. FS::cust_main->${sub}_sql();
 276     }
 277   ";
 278   die $@ if $@;
 279 }
 280
 281 =item cust_search_sql
 282
 283 Returns a list of SQL WHERE fragments to search for parameters specified
 284 in HASHREF.  Valid parameters are:
 285
 286 =over 4
 287
 288 =item agentnum
 289
 290 =item status
 291
 292 =item payby
 293
 294 =back
 295
 296 =cut
 297
 298 sub cust_search_sql {
 299   my($class, $param) = @_;
 300
 301   if ( $DEBUG ) {
 302     warn "$me cust_search_sql called with params: \n".
 303          join("\n", map { "  $_: ". $param->{$_} } keys %$param ). "\n";
 304   }
 305
 306   my @search = ();
 307
 308   if ( $param->{'agentnum'} && $param->{'agentnum'} =~ /^(\d+)$/ ) {
 309     push @search, "cust_main.agentnum = $1";
 310   }
 311
 312   #status (prospect active inactive suspended cancelled)
 313   if ( grep { $param->{'status'} eq $_ } FS::cust_main->statuses() ) {
 314     my $method = $param->{'status'}. '_sql';
 315     push @search, $class->$method();
 316   }
 317
 318   #payby
 319   my @payby = ref($param->{'payby'})
 320                 ? @{ $param->{'payby'} }
 321                 : split(',', $param->{'payby'});
 322   @payby = grep /^([A-Z]{4})$/, @payby;
 323   if ( @payby ) {
 324     push @search, 'cust_main.payby IN ('. join(',', map "'$_'", @payby). ')';
 325   }
 326
 327   #here is the agent virtualization
 328   push @search,
 329     $FS::CurrentUser::CurrentUser->agentnums_sql( 'table' => 'cust_main' );
 330
 331   return @search;
 332
 333 }
 334
 335 =item email_search_result HASHREF
 336
 337 Emails a notice to the specified customers.  Customers without
 338 invoice email destinations will be skipped.
 339
 340 Parameters:
 341
 342 =over 4
 343
 344 =item job
 345
 346 Queue job for status updates.  Required.
 347
 348 =item search
 349
 350 Hashref of params to the L<search()> method.  Required.
 351
 352 =item msgnum
 353
 354 Message template number (see L<FS::msg_template>).  Overrides all
 355 of the following options.
 356
 357 =item from
 358
 359 From: address
 360
 361 =item subject
 362
 363 Email Subject:
 364
 365 =item html_body
 366
 367 HTML body
 368
 369 =item text_body
 370
 371 Text body
 372
 373 =item to_contact_classnum
 374
 375 The customer contact class (or classes, as a comma-separated list) to send
 376 the message to. If unspecified, will be sent to any contacts that are marked
 377 as invoice destinations (the equivalent of specifying 'invoice').
 378
 379 =back
 380
 381 Returns an error message, or false for success.
 382
 383 If any messages fail to send, they will be queued as individual
 384 jobs which can be manually retried.  If the first ten messages
 385 in the job fail, the entire job will abort and return an error.
 386
 387 =cut
 388
 389 use Storable qw(thaw);
 390 use MIME::Base64;
 391 use Data::Dumper qw(Dumper);
 392 use Digest::SHA qw(sha1); # for duplicate checking
 393
 394 sub email_search_result {
 395   my($class, $param) = @_;
 396
 397   my $msgnum = $param->{msgnum};
 398   my $from = delete $param->{from};
 399   my $subject = delete $param->{subject};
 400   my $html_body = delete $param->{html_body};
 401   my $text_body = delete $param->{text_body};
 402   my $to_contact_classnum = delete $param->{to_contact_classnum};
 403   my $error = '';
 404
 405   my $job = delete $param->{'job'}
 406     or die "email_search_result must run from the job queue.\n";
 407
 408   my $msg_template;
 409   if ( $msgnum ) {
 410     $msg_template = qsearchs('msg_template', { msgnum => $msgnum } )
 411       or die "msgnum $msgnum not found\n";
 412   }
 413
 414   my $sql_query = $class->search($param->{'search'});
 415   $sql_query->{'select'} = $sql_query->{'table'} . '.*';
 416
 417   my $count_query   = delete($sql_query->{'count_query'});
 418   my $count_sth = dbh->prepare($count_query)
 419     or die "Error preparing $count_query: ". dbh->errstr;
 420   $count_sth->execute
 421     or die "Error executing $count_query: ". $count_sth->errstr;
 422   my $count_arrayref = $count_sth->fetchrow_arrayref;
 423   my $num_cust = $count_arrayref->[0];
 424
 425   my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
 426   my @retry_jobs = ();
 427   my $dups = 0;
 428   my $success = 0;
 429   my %sent_to = ();
 430
 431   #eventually order+limit magic to reduce memory use?
 432   foreach my $obj ( qsearch($sql_query) ) {
 433
 434     #progressbar first, so that the count is right
 435     $num++;
 436     if ( time - $min_sec > $last ) {
 437       my $error = $job->update_statustext(
 438         int( 100 * $num / $num_cust )
 439       );
 440       die $error if $error;
 441       $last = time;
 442     }
 443
 444     my $cust_main = $obj->cust_main;
 445     tie my %message, 'Tie::IxHash';
 446     if ( !$cust_main ) {
 447       next; # unlinked object; nothing else we can do
 448     }
 449
 450     if ( $msg_template ) {
 451       # Now supports other context objects.
 452       %message = $msg_template->prepare(
 453         'cust_main' => $cust_main,
 454         'object'    => $obj,
 455         'to_contact_classnum' => $to_contact_classnum,
 456       );
 457
 458     } else {
 459       # 3.x: false laziness with msg_template.pm; on 4.x, all email notices
 460       # are generated from templates and this case goes away
 461       my @classes;
 462       if ( $to_contact_classnum ) {
 463         @classes = ref($to_contact_classnum) ? @$to_contact_classnum : split(',', $to_contact_classnum);
 464       }
 465       if (!@classes) {
 466         @classes = ( 'invoice' );
 467       }
 468       my @to = $cust_main->contact_list_email(@classes);
 469       next if !@to;
 470
 471       %message = (
 472         'from'      => $from,
 473         'to'        => \@to,
 474         'subject'   => $subject,
 475         'html_body' => $html_body,
 476         'text_body' => $text_body,
 477         'custnum'   => $cust_main->custnum,
 478       );
 479     } #if $msg_template
 480
 481     # For non-cust_main searches, we avoid duplicates based on message
 482     # body text.
 483     my $unique = $cust_main->custnum;
 484     $unique .= sha1($message{'text_body'}) if $class ne 'FS::cust_main';
 485     if( $sent_to{$unique} ) {
 486       # avoid duplicates
 487       $dups++;
 488       next;
 489     }
 490
 491     $sent_to{$unique} = 1;
 492
 493     $error = send_email( generate_email( %message ) );
 494
 495     if($error) {
 496       # queue the sending of this message so that the user can see what we
 497       # tried to do, and retry if desired
 498       my $queue = new FS::queue {
 499         'job'        => 'FS::Misc::process_send_email',
 500         'custnum'    => $cust_main->custnum,
 501         'status'     => 'failed',
 502         'statustext' => $error,
 503       };
 504       $queue->insert(%message);
 505       push @retry_jobs, $queue;
 506     }
 507     else {
 508       $success++;
 509     }
 510
 511     if($success == 0 and
 512         (scalar(@retry_jobs) > 10 or $num == $num_cust)
 513       ) {
 514       # 10 is arbitrary, but if we have enough failures, that's
 515       # probably a configuration or network problem, and we
 516       # abort the batch and run away screaming.
 517       # We NEVER do this if anything was successfully sent.
 518       $_->delete foreach (@retry_jobs);
 519       return "multiple failures: '$error'\n";
 520     }
 521   } # foreach $obj
 522
 523   if(@retry_jobs) {
 524     # fail the job, but with a status message that makes it clear
 525     # something was sent.
 526     return "Sent $success, skipped $dups duplicate(s), failed ".scalar(@retry_jobs).". Failed attempts placed in job queue.\n";
 527   }
 528
 529   return '';
 530 }
 531
 532 sub process_email_search_result {
 533   my $job = shift;
 534   #warn "$me process_re_X $method for job $job\n" if $DEBUG;
 535
 536   my $param = thaw(decode_base64(shift));
 537   warn Dumper($param) if $DEBUG;
 538
 539   $param->{'job'} = $job;
 540
 541   $param->{'search'} = thaw(decode_base64($param->{'search'}))
 542     or die "process_email_search_result requires search params.\n";
 543
 544 #  $param->{'payby'} = [ split(/\0/, $param->{'payby'}) ]
 545 #    unless ref($param->{'payby'});
 546
 547   my $table = $param->{'table'}
 548     or die "process_email_search_result requires table.\n";
 549
 550   eval "use FS::$table;";
 551   die "error loading FS::$table: $@\n" if $@;
 552
 553   my $error = "FS::$table"->email_search_result( $param );
 554   dbh->commit; # save failed jobs before rethrowing the error
 555   die $error if $error;
 556
 557 }
 558
 559 =item conf
 560
 561 Returns a configuration handle (L<FS::Conf>) set to the customer's locale,
 562 if they have one.  If not, returns an FS::Conf with no locale.
 563
 564 =cut
 565
 566 sub conf {
 567   my $self = shift;
 568   return $self->{_conf} if (ref $self and $self->{_conf});
 569   my $cust_main = $self->cust_main;
 570   my $conf = new FS::Conf {
 571     'locale' => ($cust_main ? $cust_main->locale : '')
 572   };
 573   $self->{_conf} = $conf if ref $self;
 574   return $conf;
 575 }
 576
 577 =item mt TEXT [, ARGS ]
 578
 579 Localizes a text string (see L<Locale::Maketext>) for the customer's locale,
 580 if they have one.
 581
 582 =cut
 583
 584 sub mt {
 585   my $self = shift;
 586   return $self->{_lh}->maketext(@_) if (ref $self and $self->{_lh});
 587   my $cust_main = $self->cust_main;
 588   my $locale = $cust_main ? $cust_main->locale : '';
 589   my $lh = FS::L10N->get_handle($locale);
 590   $self->{_lh} = $lh if ref $self;
 591   return $lh->maketext(@_);
 592 }
 593
 594 =item time2str_local FORMAT, TIME[, ESCAPE]
 595
 596 Localizes a date (see L<Date::Language>) for the customer's locale.
 597
 598 FORMAT can be a L<Date::Format> string, or one of these special words:
 599
 600 - "short": the value of the "date_format" config setting for the customer's
 601   locale, defaulting to "%x".
 602 - "rdate": the same as "short" except that the default has a four-digit year.
 603 - "long": the value of the "date_format_long" config setting for the
 604   customer's locale, defaulting to "%b %o, %Y".
 605
 606 ESCAPE, if specified, is one of "latex" or "html", and will escape non-ASCII
 607 characters and convert spaces to nonbreaking spaces.
 608
 609 =cut
 610
 611 sub time2str_local {
 612   # renamed so that we don't have to change every single reference to
 613   # time2str everywhere
 614   my $self = shift;
 615   my ($format, $time, $escape) = @_;
 616   return '' unless $time > 0; # work around time2str's traditional stupidity
 617
 618   $self->{_date_format} ||= {};
 619   if (!exists($self->{_dh})) {
 620     my $cust_main = $self->cust_main;
 621     my $locale = $cust_main->locale  if $cust_main;
 622     $locale ||= 'en_US';
 623     my %info = FS::Locales->locale_info($locale);
 624     my $dh = eval { Date::Language->new($info{'name'}) } ||
 625              Date::Language->new(); # fall back to English
 626     $self->{_dh} = $dh;
 627   }
 628
 629   if ($format eq 'short') {
 630     $format = $self->{_date_format}->{short}
 631             ||= $self->conf->config('date_format') || '%x';
 632   } elsif ($format eq 'rdate') {
 633     $format = $self->{_date_format}->{rdate}
 634             ||= $self->conf->config('date_format') || '%m/%d/%Y';
 635   } elsif ($format eq 'long') {
 636     $format = $self->{_date_format}->{long}
 637             ||= $self->conf->config('date_format_long') || '%b %o, %Y';
 638   }
 639
 640   # actually render the date
 641   my $string = $self->{_dh}->time2str($format, $time);
 642
 643   if ($escape) {
 644     if ($escape eq 'html') {
 645       $string = encode_entities($string);
 646       $string =~ s/ +/&nbsp;/g;
 647     } elsif ($escape eq 'latex') { # just do nbsp's here
 648       $string =~ s/ +/~/g;
 649     }
 650   }
 651
 652   $string;
 653 }
 654
 655 =item unsuspend_balance
 656
 657 If conf I<unsuspend_balance> is set and customer's current balance is
 658 beneath the set threshold, unsuspends customer packages.
 659
 660 =cut
 661
 662 sub unsuspend_balance {
 663   my $self = shift;
 664   my $cust_main = $self->cust_main;
 665   my $conf = $self->conf;
 666   my $setting = $conf->config('unsuspend_balance');
 667   my $maxbalance;
 668   if ($setting eq 'Zero') {
 669     $maxbalance = 0;
 670
 671   # kind of a pain to load/check all cust_bill instead of just open ones,
 672   # but if for some reason payment gets applied to later bills before
 673   # earlier ones, we still want to consider the later ones as allowable balance
 674   } elsif ($setting eq 'Latest invoice charges') {
 675     my @cust_bill = $cust_main->cust_bill();
 676     my $cust_bill = $cust_bill[-1]; #always want the most recent one
 677     if ($cust_bill) {
 678       $maxbalance = $cust_bill->charged || 0;
 679     } else {
 680       $maxbalance = 0;
 681     }
 682   } elsif ($setting eq 'Charges not past due') {
 683     my $now = time;
 684     $maxbalance = 0;
 685     foreach my $cust_bill ($cust_main->cust_bill()) {
 686       next unless $now <= ($cust_bill->due_date || $cust_bill->_date);
 687       $maxbalance += $cust_bill->charged || 0;
 688     }
 689   } elsif (length($setting)) {
 690     warn "Unrecognized unsuspend_balance setting $setting";
 691     return;
 692   } else {
 693     return;
 694   }
 695   my $balance = $cust_main->balance || 0;
 696   if ($balance <= $maxbalance) {
 697     my @errors = $cust_main->unsuspend;
 698     # side-fx with nested transactions?  upstack rolls back?
 699     warn "WARNING:Errors unsuspending customer ". $cust_main->custnum. ": ".
 700          join(' / ', @errors)
 701       if @errors;
 702   }
 703   return;
 704 }
 705
 706 =back
 707
 708 =head1 BUGS
 709
 710 =head1 SEE ALSO
 711
 712 L<FS::cust_main>, L<FS::Record>
 713
 714 =cut
 715
 716 1;
 717