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 );
   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   $self->cust_linked ? qsearchs('cust_main', {custnum => $self->custnum}) : '';
  42 }
  43
  44 =item display_custnum
  45
  46 Given an object that contains fields from cust_main (say, from a JOINed
  47 search; see httemplate/search/ for examples), returns the equivalent of the
  48 FS::cust_main I<name> method, or "(unlinked)" if this object is not linked to
  49 a customer.
  50
  51 =cut
  52
  53 sub display_custnum {
  54   my $self = shift;
  55   $self->cust_linked
  56     ? FS::cust_main::display_custnum($self)
  57     : $self->cust_unlinked_msg;
  58 }
  59
  60 =item name
  61
  62 Given an object that contains fields from cust_main (say, from a JOINed
  63 search; see httemplate/search/ for examples), returns the equivalent of the
  64 FS::cust_main I<name> method, or "(unlinked)" if this object is not linked to
  65 a customer.
  66
  67 =cut
  68
  69 sub name {
  70   my $self = shift;
  71   $self->cust_linked
  72     ? FS::cust_main::name($self)
  73     : $self->cust_unlinked_msg;
  74 }
  75
  76 =item ship_name
  77
  78 Given an object that contains fields from cust_main (say, from a JOINed
  79 search; see httemplate/search/ for examples), returns the equivalent of the
  80 FS::cust_main I<ship_name> method, or "(unlinked)" if this object is not
  81 linked to a customer.
  82
  83 =cut
  84
  85 sub ship_name {
  86   my $self = shift;
  87   $self->cust_linked
  88     ? FS::cust_main::ship_name($self)
  89     : $self->cust_unlinked_msg;
  90 }
  91
  92 =item contact
  93
  94 Given an object that contains fields from cust_main (say, from a JOINed
  95 search; see httemplate/search/ for examples), returns the equivalent of the
  96 FS::cust_main I<contact> method, or "(unlinked)" if this object is not linked
  97 to a customer.
  98
  99 =cut
 100
 101 sub contact {
 102   my $self = shift;
 103   $self->cust_linked
 104     ? FS::cust_main::contact($self)
 105     : $self->cust_unlinked_msg;
 106 }
 107
 108 =item ship_contact
 109
 110 Given an object that contains fields from cust_main (say, from a JOINed
 111 search; see httemplate/search/ for examples), returns the equivalent of the
 112 FS::cust_main I<ship_contact> method, or "(unlinked)" if this object is not
 113 linked to a customer.
 114
 115 =cut
 116
 117 sub ship_contact {
 118   my $self = shift;
 119   $self->cust_linked
 120     ? FS::cust_main::ship_contact($self)
 121     : $self->cust_unlinked_msg;
 122 }
 123
 124 =item country_full
 125
 126 Given an object that contains fields from cust_main (say, from a JOINed
 127 search; see httemplate/search/ for examples), returns the equivalent of the
 128 FS::cust_main I<country_full> method, or "(unlinked)" if this object is not
 129 linked to a customer.
 130
 131 =cut
 132
 133 sub country_full {
 134   my $self = shift;
 135   if ( $self->locationnum ) {  # cust_pkg has this
 136     my $location = FS::cust_location->by_key($self->locationnum);
 137     $location ? $location->country_full : '';
 138   } elsif ( $self->cust_linked ) {
 139     $self->cust_main->bill_country_full;
 140   }
 141 }
 142
 143 =item invoicing_list_emailonly
 144
 145 Given an object that contains fields from cust_main (say, from a JOINed
 146 search; see httemplate/search/ for examples), returns the equivalent of the
 147 FS::cust_main I<invoicing_list_emailonly> method, or "(unlinked)" if this
 148 object is not linked to a customer.
 149
 150 =cut
 151
 152 sub invoicing_list_emailonly {
 153   my $self = shift;
 154   warn "invoicing_list_email only called on $self, ".
 155        "custnum ". $self->custnum. "\n"
 156     if $DEBUG;
 157   $self->cust_linked
 158     ? FS::cust_main::invoicing_list_emailonly($self)
 159     : $self->cust_unlinked_msg;
 160 }
 161
 162 =item invoicing_list_emailonly_scalar
 163
 164 Given an object that contains fields from cust_main (say, from a JOINed
 165 search; see httemplate/search/ for examples), returns the equivalent of the
 166 FS::cust_main I<invoicing_list_emailonly_scalar> method, or "(unlinked)" if
 167 this object is not linked to a customer.
 168
 169 =cut
 170
 171 sub invoicing_list_emailonly_scalar {
 172   my $self = shift;
 173   warn "invoicing_list_emailonly called on $self, ".
 174        "custnum ". $self->custnum. "\n"
 175     if $DEBUG;
 176   $self->cust_linked
 177     ? FS::cust_main::invoicing_list_emailonly_scalar($self)
 178     : $self->cust_unlinked_msg;
 179 }
 180
 181 =item invoicing_list
 182
 183 Given an object that contains fields from cust_main (say, from a JOINed
 184 search; see httemplate/search/ for examples), returns the equivalent of the
 185 FS::cust_main I<invoicing_list> method, or "(unlinked)" if this object is not
 186 linked to a customer.
 187
 188 Note: this method is read-only.
 189
 190 =cut
 191
 192 #read-only
 193 sub invoicing_list {
 194   my $self = shift;
 195   $self->cust_linked
 196     ? FS::cust_main::invoicing_list($self)
 197     : ();
 198 }
 199
 200 =item status
 201
 202 Given an object that contains fields from cust_main (say, from a JOINed
 203 search; see httemplate/search/ for examples), returns the equivalent of the
 204 FS::cust_main I<status> method, or "(unlinked)" if this object is not linked to
 205 a customer.
 206
 207 =cut
 208
 209 sub cust_status {
 210   my $self = shift;
 211   return $self->cust_unlinked_msg unless $self->cust_linked;
 212
 213   #FS::cust_main::status($self)
 214   #false laziness w/actual cust_main::status
 215   # (make sure FS::cust_main methods are called)
 216   for my $status (qw( prospect active inactive suspended cancelled )) {
 217     my $method = $status.'_sql';
 218     my $sql = FS::cust_main->$method();;
 219     my $numnum = ( $sql =~ s/cust_main\.custnum/?/g );
 220     my $sth = dbh->prepare("SELECT $sql") or die dbh->errstr;
 221     $sth->execute( ($self->custnum) x $numnum )
 222       or die "Error executing 'SELECT $sql': ". $sth->errstr;
 223     return $status if $sth->fetchrow_arrayref->[0];
 224   }
 225 }
 226
 227 =item ucfirst_cust_status
 228
 229 Given an object that contains fields from cust_main (say, from a JOINed
 230 search; see httemplate/search/ for examples), returns the equivalent of the
 231 FS::cust_main I<ucfirst_status> method, or "(unlinked)" if this object is not
 232 linked to a customer.
 233
 234 =cut
 235
 236 sub ucfirst_cust_status {
 237   my $self = shift;
 238   $self->cust_linked
 239     ? ucfirst( $self->cust_status(@_) )
 240     : $self->cust_unlinked_msg;
 241 }
 242
 243 =item cust_statuscolor
 244
 245 Given an object that contains fields from cust_main (say, from a JOINed
 246 search; see httemplate/search/ for examples), returns the equivalent of the
 247 FS::cust_main I<statuscol> method, or "000000" if this object is not linked to
 248 a customer.
 249
 250 =cut
 251
 252 sub cust_statuscolor {
 253   my $self = shift;
 254
 255   $self->cust_linked
 256     ? FS::cust_main::cust_statuscolor($self)
 257     : '000000';
 258 }
 259
 260 =item prospect_sql
 261
 262 =item active_sql
 263
 264 =item inactive_sql
 265
 266 =item suspended_sql
 267
 268 =item cancelled_sql
 269
 270 Class methods that return SQL framents, equivalent to the corresponding
 271 FS::cust_main method.
 272
 273 =cut
 274
 275 #      my \$self = shift;
 276 #      \$self->cust_linked
 277 #        ? FS::cust_main::${sub}_sql(\$self)
 278 #        : '0';
 279
 280 foreach my $sub (qw( prospect active inactive suspended cancelled )) {
 281   eval "
 282     sub ${sub}_sql {
 283       confess 'cust_main_Mixin ${sub}_sql called with object' if ref(\$_[0]);
 284       'cust_main.custnum IS NOT NULL AND '. FS::cust_main->${sub}_sql();
 285     }
 286   ";
 287   die $@ if $@;
 288 }
 289
 290 =item cust_search_sql
 291
 292 Returns a list of SQL WHERE fragments to search for parameters specified
 293 in HASHREF.  Valid parameters are:
 294
 295 =over 4
 296
 297 =item agentnum
 298
 299 =item status
 300
 301 =item payby
 302
 303 =back
 304
 305 =cut
 306
 307 sub cust_search_sql {
 308   my($class, $param) = @_;
 309
 310   if ( $DEBUG ) {
 311     warn "$me cust_search_sql called with params: \n".
 312          join("\n", map { "  $_: ". $param->{$_} } keys %$param ). "\n";
 313   }
 314
 315   my @search = ();
 316
 317   if ( $param->{'agentnum'} && $param->{'agentnum'} =~ /^(\d+)$/ ) {
 318     push @search, "cust_main.agentnum = $1";
 319   }
 320
 321   #status (prospect active inactive suspended cancelled)
 322   if ( grep { $param->{'status'} eq $_ } FS::cust_main->statuses() ) {
 323     my $method = $param->{'status'}. '_sql';
 324     push @search, $class->$method();
 325   }
 326
 327   #payby
 328   my @payby = ref($param->{'payby'})
 329                 ? @{ $param->{'payby'} }
 330                 : split(',', $param->{'payby'});
 331   @payby = grep /^([A-Z]{4})$/, @payby;
 332   if ( @payby ) {
 333     push @search, 'cust_main.payby IN ('. join(',', map "'$_'", @payby). ')';
 334   }
 335
 336   #here is the agent virtualization
 337   push @search,
 338     $FS::CurrentUser::CurrentUser->agentnums_sql( 'table' => 'cust_main' );
 339
 340   return @search;
 341
 342 }
 343
 344 =item email_search_result HASHREF
 345
 346 Emails a notice to the specified customers.  Customers without
 347 invoice email destinations will be skipped.
 348
 349 Parameters:
 350
 351 =over 4
 352
 353 =item job
 354
 355 Queue job for status updates.  Required.
 356
 357 =item search
 358
 359 Hashref of params to the L<search()> method.  Required.
 360
 361 =item msgnum
 362
 363 Message template number (see L<FS::msg_template>).  Overrides all
 364 of the following options.
 365
 366 =item from
 367
 368 From: address
 369
 370 =item subject
 371
 372 Email Subject:
 373
 374 =item html_body
 375
 376 HTML body
 377
 378 =item text_body
 379
 380 Text body
 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 $msgnum = $param->{msgnum};
 401   my $from = delete $param->{from};
 402   my $subject = delete $param->{subject};
 403   my $html_body = delete $param->{html_body};
 404   my $text_body = delete $param->{text_body};
 405   my $error = '';
 406
 407   my $job = delete $param->{'job'}
 408     or die "email_search_result must run from the job queue.\n";
 409
 410   my $msg_template;
 411   if ( $msgnum ) {
 412     $msg_template = qsearchs('msg_template', { msgnum => $msgnum } )
 413       or die "msgnum $msgnum not found\n";
 414   }
 415
 416   my $sql_query = $class->search($param->{'search'});
 417   $sql_query->{'select'} = $sql_query->{'table'} . '.*';
 418
 419   my $count_query   = delete($sql_query->{'count_query'});
 420   my $count_sth = dbh->prepare($count_query)
 421     or die "Error preparing $count_query: ". dbh->errstr;
 422   $count_sth->execute
 423     or die "Error executing $count_query: ". $count_sth->errstr;
 424   my $count_arrayref = $count_sth->fetchrow_arrayref;
 425   my $num_cust = $count_arrayref->[0];
 426
 427   my( $num, $last, $min_sec ) = (0, time, 5); #progresbar foo
 428   my @retry_jobs = ();
 429   my $dups = 0;
 430   my $success = 0;
 431   my %sent_to = ();
 432
 433   #eventually order+limit magic to reduce memory use?
 434   foreach my $obj ( qsearch($sql_query) ) {
 435
 436     #progressbar first, so that the count is right
 437     $num++;
 438     if ( time - $min_sec > $last ) {
 439       my $error = $job->update_statustext(
 440         int( 100 * $num / $num_cust )
 441       );
 442       die $error if $error;
 443       $last = time;
 444     }
 445
 446     my $cust_main = $obj->cust_main;
 447     tie my %message, 'Tie::IxHash';
 448     if ( !$cust_main ) {
 449       next; # unlinked object; nothing else we can do
 450     }
 451
 452     if ( $msg_template ) {
 453       # Now supports other context objects.
 454       %message = $msg_template->prepare(
 455         'cust_main' => $cust_main,
 456         'object'    => $obj,
 457       );
 458     }
 459     else {
 460       my @to = $cust_main->invoicing_list_emailonly;
 461       next if !@to;
 462
 463       %message = (
 464         'from'      => $from,
 465         'to'        => \@to,
 466         'subject'   => $subject,
 467         'html_body' => $html_body,
 468         'text_body' => $text_body,
 469         'custnum'   => $cust_main->custnum,
 470       );
 471     } #if $msg_template
 472
 473     # For non-cust_main searches, we avoid duplicates based on message
 474     # body text.
 475     my $unique = $cust_main->custnum;
 476     $unique .= sha1($message{'text_body'}) if $class ne 'FS::cust_main';
 477     if( $sent_to{$unique} ) {
 478       # avoid duplicates
 479       $dups++;
 480       next;
 481     }
 482
 483     $sent_to{$unique} = 1;
 484
 485     $error = send_email( generate_email( %message ) );
 486
 487     if($error) {
 488       # queue the sending of this message so that the user can see what we
 489       # tried to do, and retry if desired
 490       my $queue = new FS::queue {
 491         'job'        => 'FS::Misc::process_send_email',
 492         'custnum'    => $cust_main->custnum,
 493         'status'     => 'failed',
 494         'statustext' => $error,
 495       };
 496       $queue->insert(%message);
 497       push @retry_jobs, $queue;
 498     }
 499     else {
 500       $success++;
 501     }
 502
 503     if($success == 0 and
 504         (scalar(@retry_jobs) > 10 or $num == $num_cust)
 505       ) {
 506       # 10 is arbitrary, but if we have enough failures, that's
 507       # probably a configuration or network problem, and we
 508       # abort the batch and run away screaming.
 509       # We NEVER do this if anything was successfully sent.
 510       $_->delete foreach (@retry_jobs);
 511       return "multiple failures: '$error'\n";
 512     }
 513   } # foreach $obj
 514
 515   if(@retry_jobs) {
 516     # fail the job, but with a status message that makes it clear
 517     # something was sent.
 518     return "Sent $success, skipped $dups duplicate(s), failed ".scalar(@retry_jobs).". Failed attempts placed in job queue.\n";
 519   }
 520
 521   return '';
 522 }
 523
 524 sub process_email_search_result {
 525   my $job = shift;
 526   #warn "$me process_re_X $method for job $job\n" if $DEBUG;
 527
 528   my $param = thaw(decode_base64(shift));
 529   warn Dumper($param) if $DEBUG;
 530
 531   $param->{'job'} = $job;
 532
 533   $param->{'search'} = thaw(decode_base64($param->{'search'}))
 534     or die "process_email_search_result requires search params.\n";
 535
 536 #  $param->{'payby'} = [ split(/\0/, $param->{'payby'}) ]
 537 #    unless ref($param->{'payby'});
 538
 539   my $table = $param->{'table'}
 540     or die "process_email_search_result requires table.\n";
 541
 542   eval "use FS::$table;";
 543   die "error loading FS::$table: $@\n" if $@;
 544
 545   my $error = "FS::$table"->email_search_result( $param );
 546   dbh->commit; # save failed jobs before rethrowing the error
 547   die $error if $error;
 548
 549 }
 550
 551 =item conf
 552
 553 Returns a configuration handle (L<FS::Conf>) set to the customer's locale,
 554 if they have one.  If not, returns an FS::Conf with no locale.
 555
 556 =cut
 557
 558 sub conf {
 559   my $self = shift;
 560   return $self->{_conf} if (ref $self and $self->{_conf});
 561   my $cust_main = $self->cust_main;
 562   my $conf = new FS::Conf {
 563     'locale' => ($cust_main ? $cust_main->locale : '')
 564   };
 565   $self->{_conf} = $conf if ref $self;
 566   return $conf;
 567 }
 568
 569 =item mt TEXT [, ARGS ]
 570
 571 Localizes a text string (see L<Locale::Maketext>) for the customer's locale,
 572 if they have one.
 573
 574 =cut
 575
 576 sub mt {
 577   my $self = shift;
 578   return $self->{_lh}->maketext(@_) if (ref $self and $self->{_lh});
 579   my $cust_main = $self->cust_main;
 580   my $locale = $cust_main ? $cust_main->locale : '';
 581   my $lh = FS::L10N->get_handle($locale);
 582   $self->{_lh} = $lh if ref $self;
 583   return $lh->maketext(@_);
 584 }
 585
 586 =item time2str_local FORMAT, TIME[, ESCAPE]
 587
 588 Localizes a date (see L<Date::Language>) for the customer's locale.
 589
 590 FORMAT can be a L<Date::Format> string, or one of these special words:
 591
 592 - "short": the value of the "date_format" config setting for the customer's
 593   locale, defaulting to "%x".
 594 - "rdate": the same as "short" except that the default has a four-digit year.
 595 - "long": the value of the "date_format_long" config setting for the
 596   customer's locale, defaulting to "%b %o, %Y".
 597
 598 ESCAPE, if specified, is one of "latex" or "html", and will escape non-ASCII
 599 characters and convert spaces to nonbreaking spaces.
 600
 601 =cut
 602
 603 sub time2str_local {
 604   # renamed so that we don't have to change every single reference to
 605   # time2str everywhere
 606   my $self = shift;
 607   my ($format, $time, $escape) = @_;
 608   return '' unless $time > 0; # work around time2str's traditional stupidity
 609
 610   $self->{_date_format} ||= {};
 611   if (!exists($self->{_dh})) {
 612     my $cust_main = $self->cust_main;
 613     my $locale = $cust_main->locale  if $cust_main;
 614     $locale ||= 'en_US';
 615     my %info = FS::Locales->locale_info($locale);
 616     my $dh = eval { Date::Language->new($info{'name'}) } ||
 617              Date::Language->new(); # fall back to English
 618     $self->{_dh} = $dh;
 619   }
 620
 621   if ($format eq 'short') {
 622     $format = $self->{_date_format}->{short}
 623             ||= $self->conf->config('date_format') || '%x';
 624   } elsif ($format eq 'rdate') {
 625     $format = $self->{_date_format}->{rdate}
 626             ||= $self->conf->config('date_format') || '%m/%d/%Y';
 627   } elsif ($format eq 'long') {
 628     $format = $self->{_date_format}->{long}
 629             ||= $self->conf->config('date_format_long') || '%b %o, %Y';
 630   }
 631
 632   # actually render the date
 633   my $string = $self->{_dh}->time2str($format, $time);
 634
 635   if ($escape) {
 636     if ($escape eq 'html') {
 637       $string = encode_entities($string);
 638       $string =~ s/ +/&nbsp;/g;
 639     } elsif ($escape eq 'latex') { # just do nbsp's here
 640       $string =~ s/ +/~/g;
 641     }
 642   }
 643
 644   $string;
 645 }
 646
 647 =back
 648
 649 =head1 BUGS
 650
 651 =head1 SEE ALSO
 652
 653 L<FS::cust_main>, L<FS::Record>
 654
 655 =cut
 656
 657 1;
 658