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