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