re-write RADIUS groups, RT13274
[freeside.git] / FS / FS / svc_acct.pm
1 package FS::svc_acct;
2
3 use strict;
4 use base qw( FS::svc_Domain_Mixin FS::svc_CGP_Mixin FS::svc_CGPRule_Mixin
5              FS::svc_Common );
6 use vars qw( $DEBUG $me $conf $skip_fuzzyfiles
7              $dir_prefix @shells $usernamemin
8              $usernamemax $passwordmin $passwordmax
9              $username_ampersand $username_letter $username_letterfirst
10              $username_noperiod $username_nounderscore $username_nodash
11              $username_uppercase $username_percent $username_colon
12              $username_slash $username_equals $username_pound
13              $password_noampersand $password_noexclamation
14              $warning_template $warning_from $warning_subject $warning_mimetype
15              $warning_cc
16              $smtpmachine
17              $radius_password $radius_ip
18              $dirhash
19              @saltset @pw_set );
20 use Scalar::Util qw( blessed );
21 use Math::BigInt;
22 use Carp;
23 use Fcntl qw(:flock);
24 use Date::Format;
25 use Crypt::PasswdMD5 1.2;
26 use Digest::SHA1 'sha1_base64';
27 use Digest::MD5 'md5_base64';
28 use Data::Dumper;
29 use Text::Template;
30 use Authen::Passphrase;
31 use FS::UID qw( datasrc driver_name );
32 use FS::Conf;
33 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
34 use FS::Msgcat qw(gettext);
35 use FS::UI::bytecount;
36 use FS::UI::Web;
37 use FS::part_pkg;
38 use FS::part_svc;
39 use FS::svc_acct_pop;
40 use FS::cust_main_invoice;
41 use FS::svc_domain;
42 use FS::svc_pbx;
43 use FS::raddb;
44 use FS::queue;
45 use FS::radius_usergroup;
46 use FS::radius_group;
47 use FS::export_svc;
48 use FS::part_export;
49 use FS::svc_forward;
50 use FS::svc_www;
51 use FS::cdr;
52 use FS::acct_snarf;
53
54 $DEBUG = 0;
55 $me = '[FS::svc_acct]';
56
57 #ask FS::UID to run this stuff for us later
58 FS::UID->install_callback( sub { 
59   $conf = new FS::Conf;
60   $dir_prefix = $conf->config('home');
61   @shells = $conf->config('shells');
62   $usernamemin = $conf->config('usernamemin') || 2;
63   $usernamemax = $conf->config('usernamemax');
64   $passwordmin = $conf->config('passwordmin'); # || 6;
65   #blank->6, keep 0
66   $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
67                    ? $passwordmin
68                    : 6;
69   $passwordmax = $conf->config('passwordmax') || 8;
70   $username_letter = $conf->exists('username-letter');
71   $username_letterfirst = $conf->exists('username-letterfirst');
72   $username_noperiod = $conf->exists('username-noperiod');
73   $username_nounderscore = $conf->exists('username-nounderscore');
74   $username_nodash = $conf->exists('username-nodash');
75   $username_uppercase = $conf->exists('username-uppercase');
76   $username_ampersand = $conf->exists('username-ampersand');
77   $username_percent = $conf->exists('username-percent');
78   $username_colon = $conf->exists('username-colon');
79   $username_slash = $conf->exists('username-slash');
80   $username_equals = $conf->exists('username-equals');
81   $username_pound = $conf->exists('username-pound');
82   $password_noampersand = $conf->exists('password-noexclamation');
83   $password_noexclamation = $conf->exists('password-noexclamation');
84   $dirhash = $conf->config('dirhash') || 0;
85   if ( $conf->exists('warning_email') ) {
86     $warning_template = new Text::Template (
87       TYPE   => 'ARRAY',
88       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
89     ) or warn "can't create warning email template: $Text::Template::ERROR";
90     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
91     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
92     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
93     $warning_cc = $conf->config('warning_email-cc');
94   } else {
95     $warning_template = '';
96     $warning_from = '';
97     $warning_subject = '';
98     $warning_mimetype = '';
99     $warning_cc = '';
100   }
101   $smtpmachine = $conf->config('smtpmachine');
102   $radius_password = $conf->config('radius-password') || 'Password';
103   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
104   @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
105 }
106 );
107
108 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
109 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '.', ',' );
110
111 sub _cache {
112   my $self = shift;
113   my ( $hashref, $cache ) = @_;
114   if ( $hashref->{'svc_acct_svcnum'} ) {
115     $self->{'_domsvc'} = FS::svc_domain->new( {
116       'svcnum'   => $hashref->{'domsvc'},
117       'domain'   => $hashref->{'svc_acct_domain'},
118       'catchall' => $hashref->{'svc_acct_catchall'},
119     } );
120   }
121 }
122
123 =head1 NAME
124
125 FS::svc_acct - Object methods for svc_acct records
126
127 =head1 SYNOPSIS
128
129   use FS::svc_acct;
130
131   $record = new FS::svc_acct \%hash;
132   $record = new FS::svc_acct { 'column' => 'value' };
133
134   $error = $record->insert;
135
136   $error = $new_record->replace($old_record);
137
138   $error = $record->delete;
139
140   $error = $record->check;
141
142   $error = $record->suspend;
143
144   $error = $record->unsuspend;
145
146   $error = $record->cancel;
147
148   %hash = $record->radius;
149
150   %hash = $record->radius_reply;
151
152   %hash = $record->radius_check;
153
154   $domain = $record->domain;
155
156   $svc_domain = $record->svc_domain;
157
158   $email = $record->email;
159
160   $seconds_since = $record->seconds_since($timestamp);
161
162 =head1 DESCRIPTION
163
164 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
165 FS::svc_Common.  The following fields are currently supported:
166
167 =over 4
168
169 =item svcnum
170
171 Primary key (assigned automatcially for new accounts)
172
173 =item username
174
175 =item _password
176
177 generated if blank
178
179 =item _password_encoding
180
181 plain, crypt, ldap (or empty for autodetection)
182
183 =item sec_phrase
184
185 security phrase
186
187 =item popnum
188
189 Point of presence (see L<FS::svc_acct_pop>)
190
191 =item uid
192
193 =item gid
194
195 =item finger
196
197 GECOS
198
199 =item dir
200
201 set automatically if blank (and uid is not)
202
203 =item shell
204
205 =item quota
206
207 =item slipip
208
209 IP address
210
211 =item seconds
212
213 =item upbytes
214
215 =item downbyte
216
217 =item totalbytes
218
219 =item domsvc
220
221 svcnum from svc_domain
222
223 =item pbxsvc
224
225 Optional svcnum from svc_pbx
226
227 =item radius_I<Radius_Attribute>
228
229 I<Radius-Attribute> (reply)
230
231 =item rc_I<Radius_Attribute>
232
233 I<Radius-Attribute> (check)
234
235 =back
236
237 =head1 METHODS
238
239 =over 4
240
241 =item new HASHREF
242
243 Creates a new account.  To add the account to the database, see L<"insert">.
244
245 =cut
246
247 sub table_info {
248   {
249     'name'   => 'Account',
250     'longname_plural' => 'Access accounts and mailboxes',
251     'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
252     'display_weight' => 10,
253     'cancel_weight'  => 50, 
254     'fields' => {
255         'dir'       => 'Home directory',
256         'uid'       => {
257                          label    => 'UID',
258                          def_info => 'set to fixed and blank for no UIDs',
259                          type     => 'text',
260                        },
261         'slipip'    => 'IP address',
262     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
263         'popnum'    => {
264                          label => 'Access number',
265                          type => 'select',
266                          select_table => 'svc_acct_pop',
267                          select_key   => 'popnum',
268                          select_label => 'city',
269                          disable_select => 1,
270                        },
271         'username'  => {
272                          label => 'Username',
273                          type => 'text',
274                          disable_default => 1,
275                          disable_fixed => 1,
276                          disable_select => 1,
277                        },
278         'password_selfchange' => { label => 'Password modification',
279                                    type  => 'checkbox',
280                                  },
281         'password_recover'    => { label => 'Password recovery',
282                                    type  => 'checkbox',
283                                  },
284         'quota'     => { 
285                          label => 'Quota', #Mail storage limit
286                          type => 'text',
287                          disable_inventory => 1,
288                          disable_select => 1,
289                        },
290         'file_quota'=> { 
291                          label => 'File storage limit',
292                          type => 'text',
293                          disable_inventory => 1,
294                          disable_select => 1,
295                        },
296         'file_maxnum'=> { 
297                          label => 'Number of files limit',
298                          type => 'text',
299                          disable_inventory => 1,
300                          disable_select => 1,
301                        },
302         'file_maxsize'=> { 
303                          label => 'File size limit',
304                          type => 'text',
305                          disable_inventory => 1,
306                          disable_select => 1,
307                        },
308         '_password' => 'Password',
309         'gid'       => {
310                          label    => 'GID',
311                          def_info => 'when blank, defaults to UID',
312                          type     => 'text',
313                        },
314         'shell'     => {
315                          label    => 'Shell',
316                          def_info => 'set to blank for no shell tracking',
317                          type     => 'select',
318                          #select_list => [ $conf->config('shells') ],
319                          select_list => [ $conf ? $conf->config('shells') : () ],
320                          disable_inventory => 1,
321                          disable_select => 1,
322                        },
323         'finger'    => 'Real name', # (GECOS)',
324         'domsvc'    => {
325                          label     => 'Domain',
326                          type      => 'select',
327                          select_table => 'svc_domain',
328                          select_key   => 'svcnum',
329                          select_label => 'domain',
330                          disable_inventory => 1,
331                        },
332         'pbxsvc'    => { label => 'PBX',
333                          type  => 'select-svc_pbx.html',
334                          disable_inventory => 1,
335                          disable_select => 1, #UI wonky, pry works otherwise
336                        },
337         'usergroup' => {
338                          label => 'RADIUS groups',
339                          type  => 'select-radius_group.html',
340                          disable_inventory => 1,
341                          disable_select => 1,
342                        },
343         'seconds'   => { label => 'Seconds',
344                          label_sort => 'with Time Remaining',
345                          type  => 'text',
346                          disable_inventory => 1,
347                          disable_select => 1,
348                          disable_part_svc_column => 1,
349                        },
350         'upbytes'   => { label => 'Upload',
351                          type  => 'text',
352                          disable_inventory => 1,
353                          disable_select => 1,
354                          'format' => \&FS::UI::bytecount::display_bytecount,
355                          'parse' => \&FS::UI::bytecount::parse_bytecount,
356                          disable_part_svc_column => 1,
357                        },
358         'downbytes' => { label => 'Download',
359                          type  => 'text',
360                          disable_inventory => 1,
361                          disable_select => 1,
362                          'format' => \&FS::UI::bytecount::display_bytecount,
363                          'parse' => \&FS::UI::bytecount::parse_bytecount,
364                          disable_part_svc_column => 1,
365                        },
366         'totalbytes'=> { label => 'Total up and download',
367                          type  => 'text',
368                          disable_inventory => 1,
369                          disable_select => 1,
370                          'format' => \&FS::UI::bytecount::display_bytecount,
371                          'parse' => \&FS::UI::bytecount::parse_bytecount,
372                          disable_part_svc_column => 1,
373                        },
374         'seconds_threshold'   => { label => 'Seconds threshold',
375                                    type  => 'text',
376                                    disable_inventory => 1,
377                                    disable_select => 1,
378                                    disable_part_svc_column => 1,
379                                  },
380         'upbytes_threshold'   => { label => 'Upload threshold',
381                                    type  => 'text',
382                                    disable_inventory => 1,
383                                    disable_select => 1,
384                                    'format' => \&FS::UI::bytecount::display_bytecount,
385                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
386                                    disable_part_svc_column => 1,
387                                  },
388         'downbytes_threshold' => { label => 'Download threshold',
389                                    type  => 'text',
390                                    disable_inventory => 1,
391                                    disable_select => 1,
392                                    'format' => \&FS::UI::bytecount::display_bytecount,
393                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
394                                    disable_part_svc_column => 1,
395                                  },
396         'totalbytes_threshold'=> { label => 'Total up and download threshold',
397                                    type  => 'text',
398                                    disable_inventory => 1,
399                                    disable_select => 1,
400                                    'format' => \&FS::UI::bytecount::display_bytecount,
401                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
402                                    disable_part_svc_column => 1,
403                                  },
404         'last_login'=>           {
405                                    label     => 'Last login',
406                                    type      => 'disabled',
407                                  },
408         'last_logout'=>          {
409                                    label     => 'Last logout',
410                                    type      => 'disabled',
411                                  },
412
413         'cgp_aliases' => { 
414                            label => 'Communigate aliases',
415                            type  => 'text',
416                            disable_inventory => 1,
417                            disable_select    => 1,
418                          },
419         #settings
420         'cgp_type'=> { 
421                        label => 'Communigate account type',
422                        type => 'select',
423                        select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
424                        disable_inventory => 1,
425                        disable_select    => 1,
426                      },
427         'cgp_accessmodes' => { 
428                                label => 'Communigate enabled services',
429                                type  => 'communigate_pro-accessmodes',
430                                disable_inventory => 1,
431                                disable_select    => 1,
432                              },
433         'cgp_rulesallowed'   => {
434           label       => 'Allowed mail rules',
435           type        => 'select',
436           select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
437           disable_inventory => 1,
438           disable_select    => 1,
439         },
440         'cgp_rpopallowed'    => { label => 'RPOP modifications',
441                                   type  => 'checkbox',
442                                 },
443         'cgp_mailtoall'      => { label => 'Accepts mail to "all"',
444                                   type  => 'checkbox',
445                                 },
446         'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
447                                   type  => 'checkbox',
448                                 },
449         'cgp_archiveafter'   => {
450           label       => 'Archive messages after',
451           type        => 'select',
452           select_hash => [ 
453                            -2 => 'default(730 days)',
454                            0 => 'Never',
455                            86400 => '24 hours',
456                            172800 => '2 days',
457                            259200 => '3 days',
458                            432000 => '5 days',
459                            604800 => '7 days',
460                            1209600 => '2 weeks',
461                            2592000 => '30 days',
462                            7776000 => '90 days',
463                            15552000 => '180 days',
464                            31536000 => '365 days',
465                            63072000 => '730 days',
466                          ],
467           disable_inventory => 1,
468           disable_select    => 1,
469         },
470         #XXX mailing lists
471
472         #preferences
473         'cgp_deletemode' => { 
474                               label => 'Communigate message delete method',
475                               type  => 'select',
476                               select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
477                               disable_inventory => 1,
478                               disable_select    => 1,
479                             },
480         'cgp_emptytrash' => { 
481                               label     => 'Communigate on logout remove trash',
482                               type        => 'select',
483                               select_list => __PACKAGE__->cgp_emptytrash_values,
484                               disable_inventory => 1,
485                               disable_select    => 1,
486                             },
487         'cgp_language' => {
488                             label => 'Communigate language',
489                             type  => 'select',
490                             select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
491                             disable_inventory => 1,
492                             disable_select    => 1,
493                           },
494         'cgp_timezone' => {
495                             label       => 'Communigate time zone',
496                             type        => 'select',
497                             select_list => __PACKAGE__->cgp_timezone_values,
498                             disable_inventory => 1,
499                             disable_select    => 1,
500                           },
501         'cgp_skinname' => {
502                             label => 'Communigate layout',
503                             type  => 'select',
504                             select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
505                             disable_inventory => 1,
506                             disable_select    => 1,
507                           },
508         'cgp_prontoskinname' => {
509                             label => 'Communigate Pronto style',
510                             type  => 'select',
511                             select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ],
512                             disable_inventory => 1,
513                             disable_select    => 1,
514                           },
515         'cgp_sendmdnmode' => {
516           label => 'Communigate send read receipts',
517           type  => 'select',
518           select_list => [ '', 'Never', 'Manually', 'Automatically' ],
519           disable_inventory => 1,
520           disable_select    => 1,
521         },
522
523         #mail
524         #XXX RPOP settings
525
526     },
527   };
528 }
529
530 sub table { 'svc_acct'; }
531
532 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
533
534 sub _fieldhandlers {
535   {
536     #false laziness with edit/svc_acct.cgi
537     'usergroup' => sub { 
538                          my( $self, $groups ) = @_;
539                          if ( ref($groups) eq 'ARRAY' ) {
540                            $groups;
541                          } elsif ( length($groups) ) {
542                            [ split(/\s*,\s*/, $groups) ];
543                          } else {
544                            [];
545                          }
546                        },
547   };
548 }
549
550 sub last_login {
551   shift->_lastlog('in', @_);
552 }
553
554 sub last_logout {
555   shift->_lastlog('out', @_);
556 }
557
558 sub _lastlog {
559   my( $self, $op, $time ) = @_;
560
561   if ( defined($time) ) {
562     warn "$me last_log$op called on svcnum ". $self->svcnum.
563          ' ('. $self->email. "): $time\n"
564       if $DEBUG;
565
566     my $dbh = dbh;
567
568     my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
569     warn "$me $sql\n"
570       if $DEBUG;
571
572     my $sth = $dbh->prepare( $sql )
573       or die "Error preparing $sql: ". $dbh->errstr;
574     my $rv = $sth->execute($time, $self->svcnum);
575     die "Error executing $sql: ". $sth->errstr
576       unless defined($rv);
577     die "Can't update last_log$op for svcnum". $self->svcnum
578       if $rv == 0;
579
580     $self->{'Hash'}->{"last_log$op"} = $time;
581   }else{
582     $self->getfield("last_log$op");
583   }
584 }
585
586 =item search_sql STRING
587
588 Class method which returns an SQL fragment to search for the given string.
589
590 =cut
591
592 sub search_sql {
593   my( $class, $string ) = @_;
594   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
595     my( $username, $domain ) = ( $1, $2 );
596     my $q_username = dbh->quote($username);
597     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
598     if ( @svc_domain ) {
599       "svc_acct.username = $q_username AND ( ".
600         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
601       " )";
602     } else {
603       '1 = 0'; #false
604     }
605   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
606     ' ( '.
607       $class->search_sql_field('slipip',   $string ).
608     ' OR '.
609       $class->search_sql_field('username', $string ).
610     ' ) ';
611   } else {
612     $class->search_sql_field('username', $string);
613   }
614 }
615
616 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
617
618 Returns the "username@domain" string for this account.
619
620 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
621 history records.
622
623 =cut
624
625 sub label {
626   my $self = shift;
627   $self->email(@_);
628 }
629
630 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
631
632 Returns a longer string label for this acccount ("Real Name <username@domain>"
633 if available, or "username@domain").
634
635 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
636 history records.
637
638 =cut
639
640 sub label_long {
641   my $self = shift;
642   my $label = $self->label(@_);
643   my $finger = $self->finger;
644   return $label unless $finger =~ /\S/;
645   my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
646   $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
647   "$finger <$label>";
648 }
649
650 =item insert [ , OPTION => VALUE ... ]
651
652 Adds this account to the database.  If there is an error, returns the error,
653 otherwise returns false.
654
655 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be 
656 defined.  An FS::cust_svc record will be created and inserted.
657
658 The additional field I<usergroup> can optionally be defined; if so it should
659 contain an arrayref of group names.  See L<FS::radius_usergroup>.
660
661 The additional field I<child_objects> can optionally be defined; if so it
662 should contain an arrayref of FS::tablename objects.  They will have their
663 svcnum fields set and will be inserted after this record, but before any
664 exports are run.  Each element of the array can also optionally be a
665 two-element array reference containing the child object and the name of an
666 alternate field to be filled in with the newly-inserted svcnum, for example
667 C<[ $svc_forward, 'srcsvc' ]>
668
669 Currently available options are: I<depend_jobnum>
670
671 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
672 jobnums), all provisioning jobs will have a dependancy on the supplied
673 jobnum(s) (they will not run until the specific job(s) complete(s)).
674
675 (TODOC: L<FS::queue> and L<freeside-queued>)
676
677 (TODOC: new exports!)
678
679 =cut
680
681 sub insert {
682   my $self = shift;
683   my %options = @_;
684
685   if ( $DEBUG ) {
686     warn "[$me] insert called on $self: ". Dumper($self).
687          "\nwith options: ". Dumper(%options);
688   }
689
690   local $SIG{HUP} = 'IGNORE';
691   local $SIG{INT} = 'IGNORE';
692   local $SIG{QUIT} = 'IGNORE';
693   local $SIG{TERM} = 'IGNORE';
694   local $SIG{TSTP} = 'IGNORE';
695   local $SIG{PIPE} = 'IGNORE';
696
697   my $oldAutoCommit = $FS::UID::AutoCommit;
698   local $FS::UID::AutoCommit = 0;
699   my $dbh = dbh;
700
701   my @jobnums;
702   my $error = $self->SUPER::insert(
703     'jobnums'       => \@jobnums,
704     'child_objects' => $self->child_objects,
705     %options,
706   );
707   if ( $error ) {
708     $dbh->rollback if $oldAutoCommit;
709     return $error;
710   }
711
712   if ( $self->usergroup ) {
713     foreach my $groupnum ( @{$self->usergroup} ) {
714       my $radius_usergroup = new FS::radius_usergroup ( {
715         svcnum    => $self->svcnum,
716         groupnum  => $groupnum,
717       } );
718       my $error = $radius_usergroup->insert;
719       if ( $error ) {
720         $dbh->rollback if $oldAutoCommit;
721         return $error;
722       }
723     }
724   }
725
726   unless ( $skip_fuzzyfiles ) {
727     $error = $self->queue_fuzzyfiles_update;
728     if ( $error ) {
729       $dbh->rollback if $oldAutoCommit;
730       return "updating fuzzy search cache: $error";
731     }
732   }
733
734   my $cust_pkg = $self->cust_svc->cust_pkg;
735
736   if ( $cust_pkg ) {
737     my $cust_main = $cust_pkg->cust_main;
738     my $agentnum = $cust_main->agentnum;
739
740     if (   $conf->exists('emailinvoiceautoalways')
741         || $conf->exists('emailinvoiceauto')
742         && ! $cust_main->invoicing_list_emailonly
743        ) {
744       my @invoicing_list = $cust_main->invoicing_list;
745       push @invoicing_list, $self->email;
746       $cust_main->invoicing_list(\@invoicing_list);
747     }
748
749     #welcome email
750     my @welcome_exclude_svcparts = $conf->config('svc_acct_welcome_exclude');
751     unless ( grep { $_ eq $self->svcpart } @welcome_exclude_svcparts ) {
752         my $error = '';
753         my $msgnum = $conf->config('welcome_msgnum', $agentnum);
754         if ( $msgnum ) {
755           my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
756           $error = $msg_template->send('cust_main' => $cust_main,
757                                        'object'    => $self);
758         }
759         else { #!$msgnum
760           my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
761             = ('','','','','','');
762
763           if ( $conf->exists('welcome_email', $agentnum) ) {
764             $welcome_template = new Text::Template (
765               TYPE   => 'ARRAY',
766               SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
767             ) or warn "can't create welcome email template: $Text::Template::ERROR";
768             $welcome_from = $conf->config('welcome_email-from', $agentnum);
769               # || 'your-isp-is-dum'
770             $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
771               || 'Welcome';
772             $welcome_subject_template = new Text::Template (
773               TYPE   => 'STRING',
774               SOURCE => $welcome_subject,
775             ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
776             $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
777               || 'text/plain';
778           }
779           if ( $welcome_template ) {
780             my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
781             if ( $to ) {
782
783               my %hash = (
784                            'custnum'  => $self->custnum,
785                            'username' => $self->username,
786                            'password' => $self->_password,
787                            'first'    => $cust_main->first,
788                            'last'     => $cust_main->getfield('last'),
789                            'pkg'      => $cust_pkg->part_pkg->pkg,
790                          );
791               my $wqueue = new FS::queue {
792                 'svcnum' => $self->svcnum,
793                 'job'    => 'FS::svc_acct::send_email'
794               };
795               my $error = $wqueue->insert(
796                 'to'       => $to,
797                 'from'     => $welcome_from,
798                 'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
799                 'mimetype' => $welcome_mimetype,
800                 'body'     => $welcome_template->fill_in( HASH => \%hash, ),
801               );
802               if ( $error ) {
803                 $dbh->rollback if $oldAutoCommit;
804                 return "error queuing welcome email: $error";
805               }
806
807               if ( $options{'depend_jobnum'} ) {
808                 warn "$me depend_jobnum found; adding to welcome email dependancies"
809                   if $DEBUG;
810                 if ( ref($options{'depend_jobnum'}) ) {
811                   warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
812                        "to welcome email dependancies"
813                     if $DEBUG;
814                   push @jobnums, @{ $options{'depend_jobnum'} };
815                 } else {
816                   warn "$me adding job $options{'depend_jobnum'} ".
817                        "to welcome email dependancies"
818                     if $DEBUG;
819                   push @jobnums, $options{'depend_jobnum'};
820                 }
821               }
822
823               foreach my $jobnum ( @jobnums ) {
824                 my $error = $wqueue->depend_insert($jobnum);
825                 if ( $error ) {
826                   $dbh->rollback if $oldAutoCommit;
827                   return "error queuing welcome email job dependancy: $error";
828                 }
829               }
830
831             }
832
833           } # if $welcome_template
834         } # if !$msgnum
835     }
836   } # if $cust_pkg
837
838   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
839   ''; #no error
840 }
841
842 # set usage fields and thresholds if unset but set in a package def
843 # AND the package already has a last bill date (otherwise they get double added)
844 sub preinsert_hook_first {
845   my $self = shift;
846
847   return '' unless $self->pkgnum;
848
849   my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
850   return '' unless $cust_pkg && $cust_pkg->last_bill;
851
852   my $part_pkg = $cust_pkg->part_pkg;
853   return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
854
855   my %values = $part_pkg->usage_valuehash;
856   my $multiplier = $conf->exists('svc_acct-usage_threshold') 
857                      ? 1 - $conf->config('svc_acct-usage_threshold')/100
858                      : 0.20; #doesn't matter
859
860   foreach ( keys %values ) {
861     next if $self->getfield($_);
862     $self->setfield( $_, $values{$_} );
863     $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
864       if $conf->exists('svc_acct-usage_threshold');
865   }
866
867   ''; #no error
868 }
869
870 =item delete
871
872 Deletes this account from the database.  If there is an error, returns the
873 error, otherwise returns false.
874
875 The corresponding FS::cust_svc record will be deleted as well.
876
877 (TODOC: new exports!)
878
879 =cut
880
881 sub delete {
882   my $self = shift;
883
884   return "can't delete system account" if $self->_check_system;
885
886   return "Can't delete an account which is a (svc_forward) source!"
887     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
888
889   return "Can't delete an account which is a (svc_forward) destination!"
890     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
891
892   return "Can't delete an account with (svc_www) web service!"
893     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
894
895   # what about records in session ? (they should refer to history table)
896
897   local $SIG{HUP} = 'IGNORE';
898   local $SIG{INT} = 'IGNORE';
899   local $SIG{QUIT} = 'IGNORE';
900   local $SIG{TERM} = 'IGNORE';
901   local $SIG{TSTP} = 'IGNORE';
902   local $SIG{PIPE} = 'IGNORE';
903
904   my $oldAutoCommit = $FS::UID::AutoCommit;
905   local $FS::UID::AutoCommit = 0;
906   my $dbh = dbh;
907
908   foreach my $cust_main_invoice (
909     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
910   ) {
911     unless ( defined($cust_main_invoice) ) {
912       warn "WARNING: something's wrong with qsearch";
913       next;
914     }
915     my %hash = $cust_main_invoice->hash;
916     $hash{'dest'} = $self->email;
917     my $new = new FS::cust_main_invoice \%hash;
918     my $error = $new->replace($cust_main_invoice);
919     if ( $error ) {
920       $dbh->rollback if $oldAutoCommit;
921       return $error;
922     }
923   }
924
925   foreach my $svc_domain (
926     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
927   ) {
928     my %hash = new FS::svc_domain->hash;
929     $hash{'catchall'} = '';
930     my $new = new FS::svc_domain \%hash;
931     my $error = $new->replace($svc_domain);
932     if ( $error ) {
933       $dbh->rollback if $oldAutoCommit;
934       return $error;
935     }
936   }
937
938   my $error = $self->SUPER::delete;
939   if ( $error ) {
940     $dbh->rollback if $oldAutoCommit;
941     return $error;
942   }
943
944   foreach my $radius_usergroup (
945     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
946   ) {
947     my $error = $radius_usergroup->delete;
948     if ( $error ) {
949       $dbh->rollback if $oldAutoCommit;
950       return $error;
951     }
952   }
953
954   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
955   '';
956 }
957
958 =item replace OLD_RECORD
959
960 Replaces OLD_RECORD with this one in the database.  If there is an error,
961 returns the error, otherwise returns false.
962
963 The additional field I<usergroup> can optionally be defined; if so it should
964 contain an arrayref of group names.  See L<FS::radius_usergroup>.
965
966
967 =cut
968
969 sub replace {
970   my $new = shift;
971
972   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
973               ? shift
974               : $new->replace_old;
975
976   warn "$me replacing $old with $new\n" if $DEBUG;
977
978   my $error;
979
980   return "can't modify system account" if $old->_check_system;
981
982   {
983     #no warnings 'numeric';  #alas, a 5.006-ism
984     local($^W) = 0;
985
986     foreach my $xid (qw( uid gid )) {
987
988       return "Can't change $xid!"
989         if ! $conf->exists("svc_acct-edit_$xid")
990            && $old->$xid() != $new->$xid()
991            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
992     }
993
994   }
995
996   return "can't change username"
997     if $old->username ne $new->username
998     && $conf->exists('svc_acct-no_edit_username');
999
1000   #change homdir when we change username
1001   $new->setfield('dir', '') if $old->username ne $new->username;
1002
1003   local $SIG{HUP} = 'IGNORE';
1004   local $SIG{INT} = 'IGNORE';
1005   local $SIG{QUIT} = 'IGNORE';
1006   local $SIG{TERM} = 'IGNORE';
1007   local $SIG{TSTP} = 'IGNORE';
1008   local $SIG{PIPE} = 'IGNORE';
1009
1010   my $oldAutoCommit = $FS::UID::AutoCommit;
1011   local $FS::UID::AutoCommit = 0;
1012   my $dbh = dbh;
1013
1014   # redundant, but so $new->usergroup gets set
1015   $error = $new->check;
1016   return $error if $error;
1017
1018   $old->usergroup( [ $old->radius_groups('NUMBERS') ] );
1019   if ( $DEBUG ) {
1020     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
1021     warn $new->email. " new groups: ". join(' ',@{$new->usergroup}). "\n";
1022   }
1023   if ( $new->usergroup ) {
1024     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
1025     my @newgroups = @{$new->usergroup};
1026     foreach my $oldgroup ( @{$old->usergroup} ) {
1027       if ( grep { $oldgroup eq $_ } @newgroups ) {
1028         @newgroups = grep { $oldgroup ne $_ } @newgroups;
1029         next;
1030       }
1031       my $radius_usergroup = qsearchs('radius_usergroup', {
1032         svcnum    => $old->svcnum,
1033         groupnum  => $oldgroup,
1034       } );
1035       my $error = $radius_usergroup->delete;
1036       if ( $error ) {
1037         $dbh->rollback if $oldAutoCommit;
1038         return "error deleting radius_usergroup $oldgroup: $error";
1039       }
1040     }
1041
1042     foreach my $newgroup ( @newgroups ) {
1043       my $radius_usergroup = new FS::radius_usergroup ( {
1044         svcnum    => $new->svcnum,
1045         groupnum => $newgroup,
1046       } );
1047       my $error = $radius_usergroup->insert;
1048       if ( $error ) {
1049         $dbh->rollback if $oldAutoCommit;
1050         return "error adding radius_usergroup $newgroup: $error";
1051       }
1052     }
1053
1054   }
1055
1056   $error = $new->SUPER::replace($old, @_);
1057   if ( $error ) {
1058     $dbh->rollback if $oldAutoCommit;
1059     return $error if $error;
1060   }
1061
1062   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1063     $error = $new->queue_fuzzyfiles_update;
1064     if ( $error ) {
1065       $dbh->rollback if $oldAutoCommit;
1066       return "updating fuzzy search cache: $error";
1067     }
1068   }
1069
1070   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1071   ''; #no error
1072 }
1073
1074 =item queue_fuzzyfiles_update
1075
1076 Used by insert & replace to update the fuzzy search cache
1077
1078 =cut
1079
1080 sub queue_fuzzyfiles_update {
1081   my $self = shift;
1082
1083   local $SIG{HUP} = 'IGNORE';
1084   local $SIG{INT} = 'IGNORE';
1085   local $SIG{QUIT} = 'IGNORE';
1086   local $SIG{TERM} = 'IGNORE';
1087   local $SIG{TSTP} = 'IGNORE';
1088   local $SIG{PIPE} = 'IGNORE';
1089
1090   my $oldAutoCommit = $FS::UID::AutoCommit;
1091   local $FS::UID::AutoCommit = 0;
1092   my $dbh = dbh;
1093
1094   my $queue = new FS::queue {
1095     'svcnum' => $self->svcnum,
1096     'job'    => 'FS::svc_acct::append_fuzzyfiles'
1097   };
1098   my $error = $queue->insert($self->username);
1099   if ( $error ) {
1100     $dbh->rollback if $oldAutoCommit;
1101     return "queueing job (transaction rolled back): $error";
1102   }
1103
1104   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1105   '';
1106
1107 }
1108
1109
1110 =item suspend
1111
1112 Suspends this account by calling export-specific suspend hooks.  If there is
1113 an error, returns the error, otherwise returns false.
1114
1115 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1116
1117 =cut
1118
1119 sub suspend {
1120   my $self = shift;
1121   return "can't suspend system account" if $self->_check_system;
1122   $self->SUPER::suspend(@_);
1123 }
1124
1125 =item unsuspend
1126
1127 Unsuspends this account by by calling export-specific suspend hooks.  If there
1128 is an error, returns the error, otherwise returns false.
1129
1130 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1131
1132 =cut
1133
1134 sub unsuspend {
1135   my $self = shift;
1136   my %hash = $self->hash;
1137   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1138     $hash{_password} = $1;
1139     my $new = new FS::svc_acct ( \%hash );
1140     my $error = $new->replace($self);
1141     return $error if $error;
1142   }
1143
1144   $self->SUPER::unsuspend(@_);
1145 }
1146
1147 =item cancel
1148
1149 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1150
1151 If the B<auto_unset_catchall> configuration option is set, this method will
1152 automatically remove any references to the canceled service in the catchall
1153 field of svc_domain.  This allows packages that contain both a svc_domain and
1154 its catchall svc_acct to be canceled in one step.
1155
1156 =cut
1157
1158 sub cancel {
1159   # Only one thing to do at this level
1160   my $self = shift;
1161   foreach my $svc_domain (
1162       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1163     if($conf->exists('auto_unset_catchall')) {
1164       my %hash = $svc_domain->hash;
1165       $hash{catchall} = '';
1166       my $new = new FS::svc_domain ( \%hash );
1167       my $error = $new->replace($svc_domain);
1168       return $error if $error;
1169     } else {
1170       return "cannot unprovision svc_acct #".$self->svcnum.
1171           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1172     }
1173   }
1174
1175   $self->SUPER::cancel(@_);
1176 }
1177
1178
1179 =item check
1180
1181 Checks all fields to make sure this is a valid service.  If there is an error,
1182 returns the error, otherwise returns false.  Called by the insert and replace
1183 methods.
1184
1185 Sets any fixed values; see L<FS::part_svc>.
1186
1187 =cut
1188
1189 sub check {
1190   my $self = shift;
1191
1192   my($recref) = $self->hashref;
1193
1194   my $x = $self->setfixed( $self->_fieldhandlers );
1195   return $x unless ref($x);
1196   my $part_svc = $x;
1197
1198   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1199     $self->usergroup(
1200       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1201   }
1202
1203   my $error = $self->ut_numbern('svcnum')
1204               #|| $self->ut_number('domsvc')
1205               || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1206               || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx',    'svcnum' )
1207               || $self->ut_textn('sec_phrase')
1208               || $self->ut_snumbern('seconds')
1209               || $self->ut_snumbern('upbytes')
1210               || $self->ut_snumbern('downbytes')
1211               || $self->ut_snumbern('totalbytes')
1212               || $self->ut_snumbern('seconds_threshold')
1213               || $self->ut_snumbern('upbytes_threshold')
1214               || $self->ut_snumbern('downbytes_threshold')
1215               || $self->ut_snumbern('totalbytes_threshold')
1216               || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1217               || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1218               || $self->ut_enum('password_recover',    [ '', 'Y' ])
1219               #cardfortress
1220               || $self->ut_anything('cf_privatekey')
1221               #communigate
1222               || $self->ut_textn('cgp_accessmodes')
1223               || $self->ut_alphan('cgp_type')
1224               || $self->ut_textn('cgp_aliases' ) #well
1225               # settings
1226               || $self->ut_alphasn('cgp_rulesallowed')
1227               || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1228               || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1229               || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1230               || $self->ut_snumbern('cgp_archiveafter')
1231               # preferences
1232               || $self->ut_alphasn('cgp_deletemode')
1233               || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1234               || $self->ut_alphan('cgp_language')
1235               || $self->ut_textn('cgp_timezone')
1236               || $self->ut_textn('cgp_skinname')
1237               || $self->ut_textn('cgp_prontoskinname')
1238               || $self->ut_alphan('cgp_sendmdnmode')
1239   ;
1240   return $error if $error;
1241
1242   my $cust_pkg;
1243   local $username_letter = $username_letter;
1244   if ($self->svcnum) {
1245     my $cust_svc = $self->cust_svc
1246       or return "no cust_svc record found for svcnum ". $self->svcnum;
1247     my $cust_pkg = $cust_svc->cust_pkg;
1248   }
1249   if ($self->pkgnum) {
1250     $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1251   }
1252   if ($cust_pkg) {
1253     $username_letter =
1254       $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1255   }
1256
1257   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1258
1259   $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#]{$usernamemin,$ulen})$/i
1260     or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1261   $recref->{username} = $1;
1262
1263   unless ( $username_uppercase ) {
1264     $recref->{username} =~ /[A-Z]/ and return gettext('illegal_username');
1265   }
1266   if ( $username_letterfirst ) {
1267     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1268   } elsif ( $username_letter ) {
1269     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1270   }
1271   if ( $username_noperiod ) {
1272     $recref->{username} =~ /\./ and return gettext('illegal_username');
1273   }
1274   if ( $username_nounderscore ) {
1275     $recref->{username} =~ /_/ and return gettext('illegal_username');
1276   }
1277   if ( $username_nodash ) {
1278     $recref->{username} =~ /\-/ and return gettext('illegal_username');
1279   }
1280   unless ( $username_ampersand ) {
1281     $recref->{username} =~ /\&/ and return gettext('illegal_username');
1282   }
1283   unless ( $username_percent ) {
1284     $recref->{username} =~ /\%/ and return gettext('illegal_username');
1285   }
1286   unless ( $username_colon ) {
1287     $recref->{username} =~ /\:/ and return gettext('illegal_username');
1288   }
1289   unless ( $username_slash ) {
1290     $recref->{username} =~ /\// and return gettext('illegal_username');
1291   }
1292   unless ( $username_equals ) {
1293     $recref->{username} =~ /\=/ and return gettext('illegal_username');
1294   }
1295   unless ( $username_pound ) {
1296     $recref->{username} =~ /\#/ and return gettext('illegal_username');
1297   }
1298
1299
1300   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1301   $recref->{popnum} = $1;
1302   return "Unknown popnum" unless
1303     ! $recref->{popnum} ||
1304     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1305
1306   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1307
1308     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1309     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1310
1311     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1312     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1313     #not all systems use gid=uid
1314     #you can set a fixed gid in part_svc
1315
1316     return "Only root can have uid 0"
1317       if $recref->{uid} == 0
1318          && $recref->{username} !~ /^(root|toor|smtp)$/;
1319
1320     unless ( $recref->{username} eq 'sync' ) {
1321       if ( grep $_ eq $recref->{shell}, @shells ) {
1322         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1323       } else {
1324         return "Illegal shell \`". $self->shell. "\'; ".
1325                "shells configuration value contains: @shells";
1326       }
1327     } else {
1328       $recref->{shell} = '/bin/sync';
1329     }
1330
1331   } else {
1332     $recref->{gid} ne '' ? 
1333       return "Can't have gid without uid" : ( $recref->{gid}='' );
1334     #$recref->{dir} ne '' ? 
1335     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1336     $recref->{shell} ne '' ? 
1337       return "Can't have shell without uid" : ( $recref->{shell}='' );
1338   }
1339
1340   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1341
1342     $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1343       or return "Illegal directory: ". $recref->{dir};
1344     $recref->{dir} = $1;
1345     return "Illegal directory"
1346       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1347     return "Illegal directory"
1348       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1349     unless ( $recref->{dir} ) {
1350       $recref->{dir} = $dir_prefix . '/';
1351       if ( $dirhash > 0 ) {
1352         for my $h ( 1 .. $dirhash ) {
1353           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1354         }
1355       } elsif ( $dirhash < 0 ) {
1356         for my $h ( reverse $dirhash .. -1 ) {
1357           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1358         }
1359       }
1360       $recref->{dir} .= $recref->{username};
1361     ;
1362     }
1363
1364   }
1365
1366   #  $error = $self->ut_textn('finger');
1367   #  return $error if $error;
1368   if ( $self->getfield('finger') eq '' ) {
1369     my $cust_pkg = $self->svcnum
1370       ? $self->cust_svc->cust_pkg
1371       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1372     if ( $cust_pkg ) {
1373       my $cust_main = $cust_pkg->cust_main;
1374       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1375     }
1376   }
1377   $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]+)$/
1378       or return "Illegal finger: ". $self->getfield('finger');
1379   $self->setfield('finger', $1);
1380
1381   for (qw( quota file_quota file_maxsize )) {
1382     $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1383     $recref->{$_} = $1;
1384   }
1385   $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1386   $recref->{file_maxnum} = $1;
1387
1388   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1389     if ( $recref->{slipip} eq '' ) {
1390       $recref->{slipip} = '';
1391     } elsif ( $recref->{slipip} eq '0e0' ) {
1392       $recref->{slipip} = '0e0';
1393     } else {
1394       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1395         or return "Illegal slipip: ". $self->slipip;
1396       $recref->{slipip} = $1;
1397     }
1398
1399   }
1400
1401   #arbitrary RADIUS stuff; allow ut_textn for now
1402   foreach ( grep /^radius_/, fields('svc_acct') ) {
1403     $self->ut_textn($_);
1404   }
1405
1406   # First, if _password is blank, generate one and set default encoding.
1407   if ( ! $recref->{_password} ) {
1408     $error = $self->set_password('');
1409   }
1410   # But if there's a _password but no encoding, assume it's plaintext and 
1411   # set it to default encoding.
1412   elsif ( ! $recref->{_password_encoding} ) {
1413     $error = $self->set_password($recref->{_password});
1414   }
1415   return $error if $error;
1416
1417   # Next, check _password to ensure compliance with the encoding.
1418   if ( $recref->{_password_encoding} eq 'ldap' ) {
1419
1420     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1421       $recref->{_password} = uc($1).$2;
1422     } else {
1423       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1424     }
1425
1426   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1427
1428     if ( $recref->{_password} =~
1429            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1430            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1431        ) {
1432
1433       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1434
1435     } else {
1436       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1437     }
1438
1439   } elsif ( $recref->{_password_encoding} eq 'plain' ) { 
1440     # Password randomization is now in set_password.
1441     # Strip whitespace characters, check length requirements, etc.
1442     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1443       $recref->{_password} = $1;
1444     } else {
1445       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1446              FS::Msgcat::_gettext('illegal_password_characters').
1447              ": ". $recref->{_password};
1448     }
1449
1450     if ( $password_noampersand ) {
1451       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1452     }
1453     if ( $password_noexclamation ) {
1454       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1455     }
1456   }
1457   else {
1458     return "invalid password encoding ('".$recref->{_password_encoding}."'";
1459   }
1460   $self->SUPER::check;
1461
1462 }
1463
1464
1465 sub _password_encryption {
1466   my $self = shift;
1467   my $encoding = lc($self->_password_encoding);
1468   return if !$encoding;
1469   return 'plain' if $encoding eq 'plain';
1470   if($encoding eq 'crypt') {
1471     my $pass = $self->_password;
1472     $pass =~ s/^\*SUSPENDED\* //;
1473     $pass =~ s/^!!?//;
1474     return 'md5' if $pass =~ /^\$1\$/;
1475     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1476     return 'des' if length($pass) == 13;
1477     return;
1478   }
1479   if($encoding eq 'ldap') {
1480     uc($self->_password) =~ /^\{([\w-]+)\}/;
1481     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1482     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1483     return 'md5' if $1 eq 'MD5';
1484     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1485
1486     return;
1487   }
1488   return;
1489 }
1490
1491 sub get_cleartext_password {
1492   my $self = shift;
1493   if($self->_password_encryption eq 'plain') {
1494     if($self->_password_encoding eq 'ldap') {
1495       $self->_password =~ /\{\w+\}(.*)$/;
1496       return $1;
1497     }
1498     else {
1499       return $self->_password;
1500     }
1501   }
1502   return;
1503 }
1504
1505  
1506 =item set_password
1507
1508 Set the cleartext password for the account.  If _password_encoding is set, the 
1509 new password will be encoded according to the existing method (including 
1510 encryption mode, if it can be determined).  Otherwise, 
1511 config('default-password-encoding') is used.
1512
1513 If no password is supplied (or a zero-length password when minimum password length 
1514 is >0), one will be generated randomly.
1515
1516 =cut
1517
1518 sub set_password {
1519   my( $self, $pass ) = ( shift, shift );
1520
1521   warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1522      if $DEBUG;
1523
1524   my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1525                 FS::Msgcat::_gettext('illegal_password_characters').
1526                 ": ". $pass;
1527
1528   my( $encoding, $encryption ) = ('', '');
1529
1530   if ( $self->_password_encoding ) {
1531     $encoding = $self->_password_encoding;
1532     # identify existing encryption method, try to use it.
1533     $encryption = $self->_password_encryption;
1534     if (!$encryption) {
1535       # use the system default
1536       undef $encoding;
1537     }
1538   }
1539
1540   if ( !$encoding ) {
1541     # set encoding to system default
1542     ($encoding, $encryption) =
1543       split(/-/, lc($conf->config('default-password-encoding')));
1544     $encoding ||= 'legacy';
1545     $self->_password_encoding($encoding);
1546   }
1547
1548   if ( $encoding eq 'legacy' ) {
1549
1550     # The legacy behavior from check():
1551     # If the password is blank, randomize it and set encoding to 'plain'.
1552     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1553       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1554       $self->_password_encoding('plain');
1555     } else {
1556       # Prefix + valid-length password
1557       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1558         $pass = $1.$3;
1559         $self->_password_encoding('plain');
1560       # Prefix + crypt string
1561       } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1562         $pass = $1.$3;
1563         $self->_password_encoding('crypt');
1564       # Various disabled crypt passwords
1565       } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1566         $self->_password_encoding('crypt');
1567       } else {
1568         return $failure;
1569       }
1570     }
1571
1572     $self->_password($pass);
1573     return;
1574
1575   }
1576
1577   return $failure
1578     if $passwordmin && length($pass) < $passwordmin
1579     or $passwordmax && length($pass) > $passwordmax;
1580
1581   if ( $encoding eq 'crypt' ) {
1582     if ($encryption eq 'md5') {
1583       $pass = unix_md5_crypt($pass);
1584     } elsif ($encryption eq 'des') {
1585       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1586     }
1587
1588   } elsif ( $encoding eq 'ldap' ) {
1589     if ($encryption eq 'md5') {
1590       $pass = md5_base64($pass);
1591     } elsif ($encryption eq 'sha1') {
1592       $pass = sha1_base64($pass);
1593     } elsif ($encryption eq 'crypt') {
1594       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1595     }
1596     # else $encryption eq 'plain', do nothing
1597     $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1598       if $encryption eq 'md5' || $encryption eq 'sha1';
1599     $pass = '{'.uc($encryption).'}'.$pass;
1600   }
1601   # else encoding eq 'plain'
1602
1603   $self->_password($pass);
1604   return;
1605 }
1606
1607 =item _check_system
1608
1609 Internal function to check the username against the list of system usernames
1610 from the I<system_usernames> configuration value.  Returns true if the username
1611 is listed on the system username list.
1612
1613 =cut
1614
1615 sub _check_system {
1616   my $self = shift;
1617   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1618                $conf->config('system_usernames')
1619         );
1620 }
1621
1622 =item _check_duplicate
1623
1624 Internal method to check for duplicates usernames, username@domain pairs and
1625 uids.
1626
1627 If the I<global_unique-username> configuration value is set to B<username> or
1628 B<username@domain>, enforces global username or username@domain uniqueness.
1629
1630 In all cases, check for duplicate uids and usernames or username@domain pairs
1631 per export and with identical I<svcpart> values.
1632
1633 =cut
1634
1635 sub _check_duplicate {
1636   my $self = shift;
1637
1638   my $global_unique = $conf->config('global_unique-username') || 'none';
1639   return '' if $global_unique eq 'disabled';
1640
1641   $self->lock_table;
1642
1643   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1644   unless ( $part_svc ) {
1645     return 'unknown svcpart '. $self->svcpart;
1646   }
1647
1648   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1649                  qsearch( 'svc_acct', { 'username' => $self->username } );
1650   return gettext('username_in_use')
1651     if $global_unique eq 'username' && @dup_user;
1652
1653   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1654                        qsearch( 'svc_acct', { 'username' => $self->username,
1655                                               'domsvc'   => $self->domsvc } );
1656   return gettext('username_in_use')
1657     if $global_unique eq 'username@domain' && @dup_userdomain;
1658
1659   my @dup_uid;
1660   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1661        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1662     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1663                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1664   } else {
1665     @dup_uid = ();
1666   }
1667
1668   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1669     my $exports = FS::part_export::export_info('svc_acct');
1670     my %conflict_user_svcpart;
1671     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1672
1673     foreach my $part_export ( $part_svc->part_export ) {
1674
1675       #this will catch to the same exact export
1676       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1677
1678       #this will catch to exports w/same exporthost+type ???
1679       #my @other_part_export = qsearch('part_export', {
1680       #  'machine'    => $part_export->machine,
1681       #  'exporttype' => $part_export->exporttype,
1682       #} );
1683       #foreach my $other_part_export ( @other_part_export ) {
1684       #  push @svcparts, map { $_->svcpart }
1685       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1686       #}
1687
1688       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1689       #silly kludge to avoid uninitialized value errors
1690       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1691                      ? $exports->{$part_export->exporttype}{'nodomain'}
1692                      : '';
1693       if ( $nodomain =~ /^Y/i ) {
1694         $conflict_user_svcpart{$_} = $part_export->exportnum
1695           foreach @svcparts;
1696       } else {
1697         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1698           foreach @svcparts;
1699       }
1700     }
1701
1702     foreach my $dup_user ( @dup_user ) {
1703       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1704       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1705         return "duplicate username ". $self->username.
1706                ": conflicts with svcnum ". $dup_user->svcnum.
1707                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1708       }
1709     }
1710
1711     foreach my $dup_userdomain ( @dup_userdomain ) {
1712       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1713       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1714         return "duplicate username\@domain ". $self->email.
1715                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1716                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1717       }
1718     }
1719
1720     foreach my $dup_uid ( @dup_uid ) {
1721       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1722       if ( exists($conflict_user_svcpart{$dup_svcpart})
1723            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1724         return "duplicate uid ". $self->uid.
1725                ": conflicts with svcnum ". $dup_uid->svcnum.
1726                " via exportnum ".
1727                ( $conflict_user_svcpart{$dup_svcpart}
1728                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1729       }
1730     }
1731
1732   }
1733
1734   return '';
1735
1736 }
1737
1738 =item radius
1739
1740 Depriciated, use radius_reply instead.
1741
1742 =cut
1743
1744 sub radius {
1745   carp "FS::svc_acct::radius depriciated, use radius_reply";
1746   $_[0]->radius_reply;
1747 }
1748
1749 =item radius_reply
1750
1751 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1752 reply attributes of this record.
1753
1754 Note that this is now the preferred method for reading RADIUS attributes - 
1755 accessing the columns directly is discouraged, as the column names are
1756 expected to change in the future.
1757
1758 =cut
1759
1760 sub radius_reply { 
1761   my $self = shift;
1762
1763   return %{ $self->{'radius_reply'} }
1764     if exists $self->{'radius_reply'};
1765
1766   my %reply =
1767     map {
1768       /^(radius_(.*))$/;
1769       my($column, $attrib) = ($1, $2);
1770       #$attrib =~ s/_/\-/g;
1771       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1772     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1773
1774   if ( $self->slipip && $self->slipip ne '0e0' ) {
1775     $reply{$radius_ip} = $self->slipip;
1776   }
1777
1778   if ( $self->seconds !~ /^$/ ) {
1779     $reply{'Session-Timeout'} = $self->seconds;
1780   }
1781
1782   if ( $conf->exists('radius-chillispot-max') ) {
1783     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1784
1785     #hmm.  just because sqlradius.pm says so?
1786     my %whatis = (
1787       'input'  => 'up',
1788       'output' => 'down',
1789       'total'  => 'total',
1790     );
1791
1792     foreach my $what (qw( input output total )) {
1793       my $is = $whatis{$what}.'bytes';
1794       if ( $self->$is() =~ /\d/ ) {
1795         my $big = new Math::BigInt $self->$is();
1796         $big = new Math::BigInt '0' if $big->is_neg();
1797         my $att = "Chillispot-Max-\u$what";
1798         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1799         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1800       }
1801     }
1802
1803   }
1804
1805   %reply;
1806 }
1807
1808 =item radius_check
1809
1810 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1811 check attributes of this record.
1812
1813 Note that this is now the preferred method for reading RADIUS attributes - 
1814 accessing the columns directly is discouraged, as the column names are
1815 expected to change in the future.
1816
1817 =cut
1818
1819 sub radius_check {
1820   my $self = shift;
1821
1822   return %{ $self->{'radius_check'} }
1823     if exists $self->{'radius_check'};
1824
1825   my %check = 
1826     map {
1827       /^(rc_(.*))$/;
1828       my($column, $attrib) = ($1, $2);
1829       #$attrib =~ s/_/\-/g;
1830       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1831     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1832
1833
1834   my($pw_attrib, $password) = $self->radius_password;
1835   $check{$pw_attrib} = $password;
1836
1837   my $cust_svc = $self->cust_svc;
1838   if ( $cust_svc ) {
1839     my $cust_pkg = $cust_svc->cust_pkg;
1840     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1841       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1842     }
1843   } else {
1844     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1845          "; can't set Expiration\n"
1846       unless $cust_svc;
1847   }
1848
1849   %check;
1850
1851 }
1852
1853 =item radius_password 
1854
1855 Returns a key/value pair containing the RADIUS attribute name and value
1856 for the password.
1857
1858 =cut
1859
1860 sub radius_password {
1861   my $self = shift;
1862
1863   my $pw_attrib;
1864   if ( $self->_password_encoding eq 'ldap' ) {
1865     $pw_attrib = 'Password-With-Header';
1866   } elsif ( $self->_password_encoding eq 'crypt' ) {
1867     $pw_attrib = 'Crypt-Password';
1868   } elsif ( $self->_password_encoding eq 'plain' ) {
1869     $pw_attrib = $radius_password;
1870   } else {
1871     $pw_attrib = length($self->_password) <= 12
1872                    ? $radius_password
1873                    : 'Crypt-Password';
1874   }
1875
1876   ($pw_attrib, $self->_password);
1877
1878 }
1879
1880 =item snapshot
1881
1882 This method instructs the object to "snapshot" or freeze RADIUS check and
1883 reply attributes to the current values.
1884
1885 =cut
1886
1887 #bah, my english is too broken this morning
1888 #Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill.  (This is used by
1889 #the FS::cust_pkg's replace method to trigger the correct export updates when
1890 #package dates change)
1891
1892 sub snapshot {
1893   my $self = shift;
1894
1895   $self->{$_} = { $self->$_() }
1896     foreach qw( radius_reply radius_check );
1897
1898 }
1899
1900 =item forget_snapshot
1901
1902 This methos instructs the object to forget any previously snapshotted
1903 RADIUS check and reply attributes.
1904
1905 =cut
1906
1907 sub forget_snapshot {
1908   my $self = shift;
1909
1910   delete $self->{$_}
1911     foreach qw( radius_reply radius_check );
1912
1913 }
1914
1915 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1916
1917 Returns the domain associated with this account.
1918
1919 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1920 history records.
1921
1922 =cut
1923
1924 sub domain {
1925   my $self = shift;
1926   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1927   my $svc_domain = $self->svc_domain(@_)
1928     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1929   $svc_domain->domain;
1930 }
1931
1932 =item cust_svc
1933
1934 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1935
1936 =cut
1937
1938 #inherited from svc_Common
1939
1940 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1941
1942 Returns an email address associated with the account.
1943
1944 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1945 history records.
1946
1947 =cut
1948
1949 sub email {
1950   my $self = shift;
1951   $self->username. '@'. $self->domain(@_);
1952 }
1953
1954 =item acct_snarf
1955
1956 Returns an array of FS::acct_snarf records associated with the account.
1957
1958 =cut
1959
1960 sub acct_snarf {
1961   my $self = shift;
1962   qsearch({
1963     'table'    => 'acct_snarf',
1964     'hashref'  => { 'svcnum' => $self->svcnum },
1965     #'order_by' => 'ORDER BY priority ASC',
1966   });
1967 }
1968
1969 =item cgp_rpop_hashref
1970
1971 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1972
1973 =cut
1974
1975 sub cgp_rpop_hashref {
1976   my $self = shift;
1977   { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1978 }
1979
1980 =item decrement_upbytes OCTETS
1981
1982 Decrements the I<upbytes> field of this record by the given amount.  If there
1983 is an error, returns the error, otherwise returns false.
1984
1985 =cut
1986
1987 sub decrement_upbytes {
1988   shift->_op_usage('-', 'upbytes', @_);
1989 }
1990
1991 =item increment_upbytes OCTETS
1992
1993 Increments the I<upbytes> field of this record by the given amount.  If there
1994 is an error, returns the error, otherwise returns false.
1995
1996 =cut
1997
1998 sub increment_upbytes {
1999   shift->_op_usage('+', 'upbytes', @_);
2000 }
2001
2002 =item decrement_downbytes OCTETS
2003
2004 Decrements the I<downbytes> field of this record by the given amount.  If there
2005 is an error, returns the error, otherwise returns false.
2006
2007 =cut
2008
2009 sub decrement_downbytes {
2010   shift->_op_usage('-', 'downbytes', @_);
2011 }
2012
2013 =item increment_downbytes OCTETS
2014
2015 Increments the I<downbytes> field of this record by the given amount.  If there
2016 is an error, returns the error, otherwise returns false.
2017
2018 =cut
2019
2020 sub increment_downbytes {
2021   shift->_op_usage('+', 'downbytes', @_);
2022 }
2023
2024 =item decrement_totalbytes OCTETS
2025
2026 Decrements the I<totalbytes> field of this record by the given amount.  If there
2027 is an error, returns the error, otherwise returns false.
2028
2029 =cut
2030
2031 sub decrement_totalbytes {
2032   shift->_op_usage('-', 'totalbytes', @_);
2033 }
2034
2035 =item increment_totalbytes OCTETS
2036
2037 Increments the I<totalbytes> field of this record by the given amount.  If there
2038 is an error, returns the error, otherwise returns false.
2039
2040 =cut
2041
2042 sub increment_totalbytes {
2043   shift->_op_usage('+', 'totalbytes', @_);
2044 }
2045
2046 =item decrement_seconds SECONDS
2047
2048 Decrements the I<seconds> field of this record by the given amount.  If there
2049 is an error, returns the error, otherwise returns false.
2050
2051 =cut
2052
2053 sub decrement_seconds {
2054   shift->_op_usage('-', 'seconds', @_);
2055 }
2056
2057 =item increment_seconds SECONDS
2058
2059 Increments the I<seconds> field of this record by the given amount.  If there
2060 is an error, returns the error, otherwise returns false.
2061
2062 =cut
2063
2064 sub increment_seconds {
2065   shift->_op_usage('+', 'seconds', @_);
2066 }
2067
2068
2069 my %op2action = (
2070   '-' => 'suspend',
2071   '+' => 'unsuspend',
2072 );
2073 my %op2condition = (
2074   '-' => sub { my($self, $column, $amount) = @_;
2075                $self->$column - $amount <= 0;
2076              },
2077   '+' => sub { my($self, $column, $amount) = @_;
2078                ($self->$column || 0) + $amount > 0;
2079              },
2080 );
2081 my %op2warncondition = (
2082   '-' => sub { my($self, $column, $amount) = @_;
2083                my $threshold = $column . '_threshold';
2084                $self->$column - $amount <= $self->$threshold + 0;
2085              },
2086   '+' => sub { my($self, $column, $amount) = @_;
2087                ($self->$column || 0) + $amount > 0;
2088              },
2089 );
2090
2091 sub _op_usage {
2092   my( $self, $op, $column, $amount ) = @_;
2093
2094   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2095        ' ('. $self->email. "): $op $amount\n"
2096     if $DEBUG;
2097
2098   return '' unless $amount;
2099
2100   local $SIG{HUP} = 'IGNORE';
2101   local $SIG{INT} = 'IGNORE';
2102   local $SIG{QUIT} = 'IGNORE';
2103   local $SIG{TERM} = 'IGNORE';
2104   local $SIG{TSTP} = 'IGNORE';
2105   local $SIG{PIPE} = 'IGNORE';
2106
2107   my $oldAutoCommit = $FS::UID::AutoCommit;
2108   local $FS::UID::AutoCommit = 0;
2109   my $dbh = dbh;
2110
2111   my $sql = "UPDATE svc_acct SET $column = ".
2112             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2113             " $op ? WHERE svcnum = ?";
2114   warn "$me $sql\n"
2115     if $DEBUG;
2116
2117   my $sth = $dbh->prepare( $sql )
2118     or die "Error preparing $sql: ". $dbh->errstr;
2119   my $rv = $sth->execute($amount, $self->svcnum);
2120   die "Error executing $sql: ". $sth->errstr
2121     unless defined($rv);
2122   die "Can't update $column for svcnum". $self->svcnum
2123     if $rv == 0;
2124
2125   #$self->snapshot; #not necessary, we retain the old values
2126   #create an object with the updated usage values
2127   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2128   #call exports
2129   my $error = $new->replace($self);
2130   if ( $error ) {
2131     $dbh->rollback if $oldAutoCommit;
2132     return "Error replacing: $error";
2133   }
2134
2135   #overlimit_action eq 'cancel' handling
2136   my $cust_pkg = $self->cust_svc->cust_pkg;
2137   if ( $cust_pkg
2138        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel' 
2139        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2140      )
2141   {
2142
2143     my $error = $cust_pkg->cancel; #XXX should have a reason
2144     if ( $error ) {
2145       $dbh->rollback if $oldAutoCommit;
2146       return "Error cancelling: $error";
2147     }
2148
2149     #nothing else is relevant if we're cancelling, so commit & return success
2150     warn "$me update successful; committing\n"
2151       if $DEBUG;
2152     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2153     return '';
2154
2155   }
2156
2157   my $action = $op2action{$op};
2158
2159   if ( &{$op2condition{$op}}($self, $column, $amount) &&
2160         ( $action eq 'suspend'   && !$self->overlimit 
2161        || $action eq 'unsuspend' &&  $self->overlimit ) 
2162      ) {
2163
2164     my $error = $self->_op_overlimit($action);
2165     if ( $error ) {
2166       $dbh->rollback if $oldAutoCommit;
2167       return $error;
2168     }
2169
2170   }
2171
2172   if ( $conf->exists("svc_acct-usage_$action")
2173        && &{$op2condition{$op}}($self, $column, $amount)    ) {
2174     #my $error = $self->$action();
2175     my $error = $self->cust_svc->cust_pkg->$action();
2176     # $error ||= $self->overlimit($action);
2177     if ( $error ) {
2178       $dbh->rollback if $oldAutoCommit;
2179       return "Error ${action}ing: $error";
2180     }
2181   }
2182
2183   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2184     my $wqueue = new FS::queue {
2185       'svcnum' => $self->svcnum,
2186       'job'    => 'FS::svc_acct::reached_threshold',
2187     };
2188
2189     my $to = '';
2190     if ($op eq '-'){
2191       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2192     }
2193
2194     # x_threshold race
2195     my $error = $wqueue->insert(
2196       'svcnum' => $self->svcnum,
2197       'op'     => $op,
2198       'column' => $column,
2199       'to'     => $to,
2200     );
2201     if ( $error ) {
2202       $dbh->rollback if $oldAutoCommit;
2203       return "Error queuing threshold activity: $error";
2204     }
2205   }
2206
2207   warn "$me update successful; committing\n"
2208     if $DEBUG;
2209   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2210   '';
2211
2212 }
2213
2214 sub _op_overlimit {
2215   my( $self, $action ) = @_;
2216
2217   local $SIG{HUP} = 'IGNORE';
2218   local $SIG{INT} = 'IGNORE';
2219   local $SIG{QUIT} = 'IGNORE';
2220   local $SIG{TERM} = 'IGNORE';
2221   local $SIG{TSTP} = 'IGNORE';
2222   local $SIG{PIPE} = 'IGNORE';
2223
2224   my $oldAutoCommit = $FS::UID::AutoCommit;
2225   local $FS::UID::AutoCommit = 0;
2226   my $dbh = dbh;
2227
2228   my $cust_pkg = $self->cust_svc->cust_pkg;
2229
2230   my $conf_overlimit =
2231     $cust_pkg
2232       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2233       : $conf->config('overlimit_groups');
2234
2235   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2236
2237     my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2238     next unless $groups;
2239
2240     my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2241
2242     my $other = new FS::svc_acct $self->hashref;
2243     $other->usergroup( $gref );
2244
2245     my($new,$old);
2246     if ($action eq 'suspend') {
2247       $new = $other;
2248       $old = $self;
2249     } else { # $action eq 'unsuspend'
2250       $new = $self;
2251       $old = $other;
2252     }
2253
2254     my $error = $part_export->export_replace($new, $old)
2255                 || $self->overlimit($action);
2256
2257     if ( $error ) {
2258       $dbh->rollback if $oldAutoCommit;
2259       return "Error replacing radius groups: $error";
2260     }
2261
2262   }
2263
2264   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2265   '';
2266
2267 }
2268
2269 sub set_usage {
2270   my( $self, $valueref, %options ) = @_;
2271
2272   warn "$me set_usage called for svcnum ". $self->svcnum.
2273        ' ('. $self->email. "): ".
2274        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2275     if $DEBUG;
2276
2277   local $SIG{HUP} = 'IGNORE';
2278   local $SIG{INT} = 'IGNORE';
2279   local $SIG{QUIT} = 'IGNORE';
2280   local $SIG{TERM} = 'IGNORE';
2281   local $SIG{TSTP} = 'IGNORE';
2282   local $SIG{PIPE} = 'IGNORE';
2283
2284   local $FS::svc_Common::noexport_hack = 1;
2285   my $oldAutoCommit = $FS::UID::AutoCommit;
2286   local $FS::UID::AutoCommit = 0;
2287   my $dbh = dbh;
2288
2289   my $reset = 0;
2290   my %handyhash = ();
2291   if ( $options{null} ) { 
2292     %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2293                    qw( seconds upbytes downbytes totalbytes )
2294                  );
2295   }
2296   foreach my $field (keys %$valueref){
2297     $reset = 1 if $valueref->{$field};
2298     $self->setfield($field, $valueref->{$field});
2299     $self->setfield( $field.'_threshold',
2300                      int($self->getfield($field)
2301                          * ( $conf->exists('svc_acct-usage_threshold') 
2302                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2303                              : 0.20
2304                            )
2305                        )
2306                      );
2307     $handyhash{$field} = $self->getfield($field);
2308     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2309   }
2310   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2311   #die $error if $error;         #services not explicity changed via the UI
2312
2313   my $sql = "UPDATE svc_acct SET " .
2314     join (',', map { "$_ =  ?" } (keys %handyhash) ).
2315     " WHERE svcnum = ". $self->svcnum;
2316
2317   warn "$me $sql\n"
2318     if $DEBUG;
2319
2320   if (scalar(keys %handyhash)) {
2321     my $sth = $dbh->prepare( $sql )
2322       or die "Error preparing $sql: ". $dbh->errstr;
2323     my $rv = $sth->execute(values %handyhash);
2324     die "Error executing $sql: ". $sth->errstr
2325       unless defined($rv);
2326     die "Can't update usage for svcnum ". $self->svcnum
2327       if $rv == 0;
2328   }
2329
2330   #$self->snapshot; #not necessary, we retain the old values
2331   #create an object with the updated usage values
2332   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2333   local($FS::Record::nowarn_identical) = 1;
2334   my $error = $new->replace($self); #call exports
2335   if ( $error ) {
2336     $dbh->rollback if $oldAutoCommit;
2337     return "Error replacing: $error";
2338   }
2339
2340   if ( $reset ) {
2341
2342     my $error = '';
2343
2344     $error = $self->_op_overlimit('unsuspend')
2345       if $self->overlimit;;
2346
2347     $error ||= $self->cust_svc->cust_pkg->unsuspend
2348       if $conf->exists("svc_acct-usage_unsuspend");
2349
2350     if ( $error ) {
2351       $dbh->rollback if $oldAutoCommit;
2352       return "Error unsuspending: $error";
2353     }
2354
2355   }
2356
2357   warn "$me update successful; committing\n"
2358     if $DEBUG;
2359   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2360   '';
2361
2362 }
2363
2364
2365 =item recharge HASHREF
2366
2367   Increments usage columns by the amount specified in HASHREF as
2368   column=>amount pairs.
2369
2370 =cut
2371
2372 sub recharge {
2373   my ($self, $vhash) = @_;
2374    
2375   if ( $DEBUG ) {
2376     warn "[$me] recharge called on $self: ". Dumper($self).
2377          "\nwith vhash: ". Dumper($vhash);
2378   }
2379
2380   my $oldAutoCommit = $FS::UID::AutoCommit;
2381   local $FS::UID::AutoCommit = 0;
2382   my $dbh = dbh;
2383   my $error = '';
2384
2385   foreach my $column (keys %$vhash){
2386     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2387   }
2388
2389   if ( $error ) {
2390     $dbh->rollback if $oldAutoCommit;
2391   }else{
2392     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2393   }
2394   return $error;
2395 }
2396
2397 =item is_rechargeable
2398
2399 Returns true if this svc_account can be "recharged" and false otherwise.
2400
2401 =cut
2402
2403 sub is_rechargable {
2404   my $self = shift;
2405   $self->seconds ne ''
2406     || $self->upbytes ne ''
2407     || $self->downbytes ne ''
2408     || $self->totalbytes ne '';
2409 }
2410
2411 =item seconds_since TIMESTAMP
2412
2413 Returns the number of seconds this account has been online since TIMESTAMP,
2414 according to the session monitor (see L<FS::Session>).
2415
2416 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2417 L<Time::Local> and L<Date::Parse> for conversion functions.
2418
2419 =cut
2420
2421 #note: POD here, implementation in FS::cust_svc
2422 sub seconds_since {
2423   my $self = shift;
2424   $self->cust_svc->seconds_since(@_);
2425 }
2426
2427 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2428
2429 Returns the numbers of seconds this account has been online between
2430 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2431 external SQL radacct table, specified via sqlradius export.  Sessions which
2432 started in the specified range but are still open are counted from session
2433 start to the end of the range (unless they are over 1 day old, in which case
2434 they are presumed missing their stop record and not counted).  Also, sessions
2435 which end in the range but started earlier are counted from the start of the
2436 range to session end.  Finally, sessions which start before the range but end
2437 after are counted for the entire range.
2438
2439 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2440 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2441 functions.
2442
2443 =cut
2444
2445 #note: POD here, implementation in FS::cust_svc
2446 sub seconds_since_sqlradacct {
2447   my $self = shift;
2448   $self->cust_svc->seconds_since_sqlradacct(@_);
2449 }
2450
2451 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2452
2453 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2454 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2455 TIMESTAMP_END (exclusive).
2456
2457 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2458 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2459 functions.
2460
2461 =cut
2462
2463 #note: POD here, implementation in FS::cust_svc
2464 sub attribute_since_sqlradacct {
2465   my $self = shift;
2466   $self->cust_svc->attribute_since_sqlradacct(@_);
2467 }
2468
2469 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2470
2471 Returns an array of hash references of this customers login history for the
2472 given time range.  (document this better)
2473
2474 =cut
2475
2476 sub get_session_history {
2477   my $self = shift;
2478   $self->cust_svc->get_session_history(@_);
2479 }
2480
2481 =item last_login_text 
2482
2483 Returns text describing the time of last login.
2484
2485 =cut
2486
2487 sub last_login_text {
2488   my $self = shift;
2489   $self->last_login ? ctime($self->last_login) : 'unknown';
2490 }
2491
2492 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2493
2494 =cut
2495
2496 sub get_cdrs {
2497   my($self, $start, $end, %opt ) = @_;
2498
2499   my $did = $self->username; #yup
2500
2501   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2502
2503   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2504
2505   #SELECT $for_update * FROM cdr
2506   #  WHERE calldate >= $start #need a conversion
2507   #    AND calldate <  $end   #ditto
2508   #    AND (    charged_party = "$did"
2509   #          OR charged_party = "$prefix$did" #if length($prefix);
2510   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2511   #               AND
2512   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2513   #             )
2514   #        )
2515   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2516
2517   my $charged_or_src;
2518   if ( length($prefix) ) {
2519     $charged_or_src =
2520       " AND (    charged_party = '$did' 
2521               OR charged_party = '$prefix$did'
2522               OR ( ( charged_party IS NULL OR charged_party = '' )
2523                    AND
2524                    ( src = '$did' OR src = '$prefix$did' )
2525                  )
2526             )
2527       ";
2528   } else {
2529     $charged_or_src = 
2530       " AND (    charged_party = '$did' 
2531               OR ( ( charged_party IS NULL OR charged_party = '' )
2532                    AND
2533                    src = '$did'
2534                  )
2535             )
2536       ";
2537
2538   }
2539
2540   qsearch(
2541     'select'    => "$for_update *",
2542     'table'     => 'cdr',
2543     'hashref'   => {
2544                      #( freesidestatus IS NULL OR freesidestatus = '' )
2545                      'freesidestatus' => '',
2546                    },
2547     'extra_sql' => $charged_or_src,
2548
2549   );
2550
2551 }
2552
2553 =item radius_groups
2554
2555 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2556
2557 =cut
2558
2559 sub radius_groups {
2560   my $self = shift;
2561   if ( $self->usergroup ) {
2562     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2563       unless ref($self->usergroup) eq 'ARRAY';
2564     #when provisioning records, export callback runs in svc_Common.pm before
2565     #radius_usergroup records can be inserted...
2566     my $groups = join(',',@{$self->usergroup});
2567     my @groups;
2568     return @groups unless length($groups);
2569     @groups = qsearch({ 'table'         => 'radius_group',
2570                            'extra_sql'     => "where groupnum in ($groups)",
2571                         });
2572     map { $_->groupname } @groups;
2573   } else {
2574      my $format = shift || '';
2575      my @groups = qsearch({ 'table'         => 'radius_usergroup',
2576                             'addl_from'     => 'left join radius_group using (groupnum)',
2577                             'select'        => 'radius_group.*',
2578                             'hashref'       => { 'svcnum' => $self->svcnum },
2579                         });
2580
2581      # this is to preserve various legacy behaviour / avoid re-writing other code
2582      return map { $_->groupnum } @groups if $format eq 'NUMBERS';
2583      return map { $_->description . " (" . $_->groupname . ")" } @groups
2584         if $format eq 'COMBINED';
2585      map { $_->groupname } @groups;
2586   }
2587 }
2588
2589 =item clone_suspended
2590
2591 Constructor used by FS::part_export::_export_suspend fallback.  Document
2592 better.
2593
2594 =cut
2595
2596 sub clone_suspended {
2597   my $self = shift;
2598   my %hash = $self->hash;
2599   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2600   new FS::svc_acct \%hash;
2601 }
2602
2603 =item clone_kludge_unsuspend 
2604
2605 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2606 better.
2607
2608 =cut
2609
2610 sub clone_kludge_unsuspend {
2611   my $self = shift;
2612   my %hash = $self->hash;
2613   $hash{_password} = '';
2614   new FS::svc_acct \%hash;
2615 }
2616
2617 =item check_password 
2618
2619 Checks the supplied password against the (possibly encrypted) password in the
2620 database.  Returns true for a successful authentication, false for no match.
2621
2622 Currently supported encryptions are: classic DES crypt() and MD5
2623
2624 =cut
2625
2626 sub check_password {
2627   my($self, $check_password) = @_;
2628
2629   #remove old-style SUSPENDED kludge, they should be allowed to login to
2630   #self-service and pay up
2631   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2632
2633   if ( $self->_password_encoding eq 'ldap' ) {
2634
2635     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2636     return $auth->match($check_password);
2637
2638   } elsif ( $self->_password_encoding eq 'crypt' ) {
2639
2640     my $auth = from_crypt Authen::Passphrase $self->_password;
2641     return $auth->match($check_password);
2642
2643   } elsif ( $self->_password_encoding eq 'plain' ) {
2644
2645     return $check_password eq $password;
2646
2647   } else {
2648
2649     #XXX this could be replaced with Authen::Passphrase stuff
2650
2651     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2652       return 0;
2653     } elsif ( length($password) < 13 ) { #plaintext
2654       $check_password eq $password;
2655     } elsif ( length($password) == 13 ) { #traditional DES crypt
2656       crypt($check_password, $password) eq $password;
2657     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2658       unix_md5_crypt($check_password, $password) eq $password;
2659     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2660       warn "Can't check password: Blowfish encryption not yet supported, ".
2661            "svcnum ".  $self->svcnum. "\n";
2662       0;
2663     } else {
2664       warn "Can't check password: Unrecognized encryption for svcnum ".
2665            $self->svcnum. "\n";
2666       0;
2667     }
2668
2669   }
2670
2671 }
2672
2673 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2674
2675 Returns an encrypted password, either by passing through an encrypted password
2676 in the database or by encrypting a plaintext password from the database.
2677
2678 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2679 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2680 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2681 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2682 encryption type is only used if the password is not already encrypted in the
2683 database.
2684
2685 =cut
2686
2687 sub crypt_password {
2688   my $self = shift;
2689
2690   if ( $self->_password_encoding eq 'ldap' ) {
2691
2692     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2693       my $plain = $2;
2694
2695       #XXX this could be replaced with Authen::Passphrase stuff
2696
2697       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2698       if ( $encryption eq 'crypt' ) {
2699         return crypt(
2700           $self->_password,
2701           $saltset[int(rand(64))].$saltset[int(rand(64))]
2702         );
2703       } elsif ( $encryption eq 'md5' ) {
2704         return unix_md5_crypt( $self->_password );
2705       } elsif ( $encryption eq 'blowfish' ) {
2706         croak "unknown encryption method $encryption";
2707       } else {
2708         croak "unknown encryption method $encryption";
2709       }
2710
2711     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2712       return $1;
2713     }
2714
2715   } elsif ( $self->_password_encoding eq 'crypt' ) {
2716
2717     return $self->_password;
2718
2719   } elsif ( $self->_password_encoding eq 'plain' ) {
2720
2721     #XXX this could be replaced with Authen::Passphrase stuff
2722
2723     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2724     if ( $encryption eq 'crypt' ) {
2725       return crypt(
2726         $self->_password,
2727         $saltset[int(rand(64))].$saltset[int(rand(64))]
2728       );
2729     } elsif ( $encryption eq 'md5' ) {
2730       return unix_md5_crypt( $self->_password );
2731     } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2732       my $pass = sha1_base64( $self->_password );
2733       $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2734       return $pass;
2735     } elsif ( $encryption eq 'blowfish' ) {
2736       croak "unknown encryption method $encryption";
2737     } else {
2738       croak "unknown encryption method $encryption";
2739     }
2740
2741   } else {
2742
2743     if ( length($self->_password) == 13
2744          || $self->_password =~ /^\$(1|2a?)\$/
2745          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2746        )
2747     {
2748       $self->_password;
2749     } else {
2750     
2751       #XXX this could be replaced with Authen::Passphrase stuff
2752
2753       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2754       if ( $encryption eq 'crypt' ) {
2755         return crypt(
2756           $self->_password,
2757           $saltset[int(rand(64))].$saltset[int(rand(64))]
2758         );
2759       } elsif ( $encryption eq 'md5' ) {
2760         return unix_md5_crypt( $self->_password );
2761       } elsif ( $encryption eq 'blowfish' ) {
2762         croak "unknown encryption method $encryption";
2763       } else {
2764         croak "unknown encryption method $encryption";
2765       }
2766
2767     }
2768
2769   }
2770
2771 }
2772
2773 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2774
2775 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2776 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2777 "{MD5}5426824942db4253f87a1009fd5d2d4".
2778
2779 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2780 to work the same as the B</crypt_password> method.
2781
2782 =cut
2783
2784 sub ldap_password {
2785   my $self = shift;
2786   #eventually should check a "password-encoding" field
2787
2788   if ( $self->_password_encoding eq 'ldap' ) {
2789
2790     return $self->_password;
2791
2792   } elsif ( $self->_password_encoding eq 'crypt' ) {
2793
2794     if ( length($self->_password) == 13 ) { #crypt
2795       return '{CRYPT}'. $self->_password;
2796     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2797       return '{MD5}'. $1;
2798     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2799     #  die "Blowfish encryption not supported in this context, svcnum ".
2800     #      $self->svcnum. "\n";
2801     } else {
2802       warn "encryption method not (yet?) supported in LDAP context";
2803       return '{CRYPT}*'; #unsupported, should not auth
2804     }
2805
2806   } elsif ( $self->_password_encoding eq 'plain' ) {
2807
2808     return '{PLAIN}'. $self->_password;
2809
2810     #return '{CLEARTEXT}'. $self->_password; #?
2811
2812   } else {
2813
2814     if ( length($self->_password) == 13 ) { #crypt
2815       return '{CRYPT}'. $self->_password;
2816     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2817       return '{MD5}'. $1;
2818     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2819       warn "Blowfish encryption not supported in this context, svcnum ".
2820           $self->svcnum. "\n";
2821       return '{CRYPT}*';
2822
2823     #are these two necessary anymore?
2824     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2825       return '{SSHA}'. $1;
2826     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2827       return '{NS-MTA-MD5}'. $1;
2828
2829     } else { #plaintext
2830       return '{PLAIN}'. $self->_password;
2831
2832       #return '{CLEARTEXT}'. $self->_password; #?
2833       
2834       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2835       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2836       #if ( $encryption eq 'crypt' ) {
2837       #  return '{CRYPT}'. crypt(
2838       #    $self->_password,
2839       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2840       #  );
2841       #} elsif ( $encryption eq 'md5' ) {
2842       #  unix_md5_crypt( $self->_password );
2843       #} elsif ( $encryption eq 'blowfish' ) {
2844       #  croak "unknown encryption method $encryption";
2845       #} else {
2846       #  croak "unknown encryption method $encryption";
2847       #}
2848     }
2849
2850   }
2851
2852 }
2853
2854 =item domain_slash_username
2855
2856 Returns $domain/$username/
2857
2858 =cut
2859
2860 sub domain_slash_username {
2861   my $self = shift;
2862   $self->domain. '/'. $self->username. '/';
2863 }
2864
2865 =item virtual_maildir
2866
2867 Returns $domain/maildirs/$username/
2868
2869 =cut
2870
2871 sub virtual_maildir {
2872   my $self = shift;
2873   $self->domain. '/maildirs/'. $self->username. '/';
2874 }
2875
2876 =back
2877
2878 =head1 CLASS METHODS
2879
2880 =over 4
2881
2882 =item search HASHREF
2883
2884 Class method which returns a qsearch hash expression to search for parameters
2885 specified in HASHREF.  Valid parameters are
2886
2887 =over 4
2888
2889 =item domain
2890
2891 =item domsvc
2892
2893 =item unlinked
2894
2895 =item agentnum
2896
2897 =item pkgpart
2898
2899 Arrayref of pkgparts
2900
2901 =item pkgpart
2902
2903 =item where
2904
2905 Arrayref of additional WHERE clauses, will be ANDed together.
2906
2907 =item order_by
2908
2909 =item cust_fields
2910
2911 =back
2912
2913 =cut
2914
2915 sub search {
2916   my ($class, $params) = @_;
2917
2918   my @where = ();
2919
2920   # domain
2921   if ( $params->{'domain'} ) { 
2922     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2923     #preserve previous behavior & bubble up an error if $svc_domain not found?
2924     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2925   }
2926
2927   # domsvc
2928   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) { 
2929     push @where, "domsvc = $1";
2930   }
2931
2932   #unlinked
2933   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2934
2935   #agentnum
2936   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2937     push @where, "agentnum = $1";
2938   }
2939
2940   #custnum
2941   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2942     push @where, "custnum = $1";
2943   }
2944
2945   #pkgpart
2946   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2947     #XXX untaint or sql quote
2948     push @where,
2949       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2950   }
2951
2952   # popnum
2953   if ( $params->{'popnum'} =~ /^(\d+)$/ ) { 
2954     push @where, "popnum = $1";
2955   }
2956
2957   # svcpart
2958   if ( $params->{'svcpart'} =~ /^(\d+)$/ ) { 
2959     push @where, "svcpart = $1";
2960   }
2961
2962
2963   # here is the agent virtualization
2964   #if ($params->{CurrentUser}) {
2965   #  my $access_user =
2966   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2967   #
2968   #  if ($access_user) {
2969   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2970   #  }else{
2971   #    push @where, "1=0";
2972   #  }
2973   #} else {
2974     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2975                    'table'      => 'cust_main',
2976                    'null_right' => 'View/link unlinked services',
2977                  );
2978   #}
2979
2980   push @where, @{ $params->{'where'} } if $params->{'where'};
2981
2982   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2983
2984   my $addl_from = ' LEFT JOIN cust_svc  USING ( svcnum  ) '.
2985                   ' LEFT JOIN part_svc  USING ( svcpart ) '.
2986                   ' LEFT JOIN cust_pkg  USING ( pkgnum  ) '.
2987                   ' LEFT JOIN cust_main USING ( custnum ) ';
2988
2989   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2990   #if ( keys %svc_acct ) {
2991   #  $count_query .= ' WHERE '.
2992   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2993   #                                      keys %svc_acct
2994   #                        );
2995   #}
2996
2997   my $sql_query = {
2998     'table'       => 'svc_acct',
2999     'hashref'     => {}, # \%svc_acct,
3000     'select'      => join(', ',
3001                        'svc_acct.*',
3002                        'part_svc.svc',
3003                        'cust_main.custnum',
3004                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
3005                      ),
3006     'addl_from'   => $addl_from,
3007     'extra_sql'   => $extra_sql,
3008     'order_by'    => $params->{'order_by'},
3009     'count_query' => $count_query,
3010   };
3011
3012 }
3013
3014 =back
3015
3016 =head1 SUBROUTINES
3017
3018 =over 4
3019
3020 =item send_email
3021
3022 This is the FS::svc_acct job-queue-able version.  It still uses
3023 FS::Misc::send_email under-the-hood.
3024
3025 =cut
3026
3027 sub send_email {
3028   my %opt = @_;
3029
3030   eval "use FS::Misc qw(send_email)";
3031   die $@ if $@;
3032
3033   $opt{mimetype} ||= 'text/plain';
3034   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3035
3036   my $error = send_email(
3037     'from'         => $opt{from},
3038     'to'           => $opt{to},
3039     'subject'      => $opt{subject},
3040     'content-type' => $opt{mimetype},
3041     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
3042   );
3043   die $error if $error;
3044 }
3045
3046 =item check_and_rebuild_fuzzyfiles
3047
3048 =cut
3049
3050 sub check_and_rebuild_fuzzyfiles {
3051   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3052   -e "$dir/svc_acct.username"
3053     or &rebuild_fuzzyfiles;
3054 }
3055
3056 =item rebuild_fuzzyfiles
3057
3058 =cut
3059
3060 sub rebuild_fuzzyfiles {
3061
3062   use Fcntl qw(:flock);
3063
3064   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3065
3066   #username
3067
3068   open(USERNAMELOCK,">>$dir/svc_acct.username")
3069     or die "can't open $dir/svc_acct.username: $!";
3070   flock(USERNAMELOCK,LOCK_EX)
3071     or die "can't lock $dir/svc_acct.username: $!";
3072
3073   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
3074
3075   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
3076     or die "can't open $dir/svc_acct.username.tmp: $!";
3077   print USERNAMECACHE join("\n", @all_username), "\n";
3078   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
3079
3080   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
3081   close USERNAMELOCK;
3082
3083 }
3084
3085 =item all_username
3086
3087 =cut
3088
3089 sub all_username {
3090   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3091   open(USERNAMECACHE,"<$dir/svc_acct.username")
3092     or die "can't open $dir/svc_acct.username: $!";
3093   my @array = map { chomp; $_; } <USERNAMECACHE>;
3094   close USERNAMECACHE;
3095   \@array;
3096 }
3097
3098 =item append_fuzzyfiles USERNAME
3099
3100 =cut
3101
3102 sub append_fuzzyfiles {
3103   my $username = shift;
3104
3105   &check_and_rebuild_fuzzyfiles;
3106
3107   use Fcntl qw(:flock);
3108
3109   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3110
3111   open(USERNAME,">>$dir/svc_acct.username")
3112     or die "can't open $dir/svc_acct.username: $!";
3113   flock(USERNAME,LOCK_EX)
3114     or die "can't lock $dir/svc_acct.username: $!";
3115
3116   print USERNAME "$username\n";
3117
3118   flock(USERNAME,LOCK_UN)
3119     or die "can't unlock $dir/svc_acct.username: $!";
3120   close USERNAME;
3121
3122   1;
3123 }
3124
3125
3126 =item reached_threshold
3127
3128 Performs some activities when svc_acct thresholds (such as number of seconds
3129 remaining) are reached.  
3130
3131 =cut
3132
3133 sub reached_threshold {
3134   my %opt = @_;
3135
3136   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3137   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3138
3139   if ( $opt{'op'} eq '+' ){
3140     $svc_acct->setfield( $opt{'column'}.'_threshold',
3141                          int($svc_acct->getfield($opt{'column'})
3142                              * ( $conf->exists('svc_acct-usage_threshold') 
3143                                  ? $conf->config('svc_acct-usage_threshold')/100
3144                                  : 0.80
3145                                )
3146                          )
3147                        );
3148     my $error = $svc_acct->replace;
3149     die $error if $error;
3150   }elsif ( $opt{'op'} eq '-' ){
3151     
3152     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3153     return '' if ($threshold eq '' );
3154
3155     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3156     my $error = $svc_acct->replace;
3157     die $error if $error; # email next time, i guess
3158
3159     if ( $warning_template ) {
3160       eval "use FS::Misc qw(send_email)";
3161       die $@ if $@;
3162
3163       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
3164       my $cust_main = $cust_pkg->cust_main;
3165
3166       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } 
3167                                $cust_main->invoicing_list,
3168                                ($opt{'to'} ? $opt{'to'} : ())
3169                    );
3170
3171       my $mimetype = $warning_mimetype;
3172       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3173
3174       my $body       =  $warning_template->fill_in( HASH => {
3175                         'custnum'   => $cust_main->custnum,
3176                         'username'  => $svc_acct->username,
3177                         'password'  => $svc_acct->_password,
3178                         'first'     => $cust_main->first,
3179                         'last'      => $cust_main->getfield('last'),
3180                         'pkg'       => $cust_pkg->part_pkg->pkg,
3181                         'column'    => $opt{'column'},
3182                         'amount'    => $opt{'column'} =~/bytes/
3183                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3184                                        : $svc_acct->getfield($opt{'column'}),
3185                         'threshold' => $opt{'column'} =~/bytes/
3186                                        ? FS::UI::bytecount::display_bytecount($threshold)
3187                                        : $threshold,
3188                       } );
3189
3190
3191       my $error = send_email(
3192         'from'         => $warning_from,
3193         'to'           => $to,
3194         'subject'      => $warning_subject,
3195         'content-type' => $mimetype,
3196         'body'         => [ map "$_\n", split("\n", $body) ],
3197       );
3198       die $error if $error;
3199     }
3200   }else{
3201     die "unknown op: " . $opt{'op'};
3202   }
3203 }
3204
3205 =back
3206
3207 =head1 BUGS
3208
3209 The $recref stuff in sub check should be cleaned up.
3210
3211 The suspend, unsuspend and cancel methods update the database, but not the
3212 current object.  This is probably a bug as it's unexpected and
3213 counterintuitive.
3214
3215 insertion of RADIUS group stuff in insert could be done with child_objects now
3216 (would probably clean up export of them too)
3217
3218 _op_usage and set_usage bypass the history... maybe they shouldn't
3219
3220 =head1 SEE ALSO
3221
3222 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3223 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3224 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3225 L<freeside-queued>), L<FS::svc_acct_pop>,
3226 schema.html from the base documentation.
3227
3228 =cut
3229
3230 1;