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