FS/FS/msg_template/email.pm

   1 package FS::msg_template::email;
   2 use base qw( FS::msg_template );
   3
   4 use strict;
   5 use vars qw( $DEBUG $conf );
   6
   7 # stuff needed for template generation
   8 use Date::Format qw( time2str );
   9 use File::Temp;
  10 use IPC::Run qw(run);
  11 use Text::Template;
  12
  13 use HTML::Entities qw( decode_entities encode_entities ) ;
  14 use HTML::FormatText;
  15 use HTML::TreeBuilder;
  16 use Encode;
  17
  18 # needed to send email
  19 use FS::Misc qw( generate_email );
  20 use FS::Conf;
  21 use Email::Sender::Simple qw( sendmail );
  22
  23 use FS::Record qw( qsearch qsearchs );
  24
  25 # needed to manage template_content objects
  26 use FS::template_content;
  27 use FS::UID qw( dbh );
  28
  29 use FS::cust_msg;
  30
  31 FS::UID->install_callback( sub { $conf = new FS::Conf; } );
  32
  33 our $DEBUG = 1;
  34 our $me = '[FS::msg_template::email]';
  35
  36 =head1 NAME
  37
  38 FS::msg_template::email - Construct email notices with Text::Template.
  39
  40 =head1 DESCRIPTION
  41
  42 FS::msg_template::email is a message processor in which the template contains
  43 L<Text::Template> strings for the message subject line and body, and the
  44 message is delivered by email.
  45
  46 Currently the C<from_addr> and C<bcc_addr> fields used by this processor are
  47 in the main msg_template table.
  48
  49 =head1 METHODS
  50
  51 =over 4
  52
  53 =item insert [ CONTENT ]
  54
  55 Adds this record to the database.  If there is an error, returns the error,
  56 otherwise returns false.
  57
  58 A default (no locale) L<FS::template_content> object will be created.  CONTENT
  59 is an optional hash containing 'subject' and 'body' for this object.
  60
  61 =cut
  62
  63 sub insert {
  64   my $self = shift;
  65   my %content = @_;
  66
  67   my $oldAutoCommit = $FS::UID::AutoCommit;
  68   local $FS::UID::AutoCommit = 0;
  69   my $dbh = dbh;
  70
  71   my $error = $self->SUPER::insert;
  72   if ( !$error ) {
  73     $content{'msgnum'} = $self->msgnum;
  74     $content{'subject'} ||= '';
  75     $content{'body'} ||= '';
  76     my $template_content = new FS::template_content (\%content);
  77     $error = $template_content->insert;
  78   }
  79
  80   if ( $error ) {
  81     $dbh->rollback if $oldAutoCommit;
  82     return $error;
  83   }
  84
  85   $dbh->commit if $oldAutoCommit;
  86   return;
  87 }
  88
  89 =item replace [ OLD_RECORD ] [ CONTENT ]
  90
  91 Replaces the OLD_RECORD with this one in the database.  If there is an error,
  92 returns the error, otherwise returns false.
  93
  94 CONTENT is an optional hash containing 'subject', 'body', and 'locale'.  If
  95 supplied, an L<FS::template_content> object will be created (or modified, if
  96 one already exists for this locale).
  97
  98 =cut
  99
 100 sub replace {
 101   my $self = shift;
 102   my $old = ( ref($_[0]) and $_[0]->isa('FS::Record') )
 103               ? shift
 104               : $self->replace_old;
 105   my %content = @_;
 106
 107   my $oldAutoCommit = $FS::UID::AutoCommit;
 108   local $FS::UID::AutoCommit = 0;
 109   my $dbh = dbh;
 110
 111   my $error = $self->SUPER::replace($old);
 112
 113   if ( !$error and %content ) {
 114     $content{'locale'} ||= '';
 115     my $new_content = qsearchs('template_content', {
 116                         'msgnum' => $self->msgnum,
 117                         'locale' => $content{'locale'},
 118                       } );
 119     if ( $new_content ) {
 120       $new_content->subject($content{'subject'});
 121       $new_content->body($content{'body'});
 122       $error = $new_content->replace;
 123     }
 124     else {
 125       $content{'msgnum'} = $self->msgnum;
 126       $new_content = new FS::template_content \%content;
 127       $error = $new_content->insert;
 128     }
 129   }
 130
 131   if ( $error ) {
 132     $dbh->rollback if $oldAutoCommit;
 133     return $error;
 134   }
 135
 136   warn "committing FS::msg_template->replace\n" if $DEBUG and $oldAutoCommit;
 137   $dbh->commit if $oldAutoCommit;
 138   return;
 139 }
 140
 141 =item content_locales
 142
 143 Returns a hashref of the L<FS::template_content> objects attached to
 144 this template, with the locale as key.
 145
 146 =cut
 147
 148 sub content_locales {
 149   my $self = shift;
 150   return $self->{'_content_locales'} ||= +{
 151     map { $_->locale , $_ }
 152     qsearch('template_content', { 'msgnum' => $self->msgnum })
 153   };
 154 }
 155
 156 =item prepare OPTION => VALUE
 157
 158 Fills in the template and returns an L<FS::cust_msg> object.
 159
 160 Options are passed as a list of name/value pairs:
 161
 162 =over 4
 163
 164 =item cust_main
 165
 166 Customer object (required).
 167
 168 =item object
 169
 170 Additional context object (currently, can be a cust_main, cust_pkg,
 171 cust_bill, cust_pay, cust_pay_pending, or svc_(acct, phone, broadband,
 172 domain) ).  If the object is a svc_*, its cust_pkg will be fetched and
 173 used for substitution.
 174
 175 As a special case, this may be an arrayref of two objects.  Both
 176 objects will be available for substitution, with their field names
 177 prefixed with 'new_' and 'old_' respectively.  This is used in the
 178 rt_ticket export when exporting "replace" events.
 179
 180 =item from_config
 181
 182 Configuration option to use as the source address, based on the customer's
 183 agentnum.  If unspecified (or the named option is empty), 'invoice_from'
 184 will be used.
 185
 186 The I<from_addr> field in the template takes precedence over this.
 187
 188 =item to
 189
 190 Destination address.  The default is to use the customer's
 191 invoicing_list addresses.  Multiple addresses may be comma-separated.
 192
 193 =item substitutions
 194
 195 A hash reference of additional substitutions
 196
 197 =item msgtype
 198
 199 A string identifying the kind of message this is. Currently can be "invoice",
 200 "receipt", "admin", or null. Expand this list as necessary.
 201
 202 =back
 203
 204 =cut
 205
 206 sub prepare {
 207
 208   my( $self, %opt ) = @_;
 209
 210   my $cust_main = $opt{'cust_main'}; # or die 'cust_main required';
 211   my $object = $opt{'object'} or die 'object required';
 212
 213   my $hashref = $self->prepare_substitutions(%opt);
 214
 215   # localization
 216   my $locale = $cust_main && $cust_main->locale || '';
 217   warn "no locale for cust#".$cust_main->custnum."; using default content\n"
 218     if $DEBUG and $cust_main && !$locale;
 219   my $content = $self->content($locale);
 220
 221   warn "preparing template '".$self->msgname."\n"
 222     if $DEBUG;
 223
 224   $_ = encode_entities($_ || '') foreach values(%$hashref);
 225
 226   ###
 227   # clean up template
 228   ###
 229   my $subject_tmpl = new Text::Template (
 230     TYPE   => 'STRING',
 231     SOURCE => $content->subject,
 232   );
 233
 234   warn "$me filling in subject template\n" if $DEBUG;
 235   my $subject = $subject_tmpl->fill_in( HASH => $hashref );
 236
 237   my $body = $content->body;
 238   my ($skin, $guts) = eviscerate($body);
 239   @$guts = map {
 240     $_ = decode_entities($_); # turn all punctuation back into itself
 241     s/\r//gs;           # remove \r's
 242     s/<br[^>]*>/\n/gsi; # and <br /> tags
 243     s/<p>/\n/gsi;       # and <p>
 244     s/<\/p>//gsi;       # and </p>
 245     s/\240/ /gs;        # and &nbsp;
 246     $_
 247   } @$guts;
 248
 249   $body = '{ use Date::Format qw(time2str); "" }';
 250   while(@$skin || @$guts) {
 251     $body .= shift(@$skin) || '';
 252     $body .= shift(@$guts) || '';
 253   }
 254
 255   ###
 256   # fill-in
 257   ###
 258
 259   my $body_tmpl = new Text::Template (
 260     TYPE          => 'STRING',
 261     SOURCE        => $body,
 262   );
 263
 264   warn "$me filling in body template\n" if $DEBUG;
 265   $body = $body_tmpl->fill_in( HASH => $hashref );
 266
 267   ###
 268   # and email
 269   ###
 270
 271   my @to;
 272   if ( exists($opt{'to'}) ) {
 273     @to = split(/\s*,\s*/, $opt{'to'});
 274   } elsif ( $cust_main ) {
 275     @to = $cust_main->invoicing_list_emailonly;
 276   } else {
 277     die 'no To: address or cust_main object specified';
 278   }
 279
 280   my $from_addr = $self->from_addr;
 281
 282   if ( !$from_addr ) {
 283
 284     my $agentnum = $cust_main ? $cust_main->agentnum : '';
 285
 286     if ( $opt{'from_config'} ) {
 287       $from_addr = $conf->config($opt{'from_config'}, $agentnum);
 288     }
 289     $from_addr ||= $conf->invoice_from_full($agentnum);
 290   }
 291
 292   my $text_body = encode('UTF-8',
 293                   HTML::FormatText->new(leftmargin => 0, rightmargin => 70)
 294                       ->format( HTML::TreeBuilder->new_from_content($body) )
 295                   );
 296
 297   warn "$me constructing MIME entities\n" if $DEBUG;
 298   my %email = generate_email(
 299     'from'      => $from_addr,
 300     'to'        => \@to,
 301     'bcc'       => $self->bcc_addr || undef,
 302     'subject'   => $subject,
 303     'html_body' => $body,
 304     'text_body' => $text_body,
 305   );
 306
 307   warn "$me creating message headers\n" if $DEBUG;
 308   my $env_from = $from_addr;
 309   $env_from =~ s/^\s*//; $env_from =~ s/\s*$//;
 310   if ( $env_from =~ /^(.*)\s*<(.*@.*)>$/ ) {
 311     # a common idiom
 312     $env_from = $2;
 313   }
 314
 315   my $domain;
 316   if ( $env_from =~ /\@([\w\.\-]+)/ ) {
 317     $domain = $1;
 318   } else {
 319     warn 'no domain found in invoice from address '. $env_from .
 320          '; constructing Message-ID (and saying HELO) @example.com';
 321     $domain = 'example.com';
 322   }
 323   my $message_id = join('.', rand()*(2**32), $$, time). "\@$domain";
 324
 325   my $time = time;
 326   my $message = MIME::Entity->build(
 327     'From'        => $from_addr,
 328     'To'          => join(', ', @to),
 329     'Sender'      => $from_addr,
 330     'Reply-To'    => $from_addr,
 331     'Date'        => time2str("%a, %d %b %Y %X %z", $time),
 332     'Subject'     => Encode::encode('MIME-Header', $subject),
 333     'Message-ID'  => "<$message_id>",
 334     'Encoding'    => '7bit',
 335     'Type'        => 'multipart/related',
 336   );
 337
 338   #$message->head->replace('Content-type',
 339   #  'multipart/related; '.
 340   #  'boundary="' . $message->head->multipart_boundary . '"; ' .
 341   #  'type=multipart/alternative'
 342   #);
 343
 344   # XXX a facility to attach additional parts is necessary at some point
 345   foreach my $part (@{ $email{mimeparts} }) {
 346     warn "$me appending part ".$part->mime_type."\n" if $DEBUG;
 347     $message->add_part( $part );
 348   }
 349
 350   # effective To: address (not in headers)
 351   push @to, $self->bcc_addr if $self->bcc_addr;
 352   my $env_to = join(', ', @to);
 353
 354   my $cust_msg = FS::cust_msg->new({
 355       'custnum'   => $cust_main->custnum,
 356       'msgnum'    => $self->msgnum,
 357       '_date'     => $time,
 358       'env_from'  => $env_from,
 359       'env_to'    => $env_to,
 360       'header'    => $message->header_as_string,
 361       'body'      => $message->body_as_string,
 362       'error'     => '',
 363       'status'    => 'prepared',
 364       'msgtype'   => ($opt{'msgtype'} || ''),
 365   });
 366
 367   return $cust_msg;
 368 }
 369
 370 =item send_prepared CUST_MSG
 371
 372 Takes the CUST_MSG object and sends it to its recipient.
 373
 374 =cut
 375
 376 sub send_prepared {
 377   my $self = shift;
 378   my $cust_msg = shift or die "cust_msg required";
 379
 380   my $domain = 'example.com';
 381   if ( $cust_msg->env_from =~ /\@([\w\.\-]+)/ ) {
 382     $domain = $1;
 383   }
 384
 385   my @to = split(/\s*,\s*/, $cust_msg->env_to);
 386
 387   my %smtp_opt = ( 'host' => $conf->config('smtpmachine'),
 388                    'helo' => $domain );
 389
 390   my($port, $enc) = split('-', ($conf->config('smtp-encryption') || '25') );
 391   $smtp_opt{'port'} = $port;
 392
 393   my $transport;
 394   if ( defined($enc) && $enc eq 'starttls' ) {
 395     $smtp_opt{$_} = $conf->config("smtp-$_") for qw(username password);
 396     $transport = Email::Sender::Transport::SMTP::TLS->new( %smtp_opt );
 397   } else {
 398     if ( $conf->exists('smtp-username') && $conf->exists('smtp-password') ) {
 399       $smtp_opt{"sasl_$_"} = $conf->config("smtp-$_") for qw(username password);
 400     }
 401     $smtp_opt{'ssl'} = 1 if defined($enc) && $enc eq 'tls';
 402     $transport = Email::Sender::Transport::SMTP->new( %smtp_opt );
 403   }
 404
 405   warn "$me sending message\n" if $DEBUG;
 406   my $message = join("\n\n", $cust_msg->header, $cust_msg->body);
 407   local $@;
 408   eval {
 409     sendmail( $message, { transport => $transport,
 410                           from      => $cust_msg->env_from,
 411                           to        => \@to })
 412   };
 413   my $error = '';
 414   if(ref($@) and $@->isa('Email::Sender::Failure')) {
 415     $error = $@->code.' ' if $@->code;
 416     $error .= $@->message;
 417   }
 418   else {
 419     $error = $@;
 420   }
 421
 422   $cust_msg->set('error', $error);
 423   $cust_msg->set('status', $error ? 'failed' : 'sent');
 424   if ( $cust_msg->custmsgnum ) {
 425     $cust_msg->replace;
 426   } else {
 427     $cust_msg->insert;
 428   }
 429
 430   $error;
 431 }
 432
 433 =item render OPTION => VALUE ...
 434
 435 Fills in the template and renders it to a PDF document.  Returns the
 436 name of the PDF file.
 437
 438 Options are as for 'prepare', but 'from' and 'to' are meaningless.
 439
 440 =cut
 441
 442 # will also have options to set paper size, margins, etc.
 443
 444 sub render {
 445   my $self = shift;
 446   eval "use PDF::WebKit";
 447   die $@ if $@;
 448   my %opt = @_;
 449   my %hash = $self->prepare(%opt);
 450   my $html = $hash{'html_body'};
 451
 452   # Graphics/stylesheets should probably go in /var/www on the Freeside
 453   # machine.
 454   my $script_path = `/usr/bin/which freeside-wkhtmltopdf`;
 455   chomp $script_path;
 456   my $kit = PDF::WebKit->new(\$html); #%options
 457   # hack to use our wrapper script
 458   $kit->configure(sub { shift->wkhtmltopdf($script_path) });
 459
 460   $kit->to_pdf;
 461 }
 462
 463 =item print OPTIONS
 464
 465 Render a PDF and send it to the printer.  OPTIONS are as for 'render'.
 466
 467 =cut
 468
 469 sub print {
 470   my( $self, %opt ) = @_;
 471   do_print( [ $self->render(%opt) ], agentnum=>$opt{cust_main}->agentnum );
 472 }
 473
 474 # helper sub for package dates
 475 my $ymd = sub { $_[0] ? time2str('%Y-%m-%d', $_[0]) : '' };
 476
 477 # helper sub for money amounts
 478 my $money = sub { ($conf->money_char || '$') . sprintf('%.2f', $_[0] || 0) };
 479
 480 # helper sub for usage-related messages
 481 my $usage_warning = sub {
 482   my $svc = shift;
 483   foreach my $col (qw(seconds upbytes downbytes totalbytes)) {
 484     my $amount = $svc->$col; next if $amount eq '';
 485     my $method = $col.'_threshold';
 486     my $threshold = $svc->$method; next if $threshold eq '';
 487     return [$col, $amount, $threshold] if $amount <= $threshold;
 488     # this only returns the first one that's below threshold, if there are
 489     # several.
 490   }
 491   return ['', '', ''];
 492 };
 493
 494 #my $conf = new FS::Conf;
 495
 496 #return contexts and fill-in values
 497 # If you add anything, be sure to add a description in
 498 # httemplate/edit/msg_template.html.
 499 sub substitutions {
 500   { 'cust_main' => [qw(
 501       display_custnum agentnum agent_name
 502
 503       last first company
 504       name name_short contact contact_firstlast
 505       address1 address2 city county state zip
 506       country
 507       daytime night mobile fax
 508
 509       has_ship_address
 510       ship_name ship_name_short ship_contact ship_contact_firstlast
 511       ship_address1 ship_address2 ship_city ship_county ship_state ship_zip
 512       ship_country
 513
 514       paymask payname paytype payip
 515       num_cancelled_pkgs num_ncancelled_pkgs num_pkgs
 516       classname categoryname
 517       balance
 518       credit_limit
 519       invoicing_list_emailonly
 520       cust_status ucfirst_cust_status cust_statuscolor cust_status_label
 521
 522       signupdate dundate
 523       packages recurdates
 524       ),
 525       [ invoicing_email => sub { shift->invoicing_list_emailonly_scalar } ],
 526       #compatibility: obsolete ship_ fields - use the non-ship versions
 527       map (
 528         { my $field = $_;
 529           [ "ship_$field"   => sub { shift->$field } ]
 530         }
 531         qw( last first company daytime night fax )
 532       ),
 533       # ship_name, ship_name_short, ship_contact, ship_contact_firstlast
 534       # still work, though
 535       [ expdate           => sub { shift->paydate_epoch } ], #compatibility
 536       [ signupdate_ymd    => sub { $ymd->(shift->signupdate) } ],
 537       [ dundate_ymd       => sub { $ymd->(shift->dundate) } ],
 538       [ paydate_my        => sub { sprintf('%02d/%04d', shift->paydate_monthyear) } ],
 539       [ otaker_first      => sub { shift->access_user->first } ],
 540       [ otaker_last       => sub { shift->access_user->last } ],
 541       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
 542       [ company_name      => sub {
 543           $conf->config('company_name', shift->agentnum)
 544         } ],
 545       [ company_address   => sub {
 546           $conf->config('company_address', shift->agentnum)
 547         } ],
 548       [ company_phonenum  => sub {
 549           $conf->config('company_phonenum', shift->agentnum)
 550         } ],
 551       [ selfservice_server_base_url => sub {
 552           $conf->config('selfservice_server-base_url') #, shift->agentnum)
 553         } ],
 554     ],
 555     # next_bill_date
 556     'cust_pkg'  => [qw(
 557       pkgnum pkg_label pkg_label_long
 558       location_label
 559       status statuscolor
 560
 561       start_date setup bill last_bill
 562       adjourn susp expire
 563       labels_short
 564       ),
 565       [ pkg               => sub { shift->part_pkg->pkg } ],
 566       [ pkg_category      => sub { shift->part_pkg->categoryname } ],
 567       [ pkg_class         => sub { shift->part_pkg->classname } ],
 568       [ cancel            => sub { shift->getfield('cancel') } ], # grrr...
 569       [ start_ymd         => sub { $ymd->(shift->getfield('start_date')) } ],
 570       [ setup_ymd         => sub { $ymd->(shift->getfield('setup')) } ],
 571       [ next_bill_ymd     => sub { $ymd->(shift->getfield('bill')) } ],
 572       [ last_bill_ymd     => sub { $ymd->(shift->getfield('last_bill')) } ],
 573       [ adjourn_ymd       => sub { $ymd->(shift->getfield('adjourn')) } ],
 574       [ susp_ymd          => sub { $ymd->(shift->getfield('susp')) } ],
 575       [ expire_ymd        => sub { $ymd->(shift->getfield('expire')) } ],
 576       [ cancel_ymd        => sub { $ymd->(shift->getfield('cancel')) } ],
 577
 578       # not necessarily correct for non-flat packages
 579       [ setup_fee         => sub { shift->part_pkg->option('setup_fee') } ],
 580       [ recur_fee         => sub { shift->part_pkg->option('recur_fee') } ],
 581
 582       [ freq_pretty       => sub { shift->part_pkg->freq_pretty } ],
 583
 584     ],
 585     'cust_bill' => [qw(
 586       invnum
 587       _date
 588       _date_pretty
 589       due_date
 590     ),
 591       [ due_date2str      => sub { shift->due_date2str('short') } ],
 592     ],
 593     #XXX not really thinking about cust_bill substitutions quite yet
 594
 595     # for welcome and limit warning messages
 596     'svc_acct' => [qw(
 597       svcnum
 598       username
 599       domain
 600       ),
 601       [ password          => sub { shift->getfield('_password') } ],
 602       [ column            => sub { &$usage_warning(shift)->[0] } ],
 603       [ amount            => sub { &$usage_warning(shift)->[1] } ],
 604       [ threshold         => sub { &$usage_warning(shift)->[2] } ],
 605     ],
 606     'svc_domain' => [qw(
 607       svcnum
 608       domain
 609       ),
 610       [ registrar         => sub {
 611           my $registrar = qsearchs('registrar',
 612             { registrarnum => shift->registrarnum} );
 613           $registrar ? $registrar->registrarname : ''
 614         }
 615       ],
 616       [ catchall          => sub {
 617           my $svc_acct = qsearchs('svc_acct', { svcnum => shift->catchall });
 618           $svc_acct ? $svc_acct->email : ''
 619         }
 620       ],
 621     ],
 622     'svc_phone' => [qw(
 623       svcnum
 624       phonenum
 625       countrycode
 626       domain
 627       )
 628     ],
 629     'svc_broadband' => [qw(
 630       svcnum
 631       speed_up
 632       speed_down
 633       ip_addr
 634       mac_addr
 635       )
 636     ],
 637     # for payment receipts
 638     'cust_pay' => [qw(
 639       paynum
 640       _date
 641       ),
 642       [ paid              => sub { sprintf("%.2f", shift->paid) } ],
 643       # overrides the one in cust_main in cases where a cust_pay is passed
 644       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
 645       [ date              => sub { time2str("%a %B %o, %Y", shift->_date) } ],
 646       [ payinfo           => sub {
 647           my $cust_pay = shift;
 648           ($cust_pay->payby eq 'CARD' || $cust_pay->payby eq 'CHEK') ?
 649             $cust_pay->paymask : $cust_pay->decrypt($cust_pay->payinfo)
 650         } ],
 651     ],
 652     # for payment decline messages
 653     # try to support all cust_pay fields
 654     # 'error' is a special case, it contains the raw error from the gateway
 655     'cust_pay_pending' => [qw(
 656       _date
 657       error
 658       ),
 659       [ paid              => sub { sprintf("%.2f", shift->paid) } ],
 660       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
 661       [ date              => sub { time2str("%a %B %o, %Y", shift->_date) } ],
 662       [ payinfo           => sub {
 663           my $pending = shift;
 664           ($pending->payby eq 'CARD' || $pending->payby eq 'CHEK') ?
 665             $pending->paymask : $pending->decrypt($pending->payinfo)
 666         } ],
 667     ],
 668   };
 669 }
 670
 671 =item content LOCALE
 672
 673 Returns the L<FS::template_content> object appropriate to LOCALE, if there
 674 is one.  If not, returns the one with a NULL locale.
 675
 676 =cut
 677
 678 sub content {
 679   my $self = shift;
 680   my $locale = shift;
 681   qsearchs('template_content',
 682             { 'msgnum' => $self->msgnum, 'locale' => $locale }) ||
 683   qsearchs('template_content',
 684             { 'msgnum' => $self->msgnum, 'locale' => '' });
 685 }
 686
 687 =item agent
 688
 689 Returns the L<FS::agent> object for this template.
 690
 691 =cut
 692
 693 sub _upgrade_data {
 694   my ($self, %opts) = @_;
 695
 696   ###
 697   # First move any historical templates in config to real message templates
 698   ###
 699
 700   my @fixes = (
 701     [ 'alerter_msgnum',  'alerter_template',   '',               '', '' ],
 702     [ 'cancel_msgnum',   'cancelmessage',      'cancelsubject',  '', '' ],
 703     [ 'decline_msgnum',  'declinetemplate',    '',               '', '' ],
 704     [ 'impending_recur_msgnum', 'impending_recur_template', '',  '', 'impending_recur_bcc' ],
 705     [ 'payment_receipt_msgnum', 'payment_receipt_email', '',     '', '' ],
 706     [ 'welcome_msgnum',  'welcome_email',      'welcome_email-subject', 'welcome_email-from', '' ],
 707     [ 'warning_msgnum',  'warning_email',      'warning_email-subject', 'warning_email-from', '' ],
 708   );
 709
 710   my @agentnums = ('', map {$_->agentnum} qsearch('agent', {}));
 711   foreach my $agentnum (@agentnums) {
 712     foreach (@fixes) {
 713       my ($newname, $oldname, $subject, $from, $bcc) = @$_;
 714       if ($conf->exists($oldname, $agentnum)) {
 715         my $new = new FS::msg_template({
 716           'msgname'   => $oldname,
 717           'agentnum'  => $agentnum,
 718           'from_addr' => ($from && $conf->config($from, $agentnum)) || '',
 719           'bcc_addr'  => ($bcc && $conf->config($from, $agentnum)) || '',
 720           'subject'   => ($subject && $conf->config($subject, $agentnum)) || '',
 721           'mime_type' => 'text/html',
 722           'body'      => join('<BR>',$conf->config($oldname, $agentnum)),
 723         });
 724         my $error = $new->insert;
 725         die $error if $error;
 726         $conf->set($newname, $new->msgnum, $agentnum);
 727         $conf->delete($oldname, $agentnum);
 728         $conf->delete($from, $agentnum) if $from;
 729         $conf->delete($subject, $agentnum) if $subject;
 730       }
 731     }
 732
 733     if ( $conf->exists('alert_expiration', $agentnum) ) {
 734       my $msgnum = $conf->exists('alerter_msgnum', $agentnum);
 735       my $template = FS::msg_template->by_key($msgnum) if $msgnum;
 736       if (!$template) {
 737         warn "template for alerter_msgnum $msgnum not found\n";
 738         next;
 739       }
 740       # this is now a set of billing events
 741       foreach my $days (30, 15, 5) {
 742         my $event = FS::part_event->new({
 743             'agentnum'    => $agentnum,
 744             'event'       => "Card expiration warning - $days days",
 745             'eventtable'  => 'cust_main',
 746             'check_freq'  => '1d',
 747             'action'      => 'notice',
 748             'disabled'    => 'Y', #initialize first
 749         });
 750         my $error = $event->insert( 'msgnum' => $msgnum );
 751         if ($error) {
 752           warn "error creating expiration alert event:\n$error\n\n";
 753           next;
 754         }
 755         # make it work like before:
 756         # only send each warning once before the card expires,
 757         # only warn active customers,
 758         # only warn customers with CARD/DCRD,
 759         # only warn customers who get email invoices
 760         my %conds = (
 761           'once_every'          => { 'run_delay' => '30d' },
 762           'cust_paydate_within' => { 'within' => $days.'d' },
 763           'cust_status'         => { 'status' => { 'active' => 1 } },
 764           'payby'               => { 'payby'  => { 'CARD' => 1,
 765                                                    'DCRD' => 1, }
 766                                    },
 767           'message_email'       => {},
 768         );
 769         foreach (keys %conds) {
 770           my $condition = FS::part_event_condition->new({
 771               'conditionname' => $_,
 772               'eventpart'     => $event->eventpart,
 773           });
 774           $error = $condition->insert( %{ $conds{$_} });
 775           if ( $error ) {
 776             warn "error creating expiration alert event:\n$error\n\n";
 777             next;
 778           }
 779         }
 780         $error = $event->initialize;
 781         if ( $error ) {
 782           warn "expiration alert event was created, but not initialized:\n$error\n\n";
 783         }
 784       } # foreach $days
 785       $conf->delete('alerter_msgnum', $agentnum);
 786       $conf->delete('alert_expiration', $agentnum);
 787
 788     } # if alerter_msgnum
 789
 790   }
 791
 792   ###
 793   # Move subject and body from msg_template to template_content
 794   ###
 795
 796   foreach my $msg_template ( qsearch('msg_template', {}) ) {
 797     if ( $msg_template->subject || $msg_template->body ) {
 798       # create new default content
 799       my %content;
 800       $content{subject} = $msg_template->subject;
 801       $msg_template->set('subject', '');
 802
 803       # work around obscure Pg/DBD bug
 804       # https://rt.cpan.org/Public/Bug/Display.html?id=60200
 805       # (though the right fix is to upgrade DBD)
 806       my $body = $msg_template->body;
 807       if ( $body =~ /^x([0-9a-f]+)$/ ) {
 808         # there should be no real message templates that look like that
 809         warn "converting template body to TEXT\n";
 810         $body = pack('H*', $1);
 811       }
 812       $content{body} = $body;
 813       $msg_template->set('body', '');
 814
 815       my $error = $msg_template->replace(%content);
 816       die $error if $error;
 817     }
 818   }
 819
 820   ###
 821   # Add new-style default templates if missing
 822   ###
 823   $self->_populate_initial_data;
 824
 825 }
 826
 827 sub _populate_initial_data { #class method
 828   #my($class, %opts) = @_;
 829   #my $class = shift;
 830
 831   eval "use FS::msg_template::InitialData;";
 832   die $@ if $@;
 833
 834   my $initial_data = FS::msg_template::InitialData->_initial_data;
 835
 836   foreach my $hash ( @$initial_data ) {
 837
 838     next if $hash->{_conf} && $conf->config( $hash->{_conf} );
 839
 840     my $msg_template = new FS::msg_template($hash);
 841     my $error = $msg_template->insert( @{ $hash->{_insert_args} || [] } );
 842     die $error if $error;
 843
 844     $conf->set( $hash->{_conf}, $msg_template->msgnum ) if $hash->{_conf};
 845
 846   }
 847
 848 }
 849
 850 sub eviscerate {
 851   # Every bit as pleasant as it sounds.
 852   #
 853   # We do this because Text::Template::Preprocess doesn't
 854   # actually work.  It runs the entire template through
 855   # the preprocessor, instead of the code segments.  Which
 856   # is a shame, because Text::Template already contains
 857   # the code to do this operation.
 858   my $body = shift;
 859   my (@outside, @inside);
 860   my $depth = 0;
 861   my $chunk = '';
 862   while($body || $chunk) {
 863     my ($first, $delim, $rest);
 864     # put all leading non-delimiters into $first
 865     ($first, $rest) =
 866         ($body =~ /^((?:\\[{}]|[^{}])*)(.*)$/s);
 867     $chunk .= $first;
 868     # put a leading delimiter into $delim if there is one
 869     ($delim, $rest) =
 870       ($rest =~ /^([{}]?)(.*)$/s);
 871
 872     if( $delim eq '{' ) {
 873       $chunk .= '{';
 874       if( $depth == 0 ) {
 875         push @outside, $chunk;
 876         $chunk = '';
 877       }
 878       $depth++;
 879     }
 880     elsif( $delim eq '}' ) {
 881       $depth--;
 882       if( $depth == 0 ) {
 883         push @inside, $chunk;
 884         $chunk = '';
 885       }
 886       $chunk .= '}';
 887     }
 888     else {
 889       # no more delimiters
 890       if( $depth == 0 ) {
 891         push @outside, $chunk . $rest;
 892       } # else ? something wrong
 893       last;
 894     }
 895     $body = $rest;
 896   }
 897   (\@outside, \@inside);
 898 }
 899
 900 =back
 901
 902 =head1 BUGS
 903
 904 =head1 SEE ALSO
 905
 906 L<FS::Record>, schema.html from the base documentation.
 907
 908 =cut
 909
 910 1;
 911