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