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