try at a multiprocess torrus-srvderive to hopefully catch/keep up, RT#10574
[freeside.git] / FS / FS / msg_template.pm
1 package FS::msg_template;
2
3 use strict;
4 use base qw( FS::Record );
5 use Text::Template;
6 use FS::Misc qw( generate_email send_email );
7 use FS::Conf;
8 use FS::Record qw( qsearch qsearchs );
9
10 use Date::Format qw( time2str );
11 use HTML::Entities qw( decode_entities encode_entities ) ;
12 use HTML::FormatText;
13 use HTML::TreeBuilder;
14 use vars '$DEBUG';
15
16 $DEBUG=0;
17
18 =head1 NAME
19
20 FS::msg_template - Object methods for msg_template records
21
22 =head1 SYNOPSIS
23
24   use FS::msg_template;
25
26   $record = new FS::msg_template \%hash;
27   $record = new FS::msg_template { 'column' => 'value' };
28
29   $error = $record->insert;
30
31   $error = $new_record->replace($old_record);
32
33   $error = $record->delete;
34
35   $error = $record->check;
36
37 =head1 DESCRIPTION
38
39 An FS::msg_template object represents a customer message template.
40 FS::msg_template inherits from FS::Record.  The following fields are currently
41 supported:
42
43 =over 4
44
45 =item msgnum
46
47 primary key
48
49 =item msgname
50
51 Template name.
52
53 =item agentnum
54
55 Agent associated with this template.  Can be NULL for a global template.
56
57 =item mime_type
58
59 MIME type.  Defaults to text/html.
60
61 =item from_addr
62
63 Source email address.
64
65 =item subject
66
67 The message subject line, in L<Text::Template> format.
68
69 =item body
70
71 The message body, as plain text or HTML, in L<Text::Template> format.
72
73 =item disabled
74
75 disabled
76
77 =back
78
79 =head1 METHODS
80
81 =over 4
82
83 =item new HASHREF
84
85 Creates a new template.  To add the template to the database, see L<"insert">.
86
87 Note that this stores the hash reference, not a distinct copy of the hash it
88 points to.  You can ask the object for a copy with the I<hash> method.
89
90 =cut
91
92 # the new method can be inherited from FS::Record, if a table method is defined
93
94 sub table { 'msg_template'; }
95
96 =item insert
97
98 Adds this record to the database.  If there is an error, returns the error,
99 otherwise returns false.
100
101 =cut
102
103 # the insert method can be inherited from FS::Record
104
105 =item delete
106
107 Delete this record from the database.
108
109 =cut
110
111 # the delete method can be inherited from FS::Record
112
113 =item replace OLD_RECORD
114
115 Replaces the OLD_RECORD with this one in the database.  If there is an error,
116 returns the error, otherwise returns false.
117
118 =cut
119
120 # the replace method can be inherited from FS::Record
121
122 =item check
123
124 Checks all fields to make sure this is a valid template.  If there is
125 an error, returns the error, otherwise returns false.  Called by the insert
126 and replace methods.
127
128 =cut
129
130 # the check method should currently be supplied - FS::Record contains some
131 # data checking routines
132
133 sub check {
134   my $self = shift;
135
136   my $error = 
137     $self->ut_numbern('msgnum')
138     || $self->ut_text('msgname')
139     || $self->ut_foreign_keyn('agentnum', 'agent', 'agentnum')
140     || $self->ut_textn('mime_type')
141     || $self->ut_anything('subject')
142     || $self->ut_anything('body')
143     || $self->ut_enum('disabled', [ '', 'Y' ] )
144     || $self->ut_textn('from_addr')
145   ;
146   return $error if $error;
147
148   $self->mime_type('text/html') unless $self->mime_type;
149
150   $self->SUPER::check;
151 }
152
153 =item prepare OPTION => VALUE
154
155 Fills in the template and returns a hash of the 'from' address, 'to' 
156 addresses, subject line, and body.
157
158 Options are passed as a list of name/value pairs:
159
160 =over 4
161
162 =item cust_main
163
164 Customer object (required).
165
166 =item object
167
168 Additional context object (currently, can be a cust_main, cust_pkg, 
169 cust_bill, cust_pay, cust_pay_pending, or svc_(acct, phone, broadband, 
170 domain) ).  If the object is a svc_*, its cust_pkg will be fetched and 
171 used for substitution.
172
173 As a special case, this may be an arrayref of two objects.  Both 
174 objects will be available for substitution, with their field names 
175 prefixed with 'new_' and 'old_' respectively.  This is used in the 
176 rt_ticket export when exporting "replace" events.
177
178 =item from_config
179
180 Configuration option to use as the source address, based on the customer's 
181 agentnum.  If unspecified (or the named option is empty), 'invoice_from' 
182 will be used.
183
184 The I<from_addr> field in the template takes precedence over this.
185
186 =item to
187
188 Destination address.  The default is to use the customer's 
189 invoicing_list addresses.  Multiple addresses may be comma-separated.
190
191 =back
192
193 =cut
194
195 sub prepare {
196   my( $self, %opt ) = @_;
197
198   my $cust_main = $opt{'cust_main'};
199   my $object = $opt{'object'};
200   warn "preparing template '".$self->msgname."' to cust#".$cust_main->custnum."\n"
201     if($DEBUG);
202
203   my $subs = $self->substitutions;
204
205   ###
206   # create substitution table
207   ###  
208   my %hash;
209   my @objects = ($cust_main);
210   my @prefixes = ('');
211   my $svc;
212   if( ref $object ) {
213     if( ref($object) eq 'ARRAY' ) {
214       # [new, old], for provisioning tickets
215       push @objects, $object->[0], $object->[1];
216       push @prefixes, 'new_', 'old_';
217       $svc = $object->[0] if $object->[0]->isa('FS::svc_Common');
218     }
219     else {
220       push @objects, $object;
221       push @prefixes, '';
222       $svc = $object if $object->isa('FS::svc_Common');
223     }
224   }
225   if( $svc ) {
226     push @objects, $svc->cust_svc->cust_pkg;
227     push @prefixes, '';
228   }
229
230   foreach my $obj (@objects) {
231     my $prefix = shift @prefixes;
232     foreach my $name (@{ $subs->{$obj->table} }) {
233       if(!ref($name)) {
234         # simple case
235         $hash{$prefix.$name} = $obj->$name();
236       }
237       elsif( ref($name) eq 'ARRAY' ) {
238         # [ foo => sub { ... } ]
239         $hash{$prefix.($name->[0])} = $name->[1]->($obj);
240       }
241       else {
242         warn "bad msg_template substitution: '$name'\n";
243         #skip it?
244       } 
245     } 
246   } 
247   $_ = encode_entities($_) foreach values(%hash);
248
249
250   ###
251   # clean up template
252   ###
253   my $subject_tmpl = new Text::Template (
254     TYPE   => 'STRING',
255     SOURCE => $self->subject,
256   );
257   my $subject = $subject_tmpl->fill_in( HASH => \%hash );
258
259   my $body = $self->body;
260   my ($skin, $guts) = eviscerate($body);
261   @$guts = map { 
262     $_ = decode_entities($_); # turn all punctuation back into itself
263     s/\r//gs;           # remove \r's
264     s/<br[^>]*>/\n/gsi; # and <br /> tags
265     s/<p>/\n/gsi;       # and <p>
266     s/<\/p>//gsi;       # and </p>
267     s/\240/ /gs;        # and &nbsp;
268     $_
269   } @$guts;
270   
271   $body = '{ use Date::Format qw(time2str); "" }';
272   while(@$skin || @$guts) {
273     $body .= shift(@$skin) || '';
274     $body .= shift(@$guts) || '';
275   }
276
277   ###
278   # fill-in
279   ###
280
281   my $body_tmpl = new Text::Template (
282     TYPE          => 'STRING',
283     SOURCE        => $body,
284   );
285
286   $body = $body_tmpl->fill_in( HASH => \%hash );
287
288   ###
289   # and email
290   ###
291
292   my @to;
293   if ( exists($opt{'to'}) ) {
294     @to = split(/\s*,\s*/, $opt{'to'});
295   }
296   else {
297     @to = $cust_main->invoicing_list_emailonly;
298   }
299   # no warning when preparing with no destination
300
301   my $conf = new FS::Conf;
302   my $from_addr = $self->from_addr;
303
304   if ( !$from_addr ) {
305     if ( $opt{'from_config'} ) {
306       $from_addr = scalar( $conf->config($opt{'from_config'}, 
307                                          $cust_main->agentnum) );
308     }
309     $from_addr ||= scalar( $conf->config('invoice_from',
310                                          $cust_main->agentnum) );
311   }
312
313   (
314     'from' => $from_addr,
315     'to'   => \@to,
316     'bcc'  => $self->bcc_addr || undef,
317     'subject'   => $subject,
318     'html_body' => $body,
319     'text_body' => HTML::FormatText->new(leftmargin => 0, rightmargin => 70
320                     )->format( HTML::TreeBuilder->new_from_content($body) ),
321   );
322
323 }
324
325 =item send OPTION => VALUE
326
327 Fills in the template and sends it to the customer.  Options are as for 
328 'prepare'.
329
330 =cut
331
332 # broken out from prepare() in case we want to queue the sending,
333 # preview it, etc.
334 sub send {
335   my $self = shift;
336   send_email(generate_email($self->prepare(@_)));
337 }
338
339 # helper sub for package dates
340 my $ymd = sub { $_[0] ? time2str('%Y-%m-%d', $_[0]) : '' };
341
342 # needed for some things
343 my $conf = new FS::Conf;
344
345 #return contexts and fill-in values
346 # If you add anything, be sure to add a description in 
347 # httemplate/edit/msg_template.html.
348 sub substitutions {
349   { 'cust_main' => [qw(
350       display_custnum agentnum agent_name
351
352       last first company
353       name name_short contact contact_firstlast
354       address1 address2 city county state zip
355       country
356       daytime night fax
357
358       has_ship_address
359       ship_last ship_first ship_company
360       ship_name ship_name_short ship_contact ship_contact_firstlast
361       ship_address1 ship_address2 ship_city ship_county ship_state ship_zip
362       ship_country
363       ship_daytime ship_night ship_fax
364
365       paymask payname paytype payip
366       num_cancelled_pkgs num_ncancelled_pkgs num_pkgs
367       classname categoryname
368       balance
369       credit_limit
370       invoicing_list_emailonly
371       cust_status ucfirst_cust_status cust_statuscolor
372
373       signupdate dundate
374       expdate
375       packages recurdates
376       ),
377       # expdate is a special case
378       [ signupdate_ymd    => sub { time2str('%Y-%m-%d', shift->signupdate) } ],
379       [ dundate_ymd       => sub { time2str('%Y-%m-%d', shift->dundate) } ],
380       [ paydate_my        => sub { sprintf('%02d/%04d', shift->paydate_monthyear) } ],
381       [ otaker_first      => sub { shift->access_user->first } ],
382       [ otaker_last       => sub { shift->access_user->last } ],
383       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
384       [ company_name      => sub { 
385           $conf->config('company_name', shift->agentnum) 
386         } ],
387       [ company_address   => sub {
388           $conf->config('company_address', shift->agentnum)
389         } ],
390       [ company_phonenum  => sub {
391           $conf->config('company_phonenum', shift->agentnum)
392         } ],
393     ],
394     # next_bill_date
395     'cust_pkg'  => [qw( 
396       pkgnum pkg_label pkg_label_long
397       location_label
398       status statuscolor
399     
400       start_date setup bill last_bill 
401       adjourn susp expire 
402       labels_short
403       ),
404       [ pkg               => sub { shift->part_pkg->pkg } ],
405       [ cancel            => sub { shift->getfield('cancel') } ], # grrr...
406       [ start_ymd         => sub { $ymd->(shift->getfield('start_date')) } ],
407       [ setup_ymd         => sub { $ymd->(shift->getfield('setup')) } ],
408       [ next_bill_ymd     => sub { $ymd->(shift->getfield('bill')) } ],
409       [ last_bill_ymd     => sub { $ymd->(shift->getfield('last_bill')) } ],
410       [ adjourn_ymd       => sub { $ymd->(shift->getfield('adjourn')) } ],
411       [ susp_ymd          => sub { $ymd->(shift->getfield('susp')) } ],
412       [ expire_ymd        => sub { $ymd->(shift->getfield('expire')) } ],
413       [ cancel_ymd        => sub { $ymd->(shift->getfield('cancel')) } ],
414     ],
415     'cust_bill' => [qw(
416       invnum
417       _date
418     )],
419     #XXX not really thinking about cust_bill substitutions quite yet
420     
421     # for welcome and limit warning messages
422     'svc_acct' => [qw(
423       svcnum
424       username
425       domain
426       ),
427       [ password          => sub { shift->getfield('_password') } ],
428     ],
429     'svc_domain' => [qw(
430       svcnum
431       domain
432       ),
433       [ registrar         => sub {
434           my $registrar = qsearchs('registrar', 
435             { registrarnum => shift->registrarnum} );
436           $registrar ? $registrar->registrarname : ''
437         }
438       ],
439       [ catchall          => sub { 
440           my $svc_acct = qsearchs('svc_acct', { svcnum => shift->catchall });
441           $svc_acct ? $svc_acct->email : ''
442         }
443       ],
444     ],
445     'svc_phone' => [qw(
446       svcnum
447       phonenum
448       countrycode
449       domain
450       )
451     ],
452     'svc_broadband' => [qw(
453       svcnum
454       speed_up
455       speed_down
456       ip_addr
457       mac_addr
458       )
459     ],
460     # for payment receipts
461     'cust_pay' => [qw(
462       paynum
463       _date
464       ),
465       [ paid              => sub { sprintf("%.2f", shift->paid) } ],
466       # overrides the one in cust_main in cases where a cust_pay is passed
467       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
468       [ date              => sub { time2str("%a %B %o, %Y", shift->_date) } ],
469       [ payinfo           => sub { 
470           my $cust_pay = shift;
471           ($cust_pay->payby eq 'CARD' || $cust_pay->payby eq 'CHEK') ?
472             $cust_pay->paymask : $cust_pay->decrypt($cust_pay->payinfo)
473         } ],
474     ],
475     # for payment decline messages
476     # try to support all cust_pay fields
477     # 'error' is a special case, it contains the raw error from the gateway
478     'cust_pay_pending' => [qw(
479       _date
480       error
481       ),
482       [ paid              => sub { sprintf("%.2f", shift->paid) } ],
483       [ payby             => sub { FS::payby->shortname(shift->payby) } ],
484       [ date              => sub { time2str("%a %B %o, %Y", shift->_date) } ],
485       [ payinfo           => sub {
486           my $pending = shift;
487           ($pending->payby eq 'CARD' || $pending->payby eq 'CHEK') ?
488             $pending->paymask : $pending->decrypt($pending->payinfo)
489         } ],
490     ],
491   };
492 }
493
494 sub _upgrade_data {
495   my ($self, %opts) = @_;
496
497   my @fixes = (
498     [ 'alerter_msgnum',  'alerter_template',   '',               '', '' ],
499     [ 'cancel_msgnum',   'cancelmessage',      'cancelsubject',  '', '' ],
500     [ 'decline_msgnum',  'declinetemplate',    '',               '', '' ],
501     [ 'impending_recur_msgnum', 'impending_recur_template', '',  '', 'impending_recur_bcc' ],
502     [ 'payment_receipt_msgnum', 'payment_receipt_email', '',     '', '' ],
503     [ 'welcome_msgnum',  'welcome_email',      'welcome_email-subject', 'welcome_email-from', '' ],
504     [ 'warning_msgnum',  'warning_email',      'warning_email-subject', 'warning_email-from', '' ],
505   );
506  
507   my $conf = new FS::Conf;
508   my @agentnums = ('', map {$_->agentnum} qsearch('agent', {}));
509   foreach my $agentnum (@agentnums) {
510     foreach (@fixes) {
511       my ($newname, $oldname, $subject, $from, $bcc) = @$_;
512       if ($conf->exists($oldname, $agentnum)) {
513         my $new = new FS::msg_template({
514            'msgname'   => $oldname,
515            'agentnum'  => $agentnum,
516            'from_addr' => ($from && $conf->config($from, $agentnum)) || 
517                           $conf->config('invoice_from', $agentnum),
518            'bcc_addr'  => ($bcc && $conf->config($from, $agentnum)) || '',
519            'subject'   => ($subject && $conf->config($subject, $agentnum)) || '',
520            'mime_type' => 'text/html',
521            'body'      => join('<BR>',$conf->config($oldname, $agentnum)),
522         });
523         my $error = $new->insert;
524         die $error if $error;
525         $conf->set($newname, $new->msgnum, $agentnum);
526         $conf->delete($oldname, $agentnum);
527         $conf->delete($from, $agentnum) if $from;
528         $conf->delete($subject, $agentnum) if $subject;
529       }
530     }
531   }
532 }
533
534 sub eviscerate {
535   # Every bit as pleasant as it sounds.
536   #
537   # We do this because Text::Template::Preprocess doesn't
538   # actually work.  It runs the entire template through 
539   # the preprocessor, instead of the code segments.  Which 
540   # is a shame, because Text::Template already contains
541   # the code to do this operation.
542   my $body = shift;
543   my (@outside, @inside);
544   my $depth = 0;
545   my $chunk = '';
546   while($body || $chunk) {
547     my ($first, $delim, $rest);
548     # put all leading non-delimiters into $first
549     ($first, $rest) =
550         ($body =~ /^((?:\\[{}]|[^{}])*)(.*)$/s);
551     $chunk .= $first;
552     # put a leading delimiter into $delim if there is one
553     ($delim, $rest) =
554       ($rest =~ /^([{}]?)(.*)$/s);
555
556     if( $delim eq '{' ) {
557       $chunk .= '{';
558       if( $depth == 0 ) {
559         push @outside, $chunk;
560         $chunk = '';
561       }
562       $depth++;
563     }
564     elsif( $delim eq '}' ) {
565       $depth--;
566       if( $depth == 0 ) {
567         push @inside, $chunk;
568         $chunk = '';
569       }
570       $chunk .= '}';
571     }
572     else {
573       # no more delimiters
574       if( $depth == 0 ) {
575         push @outside, $chunk . $rest;
576       } # else ? something wrong
577       last;
578     }
579     $body = $rest;
580   }
581   (\@outside, \@inside);
582 }
583
584 =back
585
586 =head1 BUGS
587
588 =head1 SEE ALSO
589
590 L<FS::Record>, schema.html from the base documentation.
591
592 =cut
593
594 1;
595