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