4 use base qw( FS::svc_Domain_Mixin FS::svc_CGP_Mixin FS::svc_CGPRule_Mixin
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
17 $radius_password $radius_ip
20 use Scalar::Util qw( blessed );
25 use Crypt::PasswdMD5 1.2;
26 use Digest::SHA1 'sha1_base64';
27 use Digest::MD5 'md5_base64';
30 use Authen::Passphrase;
31 use FS::UID qw( datasrc driver_name );
33 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
34 use FS::Msgcat qw(gettext);
35 use FS::UI::bytecount;
40 use FS::cust_main_invoice;
45 use FS::radius_usergroup;
55 $me = '[FS::svc_acct]';
57 #ask FS::UID to run this stuff for us later
58 FS::UID->install_callback( sub {
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;
66 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
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 (
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');
95 $warning_template = '';
97 $warning_subject = '';
98 $warning_mimetype = '';
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');
108 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
109 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '.', ',' );
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'},
125 FS::svc_acct - Object methods for svc_acct records
131 $record = new FS::svc_acct \%hash;
132 $record = new FS::svc_acct { 'column' => 'value' };
134 $error = $record->insert;
136 $error = $new_record->replace($old_record);
138 $error = $record->delete;
140 $error = $record->check;
142 $error = $record->suspend;
144 $error = $record->unsuspend;
146 $error = $record->cancel;
148 %hash = $record->radius;
150 %hash = $record->radius_reply;
152 %hash = $record->radius_check;
154 $domain = $record->domain;
156 $svc_domain = $record->svc_domain;
158 $email = $record->email;
160 $seconds_since = $record->seconds_since($timestamp);
164 An FS::svc_acct object represents an account. FS::svc_acct inherits from
165 FS::svc_Common. The following fields are currently supported:
171 Primary key (assigned automatcially for new accounts)
179 =item _password_encoding
181 plain, crypt, ldap (or empty for autodetection)
189 Point of presence (see L<FS::svc_acct_pop>)
201 set automatically if blank (and uid is not)
221 svcnum from svc_domain
225 Optional svcnum from svc_pbx
227 =item radius_I<Radius_Attribute>
229 I<Radius-Attribute> (reply)
231 =item rc_I<Radius_Attribute>
233 I<Radius-Attribute> (check)
243 Creates a new account. To add the account to the database, see L<"insert">.
250 'longname_plural' => 'Access accounts and mailboxes',
251 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
252 'display_weight' => 10,
253 'cancel_weight' => 50,
255 'dir' => 'Home directory',
258 def_info => 'set to fixed and blank for no UIDs',
261 'slipip' => 'IP address',
262 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
264 label => 'Access number',
266 select_table => 'svc_acct_pop',
267 select_key => 'popnum',
268 select_label => 'city',
274 disable_default => 1,
278 'password_selfchange' => { label => 'Password modification',
281 'password_recover' => { label => 'Password recovery',
285 label => 'Quota', #Mail storage limit
287 disable_inventory => 1,
291 label => 'File storage limit',
293 disable_inventory => 1,
297 label => 'Number of files limit',
299 disable_inventory => 1,
303 label => 'File size limit',
305 disable_inventory => 1,
308 '_password' => 'Password',
311 def_info => 'when blank, defaults to UID',
316 def_info => 'set to blank for no shell tracking',
318 #select_list => [ $conf->config('shells') ],
319 select_list => [ $conf ? $conf->config('shells') : () ],
320 disable_inventory => 1,
323 'finger' => 'Real name', # (GECOS)',
327 select_table => 'svc_domain',
328 select_key => 'svcnum',
329 select_label => 'domain',
330 disable_inventory => 1,
332 'pbxsvc' => { label => 'PBX',
333 type => 'select-svc_pbx.html',
334 disable_inventory => 1,
335 disable_select => 1, #UI wonky, pry works otherwise
338 label => 'RADIUS groups',
339 type => 'select-radius_group.html',
340 disable_inventory => 1,
343 'seconds' => { label => 'Seconds',
344 label_sort => 'with Time Remaining',
346 disable_inventory => 1,
348 disable_part_svc_column => 1,
350 'upbytes' => { label => 'Upload',
352 disable_inventory => 1,
354 'format' => \&FS::UI::bytecount::display_bytecount,
355 'parse' => \&FS::UI::bytecount::parse_bytecount,
356 disable_part_svc_column => 1,
358 'downbytes' => { label => 'Download',
360 disable_inventory => 1,
362 'format' => \&FS::UI::bytecount::display_bytecount,
363 'parse' => \&FS::UI::bytecount::parse_bytecount,
364 disable_part_svc_column => 1,
366 'totalbytes'=> { label => 'Total up and download',
368 disable_inventory => 1,
370 'format' => \&FS::UI::bytecount::display_bytecount,
371 'parse' => \&FS::UI::bytecount::parse_bytecount,
372 disable_part_svc_column => 1,
374 'seconds_threshold' => { label => 'Seconds threshold',
376 disable_inventory => 1,
378 disable_part_svc_column => 1,
380 'upbytes_threshold' => { label => 'Upload threshold',
382 disable_inventory => 1,
384 'format' => \&FS::UI::bytecount::display_bytecount,
385 'parse' => \&FS::UI::bytecount::parse_bytecount,
386 disable_part_svc_column => 1,
388 'downbytes_threshold' => { label => 'Download threshold',
390 disable_inventory => 1,
392 'format' => \&FS::UI::bytecount::display_bytecount,
393 'parse' => \&FS::UI::bytecount::parse_bytecount,
394 disable_part_svc_column => 1,
396 'totalbytes_threshold'=> { label => 'Total up and download threshold',
398 disable_inventory => 1,
400 'format' => \&FS::UI::bytecount::display_bytecount,
401 'parse' => \&FS::UI::bytecount::parse_bytecount,
402 disable_part_svc_column => 1,
405 label => 'Last login',
409 label => 'Last logout',
414 label => 'Communigate aliases',
416 disable_inventory => 1,
421 label => 'Communigate account type',
423 select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
424 disable_inventory => 1,
427 'cgp_accessmodes' => {
428 label => 'Communigate enabled services',
429 type => 'communigate_pro-accessmodes',
430 disable_inventory => 1,
433 'cgp_rulesallowed' => {
434 label => 'Allowed mail rules',
436 select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
437 disable_inventory => 1,
440 'cgp_rpopallowed' => { label => 'RPOP modifications',
443 'cgp_mailtoall' => { label => 'Accepts mail to "all"',
446 'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
449 'cgp_archiveafter' => {
450 label => 'Archive messages after',
453 -2 => 'default(730 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',
467 disable_inventory => 1,
473 'cgp_deletemode' => {
474 label => 'Communigate message delete method',
476 select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
477 disable_inventory => 1,
480 'cgp_emptytrash' => {
481 label => 'Communigate on logout remove trash',
483 select_list => __PACKAGE__->cgp_emptytrash_values,
484 disable_inventory => 1,
488 label => 'Communigate language',
490 select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
491 disable_inventory => 1,
495 label => 'Communigate time zone',
497 select_list => __PACKAGE__->cgp_timezone_values,
498 disable_inventory => 1,
502 label => 'Communigate layout',
504 select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
505 disable_inventory => 1,
508 'cgp_prontoskinname' => {
509 label => 'Communigate Pronto style',
511 select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ],
512 disable_inventory => 1,
515 'cgp_sendmdnmode' => {
516 label => 'Communigate send read receipts',
518 select_list => [ '', 'Never', 'Manually', 'Automatically' ],
519 disable_inventory => 1,
530 sub table { 'svc_acct'; }
532 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
536 #false laziness with edit/svc_acct.cgi
538 my( $self, $groups ) = @_;
539 if ( ref($groups) eq 'ARRAY' ) {
541 } elsif ( length($groups) ) {
542 [ split(/\s*,\s*/, $groups) ];
551 shift->_lastlog('in', @_);
555 shift->_lastlog('out', @_);
559 my( $self, $op, $time ) = @_;
561 if ( defined($time) ) {
562 warn "$me last_log$op called on svcnum ". $self->svcnum.
563 ' ('. $self->email. "): $time\n"
568 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
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
577 die "Can't update last_log$op for svcnum". $self->svcnum
580 $self->{'Hash'}->{"last_log$op"} = $time;
582 $self->getfield("last_log$op");
586 =item search_sql STRING
588 Class method which returns an SQL fragment to search for the given string.
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 } );
599 "svc_acct.username = $q_username AND ( ".
600 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
605 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
607 $class->search_sql_field('slipip', $string ).
609 $class->search_sql_field('username', $string ).
612 $class->search_sql_field('username', $string);
616 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
618 Returns the "username@domain" string for this account.
620 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
630 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
632 Returns a longer string label for this acccount ("Real Name <username@domain>"
633 if available, or "username@domain").
635 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
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;
650 =item insert [ , OPTION => VALUE ... ]
652 Adds this account to the database. If there is an error, returns the error,
653 otherwise returns false.
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.
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>.
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' ]>
669 Currently available options are: I<depend_jobnum>
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)).
675 (TODOC: L<FS::queue> and L<freeside-queued>)
677 (TODOC: new exports!)
686 warn "[$me] insert called on $self: ". Dumper($self).
687 "\nwith options: ". Dumper(%options);
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';
697 my $oldAutoCommit = $FS::UID::AutoCommit;
698 local $FS::UID::AutoCommit = 0;
702 my $error = $self->SUPER::insert(
703 'jobnums' => \@jobnums,
704 'child_objects' => $self->child_objects,
708 $dbh->rollback if $oldAutoCommit;
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,
718 my $error = $radius_usergroup->insert;
720 $dbh->rollback if $oldAutoCommit;
726 unless ( $skip_fuzzyfiles ) {
727 $error = $self->queue_fuzzyfiles_update;
729 $dbh->rollback if $oldAutoCommit;
730 return "updating fuzzy search cache: $error";
734 my $cust_pkg = $self->cust_svc->cust_pkg;
737 my $cust_main = $cust_pkg->cust_main;
738 my $agentnum = $cust_main->agentnum;
740 if ( $conf->exists('emailinvoiceautoalways')
741 || $conf->exists('emailinvoiceauto')
742 && ! $cust_main->invoicing_list_emailonly
744 my @invoicing_list = $cust_main->invoicing_list;
745 push @invoicing_list, $self->email;
746 $cust_main->invoicing_list(\@invoicing_list);
750 my @welcome_exclude_svcparts = $conf->config('svc_acct_welcome_exclude');
751 unless ( grep { $_ eq $self->svcpart } @welcome_exclude_svcparts ) {
753 my $msgnum = $conf->config('welcome_msgnum', $agentnum);
755 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
756 $error = $msg_template->send('cust_main' => $cust_main,
760 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
761 = ('','','','','','');
763 if ( $conf->exists('welcome_email', $agentnum) ) {
764 $welcome_template = new Text::Template (
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)
772 $welcome_subject_template = new Text::Template (
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)
779 if ( $welcome_template ) {
780 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
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,
791 my $wqueue = new FS::queue {
792 'svcnum' => $self->svcnum,
793 'job' => 'FS::svc_acct::send_email'
795 my $error = $wqueue->insert(
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, ),
803 $dbh->rollback if $oldAutoCommit;
804 return "error queuing welcome email: $error";
807 if ( $options{'depend_jobnum'} ) {
808 warn "$me depend_jobnum found; adding to welcome email dependancies"
810 if ( ref($options{'depend_jobnum'}) ) {
811 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
812 "to welcome email dependancies"
814 push @jobnums, @{ $options{'depend_jobnum'} };
816 warn "$me adding job $options{'depend_jobnum'} ".
817 "to welcome email dependancies"
819 push @jobnums, $options{'depend_jobnum'};
823 foreach my $jobnum ( @jobnums ) {
824 my $error = $wqueue->depend_insert($jobnum);
826 $dbh->rollback if $oldAutoCommit;
827 return "error queuing welcome email job dependancy: $error";
833 } # if $welcome_template
838 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
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 {
847 return '' unless $self->pkgnum;
849 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
850 return '' unless $cust_pkg && $cust_pkg->last_bill;
852 my $part_pkg = $cust_pkg->part_pkg;
853 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
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
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');
872 Deletes this account from the database. If there is an error, returns the
873 error, otherwise returns false.
875 The corresponding FS::cust_svc record will be deleted as well.
877 (TODOC: new exports!)
884 return "can't delete system account" if $self->_check_system;
886 return "Can't delete an account which is a (svc_forward) source!"
887 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
889 return "Can't delete an account which is a (svc_forward) destination!"
890 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
892 return "Can't delete an account with (svc_www) web service!"
893 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
895 # what about records in session ? (they should refer to history table)
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';
904 my $oldAutoCommit = $FS::UID::AutoCommit;
905 local $FS::UID::AutoCommit = 0;
908 foreach my $cust_main_invoice (
909 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
911 unless ( defined($cust_main_invoice) ) {
912 warn "WARNING: something's wrong with qsearch";
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);
920 $dbh->rollback if $oldAutoCommit;
925 foreach my $svc_domain (
926 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
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);
933 $dbh->rollback if $oldAutoCommit;
938 my $error = $self->SUPER::delete;
940 $dbh->rollback if $oldAutoCommit;
944 foreach my $radius_usergroup (
945 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
947 my $error = $radius_usergroup->delete;
949 $dbh->rollback if $oldAutoCommit;
954 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
958 =item replace OLD_RECORD
960 Replaces OLD_RECORD with this one in the database. If there is an error,
961 returns the error, otherwise returns false.
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>.
972 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
976 warn "$me replacing $old with $new\n" if $DEBUG;
980 return "can't modify system account" if $old->_check_system;
983 #no warnings 'numeric'; #alas, a 5.006-ism
986 foreach my $xid (qw( uid gid )) {
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'
996 #change homdir when we change username
997 $new->setfield('dir', '') if $old->username ne $new->username;
999 local $SIG{HUP} = 'IGNORE';
1000 local $SIG{INT} = 'IGNORE';
1001 local $SIG{QUIT} = 'IGNORE';
1002 local $SIG{TERM} = 'IGNORE';
1003 local $SIG{TSTP} = 'IGNORE';
1004 local $SIG{PIPE} = 'IGNORE';
1006 my $oldAutoCommit = $FS::UID::AutoCommit;
1007 local $FS::UID::AutoCommit = 0;
1010 # redundant, but so $new->usergroup gets set
1011 $error = $new->check;
1012 return $error if $error;
1014 $old->usergroup( [ $old->radius_groups('NUMBERS') ] );
1016 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
1017 warn $new->email. " new groups: ". join(' ',@{$new->usergroup}). "\n";
1019 if ( $new->usergroup ) {
1020 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
1021 my @newgroups = @{$new->usergroup};
1022 foreach my $oldgroup ( @{$old->usergroup} ) {
1023 if ( grep { $oldgroup eq $_ } @newgroups ) {
1024 @newgroups = grep { $oldgroup ne $_ } @newgroups;
1027 my $radius_usergroup = qsearchs('radius_usergroup', {
1028 svcnum => $old->svcnum,
1029 groupnum => $oldgroup,
1031 my $error = $radius_usergroup->delete;
1033 $dbh->rollback if $oldAutoCommit;
1034 return "error deleting radius_usergroup $oldgroup: $error";
1038 foreach my $newgroup ( @newgroups ) {
1039 my $radius_usergroup = new FS::radius_usergroup ( {
1040 svcnum => $new->svcnum,
1041 groupnum => $newgroup,
1043 my $error = $radius_usergroup->insert;
1045 $dbh->rollback if $oldAutoCommit;
1046 return "error adding radius_usergroup $newgroup: $error";
1052 $error = $new->SUPER::replace($old, @_);
1054 $dbh->rollback if $oldAutoCommit;
1055 return $error if $error;
1058 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1059 $error = $new->queue_fuzzyfiles_update;
1061 $dbh->rollback if $oldAutoCommit;
1062 return "updating fuzzy search cache: $error";
1066 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1070 =item queue_fuzzyfiles_update
1072 Used by insert & replace to update the fuzzy search cache
1076 sub queue_fuzzyfiles_update {
1079 local $SIG{HUP} = 'IGNORE';
1080 local $SIG{INT} = 'IGNORE';
1081 local $SIG{QUIT} = 'IGNORE';
1082 local $SIG{TERM} = 'IGNORE';
1083 local $SIG{TSTP} = 'IGNORE';
1084 local $SIG{PIPE} = 'IGNORE';
1086 my $oldAutoCommit = $FS::UID::AutoCommit;
1087 local $FS::UID::AutoCommit = 0;
1090 my $queue = new FS::queue {
1091 'svcnum' => $self->svcnum,
1092 'job' => 'FS::svc_acct::append_fuzzyfiles'
1094 my $error = $queue->insert($self->username);
1096 $dbh->rollback if $oldAutoCommit;
1097 return "queueing job (transaction rolled back): $error";
1100 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1108 Suspends this account by calling export-specific suspend hooks. If there is
1109 an error, returns the error, otherwise returns false.
1111 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1117 return "can't suspend system account" if $self->_check_system;
1118 $self->SUPER::suspend(@_);
1123 Unsuspends this account by by calling export-specific suspend hooks. If there
1124 is an error, returns the error, otherwise returns false.
1126 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1132 my %hash = $self->hash;
1133 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1134 $hash{_password} = $1;
1135 my $new = new FS::svc_acct ( \%hash );
1136 my $error = $new->replace($self);
1137 return $error if $error;
1140 $self->SUPER::unsuspend(@_);
1145 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1147 If the B<auto_unset_catchall> configuration option is set, this method will
1148 automatically remove any references to the canceled service in the catchall
1149 field of svc_domain. This allows packages that contain both a svc_domain and
1150 its catchall svc_acct to be canceled in one step.
1155 # Only one thing to do at this level
1157 foreach my $svc_domain (
1158 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1159 if($conf->exists('auto_unset_catchall')) {
1160 my %hash = $svc_domain->hash;
1161 $hash{catchall} = '';
1162 my $new = new FS::svc_domain ( \%hash );
1163 my $error = $new->replace($svc_domain);
1164 return $error if $error;
1166 return "cannot unprovision svc_acct #".$self->svcnum.
1167 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1171 $self->SUPER::cancel(@_);
1177 Checks all fields to make sure this is a valid service. If there is an error,
1178 returns the error, otherwise returns false. Called by the insert and replace
1181 Sets any fixed values; see L<FS::part_svc>.
1188 my($recref) = $self->hashref;
1190 my $x = $self->setfixed( $self->_fieldhandlers );
1191 return $x unless ref($x);
1194 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1196 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1199 my $error = $self->ut_numbern('svcnum')
1200 #|| $self->ut_number('domsvc')
1201 || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1202 || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' )
1203 || $self->ut_textn('sec_phrase')
1204 || $self->ut_snumbern('seconds')
1205 || $self->ut_snumbern('upbytes')
1206 || $self->ut_snumbern('downbytes')
1207 || $self->ut_snumbern('totalbytes')
1208 || $self->ut_snumbern('seconds_threshold')
1209 || $self->ut_snumbern('upbytes_threshold')
1210 || $self->ut_snumbern('downbytes_threshold')
1211 || $self->ut_snumbern('totalbytes_threshold')
1212 || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1213 || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1214 || $self->ut_enum('password_recover', [ '', 'Y' ])
1216 || $self->ut_anything('cf_privatekey')
1218 || $self->ut_textn('cgp_accessmodes')
1219 || $self->ut_alphan('cgp_type')
1220 || $self->ut_textn('cgp_aliases' ) #well
1222 || $self->ut_alphasn('cgp_rulesallowed')
1223 || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1224 || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1225 || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1226 || $self->ut_snumbern('cgp_archiveafter')
1228 || $self->ut_alphasn('cgp_deletemode')
1229 || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1230 || $self->ut_alphan('cgp_language')
1231 || $self->ut_textn('cgp_timezone')
1232 || $self->ut_textn('cgp_skinname')
1233 || $self->ut_textn('cgp_prontoskinname')
1234 || $self->ut_alphan('cgp_sendmdnmode')
1236 return $error if $error;
1239 local $username_letter = $username_letter;
1240 if ($self->svcnum) {
1241 my $cust_svc = $self->cust_svc
1242 or return "no cust_svc record found for svcnum ". $self->svcnum;
1243 my $cust_pkg = $cust_svc->cust_pkg;
1245 if ($self->pkgnum) {
1246 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1250 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1253 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1255 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#]{$usernamemin,$ulen})$/i
1256 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1257 $recref->{username} = $1;
1259 unless ( $username_uppercase ) {
1260 $recref->{username} =~ /[A-Z]/ and return gettext('illegal_username');
1262 if ( $username_letterfirst ) {
1263 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1264 } elsif ( $username_letter ) {
1265 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1267 if ( $username_noperiod ) {
1268 $recref->{username} =~ /\./ and return gettext('illegal_username');
1270 if ( $username_nounderscore ) {
1271 $recref->{username} =~ /_/ and return gettext('illegal_username');
1273 if ( $username_nodash ) {
1274 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1276 unless ( $username_ampersand ) {
1277 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1279 unless ( $username_percent ) {
1280 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1282 unless ( $username_colon ) {
1283 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1285 unless ( $username_slash ) {
1286 $recref->{username} =~ /\// and return gettext('illegal_username');
1288 unless ( $username_equals ) {
1289 $recref->{username} =~ /\=/ and return gettext('illegal_username');
1291 unless ( $username_pound ) {
1292 $recref->{username} =~ /\#/ and return gettext('illegal_username');
1296 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1297 $recref->{popnum} = $1;
1298 return "Unknown popnum" unless
1299 ! $recref->{popnum} ||
1300 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1302 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1304 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1305 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1307 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1308 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1309 #not all systems use gid=uid
1310 #you can set a fixed gid in part_svc
1312 return "Only root can have uid 0"
1313 if $recref->{uid} == 0
1314 && $recref->{username} !~ /^(root|toor|smtp)$/;
1316 unless ( $recref->{username} eq 'sync' ) {
1317 if ( grep $_ eq $recref->{shell}, @shells ) {
1318 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1320 return "Illegal shell \`". $self->shell. "\'; ".
1321 "shells configuration value contains: @shells";
1324 $recref->{shell} = '/bin/sync';
1328 $recref->{gid} ne '' ?
1329 return "Can't have gid without uid" : ( $recref->{gid}='' );
1330 #$recref->{dir} ne '' ?
1331 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1332 $recref->{shell} ne '' ?
1333 return "Can't have shell without uid" : ( $recref->{shell}='' );
1336 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1338 $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1339 or return "Illegal directory: ". $recref->{dir};
1340 $recref->{dir} = $1;
1341 return "Illegal directory"
1342 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1343 return "Illegal directory"
1344 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1345 unless ( $recref->{dir} ) {
1346 $recref->{dir} = $dir_prefix . '/';
1347 if ( $dirhash > 0 ) {
1348 for my $h ( 1 .. $dirhash ) {
1349 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1351 } elsif ( $dirhash < 0 ) {
1352 for my $h ( reverse $dirhash .. -1 ) {
1353 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1356 $recref->{dir} .= $recref->{username};
1362 # $error = $self->ut_textn('finger');
1363 # return $error if $error;
1364 if ( $self->getfield('finger') eq '' ) {
1365 my $cust_pkg = $self->svcnum
1366 ? $self->cust_svc->cust_pkg
1367 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1369 my $cust_main = $cust_pkg->cust_main;
1370 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1373 $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]+)$/
1374 or return "Illegal finger: ". $self->getfield('finger');
1375 $self->setfield('finger', $1);
1377 for (qw( quota file_quota file_maxsize )) {
1378 $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1381 $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1382 $recref->{file_maxnum} = $1;
1384 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1385 if ( $recref->{slipip} eq '' ) {
1386 $recref->{slipip} = '';
1387 } elsif ( $recref->{slipip} eq '0e0' ) {
1388 $recref->{slipip} = '0e0';
1390 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1391 or return "Illegal slipip: ". $self->slipip;
1392 $recref->{slipip} = $1;
1397 #arbitrary RADIUS stuff; allow ut_textn for now
1398 foreach ( grep /^radius_/, fields('svc_acct') ) {
1399 $self->ut_textn($_);
1402 # First, if _password is blank, generate one and set default encoding.
1403 if ( ! $recref->{_password} ) {
1404 $error = $self->set_password('');
1406 # But if there's a _password but no encoding, assume it's plaintext and
1407 # set it to default encoding.
1408 elsif ( ! $recref->{_password_encoding} ) {
1409 $error = $self->set_password($recref->{_password});
1411 return $error if $error;
1413 # Next, check _password to ensure compliance with the encoding.
1414 if ( $recref->{_password_encoding} eq 'ldap' ) {
1416 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1417 $recref->{_password} = uc($1).$2;
1419 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1422 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1424 if ( $recref->{_password} =~
1425 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1426 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1429 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1432 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1435 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1436 # Password randomization is now in set_password.
1437 # Strip whitespace characters, check length requirements, etc.
1438 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1439 $recref->{_password} = $1;
1441 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1442 FS::Msgcat::_gettext('illegal_password_characters').
1443 ": ". $recref->{_password};
1446 if ( $password_noampersand ) {
1447 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1449 if ( $password_noexclamation ) {
1450 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1454 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1456 $self->SUPER::check;
1461 sub _password_encryption {
1463 my $encoding = lc($self->_password_encoding);
1464 return if !$encoding;
1465 return 'plain' if $encoding eq 'plain';
1466 if($encoding eq 'crypt') {
1467 my $pass = $self->_password;
1468 $pass =~ s/^\*SUSPENDED\* //;
1470 return 'md5' if $pass =~ /^\$1\$/;
1471 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1472 return 'des' if length($pass) == 13;
1475 if($encoding eq 'ldap') {
1476 uc($self->_password) =~ /^\{([\w-]+)\}/;
1477 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1478 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1479 return 'md5' if $1 eq 'MD5';
1480 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1487 sub get_cleartext_password {
1489 if($self->_password_encryption eq 'plain') {
1490 if($self->_password_encoding eq 'ldap') {
1491 $self->_password =~ /\{\w+\}(.*)$/;
1495 return $self->_password;
1504 Set the cleartext password for the account. If _password_encoding is set, the
1505 new password will be encoded according to the existing method (including
1506 encryption mode, if it can be determined). Otherwise,
1507 config('default-password-encoding') is used.
1509 If no password is supplied (or a zero-length password when minimum password length
1510 is >0), one will be generated randomly.
1515 my( $self, $pass ) = ( shift, shift );
1517 warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1520 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1521 FS::Msgcat::_gettext('illegal_password_characters').
1524 my( $encoding, $encryption ) = ('', '');
1526 if ( $self->_password_encoding ) {
1527 $encoding = $self->_password_encoding;
1528 # identify existing encryption method, try to use it.
1529 $encryption = $self->_password_encryption;
1531 # use the system default
1537 # set encoding to system default
1538 ($encoding, $encryption) =
1539 split(/-/, lc($conf->config('default-password-encoding')));
1540 $encoding ||= 'legacy';
1541 $self->_password_encoding($encoding);
1544 if ( $encoding eq 'legacy' ) {
1546 # The legacy behavior from check():
1547 # If the password is blank, randomize it and set encoding to 'plain'.
1548 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1549 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1550 $self->_password_encoding('plain');
1552 # Prefix + valid-length password
1553 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1555 $self->_password_encoding('plain');
1556 # Prefix + crypt string
1557 } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1559 $self->_password_encoding('crypt');
1560 # Various disabled crypt passwords
1561 } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1562 $self->_password_encoding('crypt');
1568 $self->_password($pass);
1574 if $passwordmin && length($pass) < $passwordmin
1575 or $passwordmax && length($pass) > $passwordmax;
1577 if ( $encoding eq 'crypt' ) {
1578 if ($encryption eq 'md5') {
1579 $pass = unix_md5_crypt($pass);
1580 } elsif ($encryption eq 'des') {
1581 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1584 } elsif ( $encoding eq 'ldap' ) {
1585 if ($encryption eq 'md5') {
1586 $pass = md5_base64($pass);
1587 } elsif ($encryption eq 'sha1') {
1588 $pass = sha1_base64($pass);
1589 } elsif ($encryption eq 'crypt') {
1590 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1592 # else $encryption eq 'plain', do nothing
1593 $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1594 if $encryption eq 'md5' || $encryption eq 'sha1';
1595 $pass = '{'.uc($encryption).'}'.$pass;
1597 # else encoding eq 'plain'
1599 $self->_password($pass);
1605 Internal function to check the username against the list of system usernames
1606 from the I<system_usernames> configuration value. Returns true if the username
1607 is listed on the system username list.
1613 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1614 $conf->config('system_usernames')
1618 =item _check_duplicate
1620 Internal method to check for duplicates usernames, username@domain pairs and
1623 If the I<global_unique-username> configuration value is set to B<username> or
1624 B<username@domain>, enforces global username or username@domain uniqueness.
1626 In all cases, check for duplicate uids and usernames or username@domain pairs
1627 per export and with identical I<svcpart> values.
1631 sub _check_duplicate {
1634 my $global_unique = $conf->config('global_unique-username') || 'none';
1635 return '' if $global_unique eq 'disabled';
1639 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1640 unless ( $part_svc ) {
1641 return 'unknown svcpart '. $self->svcpart;
1644 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1645 qsearch( 'svc_acct', { 'username' => $self->username } );
1646 return gettext('username_in_use')
1647 if $global_unique eq 'username' && @dup_user;
1649 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1650 qsearch( 'svc_acct', { 'username' => $self->username,
1651 'domsvc' => $self->domsvc } );
1652 return gettext('username_in_use')
1653 if $global_unique eq 'username@domain' && @dup_userdomain;
1656 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1657 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1658 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1659 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1664 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1665 my $exports = FS::part_export::export_info('svc_acct');
1666 my %conflict_user_svcpart;
1667 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1669 foreach my $part_export ( $part_svc->part_export ) {
1671 #this will catch to the same exact export
1672 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1674 #this will catch to exports w/same exporthost+type ???
1675 #my @other_part_export = qsearch('part_export', {
1676 # 'machine' => $part_export->machine,
1677 # 'exporttype' => $part_export->exporttype,
1679 #foreach my $other_part_export ( @other_part_export ) {
1680 # push @svcparts, map { $_->svcpart }
1681 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1684 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1685 #silly kludge to avoid uninitialized value errors
1686 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1687 ? $exports->{$part_export->exporttype}{'nodomain'}
1689 if ( $nodomain =~ /^Y/i ) {
1690 $conflict_user_svcpart{$_} = $part_export->exportnum
1693 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1698 foreach my $dup_user ( @dup_user ) {
1699 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1700 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1701 return "duplicate username ". $self->username.
1702 ": conflicts with svcnum ". $dup_user->svcnum.
1703 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1707 foreach my $dup_userdomain ( @dup_userdomain ) {
1708 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1709 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1710 return "duplicate username\@domain ". $self->email.
1711 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1712 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1716 foreach my $dup_uid ( @dup_uid ) {
1717 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1718 if ( exists($conflict_user_svcpart{$dup_svcpart})
1719 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1720 return "duplicate uid ". $self->uid.
1721 ": conflicts with svcnum ". $dup_uid->svcnum.
1723 ( $conflict_user_svcpart{$dup_svcpart}
1724 || $conflict_userdomain_svcpart{$dup_svcpart} );
1736 Depriciated, use radius_reply instead.
1741 carp "FS::svc_acct::radius depriciated, use radius_reply";
1742 $_[0]->radius_reply;
1747 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1748 reply attributes of this record.
1750 Note that this is now the preferred method for reading RADIUS attributes -
1751 accessing the columns directly is discouraged, as the column names are
1752 expected to change in the future.
1759 return %{ $self->{'radius_reply'} }
1760 if exists $self->{'radius_reply'};
1765 my($column, $attrib) = ($1, $2);
1766 #$attrib =~ s/_/\-/g;
1767 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1768 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1770 if ( $self->slipip && $self->slipip ne '0e0' ) {
1771 $reply{$radius_ip} = $self->slipip;
1774 if ( $self->seconds !~ /^$/ ) {
1775 $reply{'Session-Timeout'} = $self->seconds;
1778 if ( $conf->exists('radius-chillispot-max') ) {
1779 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1781 #hmm. just because sqlradius.pm says so?
1788 foreach my $what (qw( input output total )) {
1789 my $is = $whatis{$what}.'bytes';
1790 if ( $self->$is() =~ /\d/ ) {
1791 my $big = new Math::BigInt $self->$is();
1792 $big = new Math::BigInt '0' if $big->is_neg();
1793 my $att = "Chillispot-Max-\u$what";
1794 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1795 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1806 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1807 check attributes of this record.
1809 Note that this is now the preferred method for reading RADIUS attributes -
1810 accessing the columns directly is discouraged, as the column names are
1811 expected to change in the future.
1818 return %{ $self->{'radius_check'} }
1819 if exists $self->{'radius_check'};
1824 my($column, $attrib) = ($1, $2);
1825 #$attrib =~ s/_/\-/g;
1826 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1827 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1830 my($pw_attrib, $password) = $self->radius_password;
1831 $check{$pw_attrib} = $password;
1833 my $cust_svc = $self->cust_svc;
1835 my $cust_pkg = $cust_svc->cust_pkg;
1836 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1837 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1840 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1841 "; can't set Expiration\n"
1849 =item radius_password
1851 Returns a key/value pair containing the RADIUS attribute name and value
1856 sub radius_password {
1860 if ( $self->_password_encoding eq 'ldap' ) {
1861 $pw_attrib = 'Password-With-Header';
1862 } elsif ( $self->_password_encoding eq 'crypt' ) {
1863 $pw_attrib = 'Crypt-Password';
1864 } elsif ( $self->_password_encoding eq 'plain' ) {
1865 $pw_attrib = $radius_password;
1867 $pw_attrib = length($self->_password) <= 12
1872 ($pw_attrib, $self->_password);
1878 This method instructs the object to "snapshot" or freeze RADIUS check and
1879 reply attributes to the current values.
1883 #bah, my english is too broken this morning
1884 #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
1885 #the FS::cust_pkg's replace method to trigger the correct export updates when
1886 #package dates change)
1891 $self->{$_} = { $self->$_() }
1892 foreach qw( radius_reply radius_check );
1896 =item forget_snapshot
1898 This methos instructs the object to forget any previously snapshotted
1899 RADIUS check and reply attributes.
1903 sub forget_snapshot {
1907 foreach qw( radius_reply radius_check );
1911 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1913 Returns the domain associated with this account.
1915 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1922 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1923 my $svc_domain = $self->svc_domain(@_)
1924 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1925 $svc_domain->domain;
1930 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1934 #inherited from svc_Common
1936 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1938 Returns an email address associated with the account.
1940 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1947 $self->username. '@'. $self->domain(@_);
1952 Returns an array of FS::acct_snarf records associated with the account.
1959 'table' => 'acct_snarf',
1960 'hashref' => { 'svcnum' => $self->svcnum },
1961 #'order_by' => 'ORDER BY priority ASC',
1965 =item cgp_rpop_hashref
1967 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1971 sub cgp_rpop_hashref {
1973 { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1976 =item decrement_upbytes OCTETS
1978 Decrements the I<upbytes> field of this record by the given amount. If there
1979 is an error, returns the error, otherwise returns false.
1983 sub decrement_upbytes {
1984 shift->_op_usage('-', 'upbytes', @_);
1987 =item increment_upbytes OCTETS
1989 Increments the I<upbytes> field of this record by the given amount. If there
1990 is an error, returns the error, otherwise returns false.
1994 sub increment_upbytes {
1995 shift->_op_usage('+', 'upbytes', @_);
1998 =item decrement_downbytes OCTETS
2000 Decrements the I<downbytes> field of this record by the given amount. If there
2001 is an error, returns the error, otherwise returns false.
2005 sub decrement_downbytes {
2006 shift->_op_usage('-', 'downbytes', @_);
2009 =item increment_downbytes OCTETS
2011 Increments the I<downbytes> field of this record by the given amount. If there
2012 is an error, returns the error, otherwise returns false.
2016 sub increment_downbytes {
2017 shift->_op_usage('+', 'downbytes', @_);
2020 =item decrement_totalbytes OCTETS
2022 Decrements the I<totalbytes> field of this record by the given amount. If there
2023 is an error, returns the error, otherwise returns false.
2027 sub decrement_totalbytes {
2028 shift->_op_usage('-', 'totalbytes', @_);
2031 =item increment_totalbytes OCTETS
2033 Increments the I<totalbytes> field of this record by the given amount. If there
2034 is an error, returns the error, otherwise returns false.
2038 sub increment_totalbytes {
2039 shift->_op_usage('+', 'totalbytes', @_);
2042 =item decrement_seconds SECONDS
2044 Decrements the I<seconds> field of this record by the given amount. If there
2045 is an error, returns the error, otherwise returns false.
2049 sub decrement_seconds {
2050 shift->_op_usage('-', 'seconds', @_);
2053 =item increment_seconds SECONDS
2055 Increments the I<seconds> field of this record by the given amount. If there
2056 is an error, returns the error, otherwise returns false.
2060 sub increment_seconds {
2061 shift->_op_usage('+', 'seconds', @_);
2069 my %op2condition = (
2070 '-' => sub { my($self, $column, $amount) = @_;
2071 $self->$column - $amount <= 0;
2073 '+' => sub { my($self, $column, $amount) = @_;
2074 ($self->$column || 0) + $amount > 0;
2077 my %op2warncondition = (
2078 '-' => sub { my($self, $column, $amount) = @_;
2079 my $threshold = $column . '_threshold';
2080 $self->$column - $amount <= $self->$threshold + 0;
2082 '+' => sub { my($self, $column, $amount) = @_;
2083 ($self->$column || 0) + $amount > 0;
2088 my( $self, $op, $column, $amount ) = @_;
2090 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2091 ' ('. $self->email. "): $op $amount\n"
2094 return '' unless $amount;
2096 local $SIG{HUP} = 'IGNORE';
2097 local $SIG{INT} = 'IGNORE';
2098 local $SIG{QUIT} = 'IGNORE';
2099 local $SIG{TERM} = 'IGNORE';
2100 local $SIG{TSTP} = 'IGNORE';
2101 local $SIG{PIPE} = 'IGNORE';
2103 my $oldAutoCommit = $FS::UID::AutoCommit;
2104 local $FS::UID::AutoCommit = 0;
2107 my $sql = "UPDATE svc_acct SET $column = ".
2108 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2109 " $op ? WHERE svcnum = ?";
2113 my $sth = $dbh->prepare( $sql )
2114 or die "Error preparing $sql: ". $dbh->errstr;
2115 my $rv = $sth->execute($amount, $self->svcnum);
2116 die "Error executing $sql: ". $sth->errstr
2117 unless defined($rv);
2118 die "Can't update $column for svcnum". $self->svcnum
2121 #$self->snapshot; #not necessary, we retain the old values
2122 #create an object with the updated usage values
2123 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2125 my $error = $new->replace($self);
2127 $dbh->rollback if $oldAutoCommit;
2128 return "Error replacing: $error";
2131 #overlimit_action eq 'cancel' handling
2132 my $cust_pkg = $self->cust_svc->cust_pkg;
2134 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2135 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2139 my $error = $cust_pkg->cancel; #XXX should have a reason
2141 $dbh->rollback if $oldAutoCommit;
2142 return "Error cancelling: $error";
2145 #nothing else is relevant if we're cancelling, so commit & return success
2146 warn "$me update successful; committing\n"
2148 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2153 my $action = $op2action{$op};
2155 if ( &{$op2condition{$op}}($self, $column, $amount) &&
2156 ( $action eq 'suspend' && !$self->overlimit
2157 || $action eq 'unsuspend' && $self->overlimit )
2160 my $error = $self->_op_overlimit($action);
2162 $dbh->rollback if $oldAutoCommit;
2168 if ( $conf->exists("svc_acct-usage_$action")
2169 && &{$op2condition{$op}}($self, $column, $amount) ) {
2170 #my $error = $self->$action();
2171 my $error = $self->cust_svc->cust_pkg->$action();
2172 # $error ||= $self->overlimit($action);
2174 $dbh->rollback if $oldAutoCommit;
2175 return "Error ${action}ing: $error";
2179 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2180 my $wqueue = new FS::queue {
2181 'svcnum' => $self->svcnum,
2182 'job' => 'FS::svc_acct::reached_threshold',
2187 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2191 my $error = $wqueue->insert(
2192 'svcnum' => $self->svcnum,
2194 'column' => $column,
2198 $dbh->rollback if $oldAutoCommit;
2199 return "Error queuing threshold activity: $error";
2203 warn "$me update successful; committing\n"
2205 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2211 my( $self, $action ) = @_;
2213 local $SIG{HUP} = 'IGNORE';
2214 local $SIG{INT} = 'IGNORE';
2215 local $SIG{QUIT} = 'IGNORE';
2216 local $SIG{TERM} = 'IGNORE';
2217 local $SIG{TSTP} = 'IGNORE';
2218 local $SIG{PIPE} = 'IGNORE';
2220 my $oldAutoCommit = $FS::UID::AutoCommit;
2221 local $FS::UID::AutoCommit = 0;
2224 my $cust_pkg = $self->cust_svc->cust_pkg;
2226 my $conf_overlimit =
2228 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2229 : $conf->config('overlimit_groups');
2231 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2233 my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2234 next unless $groups;
2236 my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2238 my $other = new FS::svc_acct $self->hashref;
2239 $other->usergroup( $gref );
2242 if ($action eq 'suspend') {
2245 } else { # $action eq 'unsuspend'
2250 my $error = $part_export->export_replace($new, $old)
2251 || $self->overlimit($action);
2254 $dbh->rollback if $oldAutoCommit;
2255 return "Error replacing radius groups: $error";
2260 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2266 my( $self, $valueref, %options ) = @_;
2268 warn "$me set_usage called for svcnum ". $self->svcnum.
2269 ' ('. $self->email. "): ".
2270 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2273 local $SIG{HUP} = 'IGNORE';
2274 local $SIG{INT} = 'IGNORE';
2275 local $SIG{QUIT} = 'IGNORE';
2276 local $SIG{TERM} = 'IGNORE';
2277 local $SIG{TSTP} = 'IGNORE';
2278 local $SIG{PIPE} = 'IGNORE';
2280 local $FS::svc_Common::noexport_hack = 1;
2281 my $oldAutoCommit = $FS::UID::AutoCommit;
2282 local $FS::UID::AutoCommit = 0;
2287 if ( $options{null} ) {
2288 %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2289 qw( seconds upbytes downbytes totalbytes )
2292 foreach my $field (keys %$valueref){
2293 $reset = 1 if $valueref->{$field};
2294 $self->setfield($field, $valueref->{$field});
2295 $self->setfield( $field.'_threshold',
2296 int($self->getfield($field)
2297 * ( $conf->exists('svc_acct-usage_threshold')
2298 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2303 $handyhash{$field} = $self->getfield($field);
2304 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2306 #my $error = $self->replace; #NO! we avoid the call to ->check for
2307 #die $error if $error; #services not explicity changed via the UI
2309 my $sql = "UPDATE svc_acct SET " .
2310 join (',', map { "$_ = ?" } (keys %handyhash) ).
2311 " WHERE svcnum = ". $self->svcnum;
2316 if (scalar(keys %handyhash)) {
2317 my $sth = $dbh->prepare( $sql )
2318 or die "Error preparing $sql: ". $dbh->errstr;
2319 my $rv = $sth->execute(values %handyhash);
2320 die "Error executing $sql: ". $sth->errstr
2321 unless defined($rv);
2322 die "Can't update usage for svcnum ". $self->svcnum
2326 #$self->snapshot; #not necessary, we retain the old values
2327 #create an object with the updated usage values
2328 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2329 local($FS::Record::nowarn_identical) = 1;
2330 my $error = $new->replace($self); #call exports
2332 $dbh->rollback if $oldAutoCommit;
2333 return "Error replacing: $error";
2340 $error = $self->_op_overlimit('unsuspend')
2341 if $self->overlimit;;
2343 $error ||= $self->cust_svc->cust_pkg->unsuspend
2344 if $conf->exists("svc_acct-usage_unsuspend");
2347 $dbh->rollback if $oldAutoCommit;
2348 return "Error unsuspending: $error";
2353 warn "$me update successful; committing\n"
2355 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2361 =item recharge HASHREF
2363 Increments usage columns by the amount specified in HASHREF as
2364 column=>amount pairs.
2369 my ($self, $vhash) = @_;
2372 warn "[$me] recharge called on $self: ". Dumper($self).
2373 "\nwith vhash: ". Dumper($vhash);
2376 my $oldAutoCommit = $FS::UID::AutoCommit;
2377 local $FS::UID::AutoCommit = 0;
2381 foreach my $column (keys %$vhash){
2382 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2386 $dbh->rollback if $oldAutoCommit;
2388 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2393 =item is_rechargeable
2395 Returns true if this svc_account can be "recharged" and false otherwise.
2399 sub is_rechargable {
2401 $self->seconds ne ''
2402 || $self->upbytes ne ''
2403 || $self->downbytes ne ''
2404 || $self->totalbytes ne '';
2407 =item seconds_since TIMESTAMP
2409 Returns the number of seconds this account has been online since TIMESTAMP,
2410 according to the session monitor (see L<FS::Session>).
2412 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2413 L<Time::Local> and L<Date::Parse> for conversion functions.
2417 #note: POD here, implementation in FS::cust_svc
2420 $self->cust_svc->seconds_since(@_);
2423 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2425 Returns the numbers of seconds this account has been online between
2426 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2427 external SQL radacct table, specified via sqlradius export. Sessions which
2428 started in the specified range but are still open are counted from session
2429 start to the end of the range (unless they are over 1 day old, in which case
2430 they are presumed missing their stop record and not counted). Also, sessions
2431 which end in the range but started earlier are counted from the start of the
2432 range to session end. Finally, sessions which start before the range but end
2433 after are counted for the entire range.
2435 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2436 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2441 #note: POD here, implementation in FS::cust_svc
2442 sub seconds_since_sqlradacct {
2444 $self->cust_svc->seconds_since_sqlradacct(@_);
2447 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2449 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2450 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2451 TIMESTAMP_END (exclusive).
2453 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2454 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2459 #note: POD here, implementation in FS::cust_svc
2460 sub attribute_since_sqlradacct {
2462 $self->cust_svc->attribute_since_sqlradacct(@_);
2465 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2467 Returns an array of hash references of this customers login history for the
2468 given time range. (document this better)
2472 sub get_session_history {
2474 $self->cust_svc->get_session_history(@_);
2477 =item last_login_text
2479 Returns text describing the time of last login.
2483 sub last_login_text {
2485 $self->last_login ? ctime($self->last_login) : 'unknown';
2488 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2493 my($self, $start, $end, %opt ) = @_;
2495 my $did = $self->username; #yup
2497 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2499 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2501 #SELECT $for_update * FROM cdr
2502 # WHERE calldate >= $start #need a conversion
2503 # AND calldate < $end #ditto
2504 # AND ( charged_party = "$did"
2505 # OR charged_party = "$prefix$did" #if length($prefix);
2506 # OR ( ( charged_party IS NULL OR charged_party = '' )
2508 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2511 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2514 if ( length($prefix) ) {
2516 " AND ( charged_party = '$did'
2517 OR charged_party = '$prefix$did'
2518 OR ( ( charged_party IS NULL OR charged_party = '' )
2520 ( src = '$did' OR src = '$prefix$did' )
2526 " AND ( charged_party = '$did'
2527 OR ( ( charged_party IS NULL OR charged_party = '' )
2537 'select' => "$for_update *",
2540 #( freesidestatus IS NULL OR freesidestatus = '' )
2541 'freesidestatus' => '',
2543 'extra_sql' => $charged_or_src,
2551 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2557 if ( $self->usergroup ) {
2558 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2559 unless ref($self->usergroup) eq 'ARRAY';
2560 #when provisioning records, export callback runs in svc_Common.pm before
2561 #radius_usergroup records can be inserted...
2562 @{$self->usergroup};
2564 my $format = shift || '';
2565 my @groups = qsearch({ 'table' => 'radius_usergroup',
2566 'addl_from' => 'left join radius_group using (groupnum)',
2567 'select' => 'radius_group.*',
2568 'hashref' => { 'svcnum' => $self->svcnum },
2571 # this is to preserve various legacy behaviour / avoid re-writing other code
2572 return map { $_->groupnum } @groups if $format eq 'NUMBERS';
2573 return map { $_->description . " (" . $_->groupname . ")" } @groups
2574 if $format eq 'COMBINED';
2575 map { $_->groupname } @groups;
2579 =item clone_suspended
2581 Constructor used by FS::part_export::_export_suspend fallback. Document
2586 sub clone_suspended {
2588 my %hash = $self->hash;
2589 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2590 new FS::svc_acct \%hash;
2593 =item clone_kludge_unsuspend
2595 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2600 sub clone_kludge_unsuspend {
2602 my %hash = $self->hash;
2603 $hash{_password} = '';
2604 new FS::svc_acct \%hash;
2607 =item check_password
2609 Checks the supplied password against the (possibly encrypted) password in the
2610 database. Returns true for a successful authentication, false for no match.
2612 Currently supported encryptions are: classic DES crypt() and MD5
2616 sub check_password {
2617 my($self, $check_password) = @_;
2619 #remove old-style SUSPENDED kludge, they should be allowed to login to
2620 #self-service and pay up
2621 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2623 if ( $self->_password_encoding eq 'ldap' ) {
2625 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2626 return $auth->match($check_password);
2628 } elsif ( $self->_password_encoding eq 'crypt' ) {
2630 my $auth = from_crypt Authen::Passphrase $self->_password;
2631 return $auth->match($check_password);
2633 } elsif ( $self->_password_encoding eq 'plain' ) {
2635 return $check_password eq $password;
2639 #XXX this could be replaced with Authen::Passphrase stuff
2641 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2643 } elsif ( length($password) < 13 ) { #plaintext
2644 $check_password eq $password;
2645 } elsif ( length($password) == 13 ) { #traditional DES crypt
2646 crypt($check_password, $password) eq $password;
2647 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2648 unix_md5_crypt($check_password, $password) eq $password;
2649 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2650 warn "Can't check password: Blowfish encryption not yet supported, ".
2651 "svcnum ". $self->svcnum. "\n";
2654 warn "Can't check password: Unrecognized encryption for svcnum ".
2655 $self->svcnum. "\n";
2663 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2665 Returns an encrypted password, either by passing through an encrypted password
2666 in the database or by encrypting a plaintext password from the database.
2668 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2669 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2670 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2671 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2672 encryption type is only used if the password is not already encrypted in the
2677 sub crypt_password {
2680 if ( $self->_password_encoding eq 'ldap' ) {
2682 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2685 #XXX this could be replaced with Authen::Passphrase stuff
2687 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2688 if ( $encryption eq 'crypt' ) {
2691 $saltset[int(rand(64))].$saltset[int(rand(64))]
2693 } elsif ( $encryption eq 'md5' ) {
2694 return unix_md5_crypt( $self->_password );
2695 } elsif ( $encryption eq 'blowfish' ) {
2696 croak "unknown encryption method $encryption";
2698 croak "unknown encryption method $encryption";
2701 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2705 } elsif ( $self->_password_encoding eq 'crypt' ) {
2707 return $self->_password;
2709 } elsif ( $self->_password_encoding eq 'plain' ) {
2711 #XXX this could be replaced with Authen::Passphrase stuff
2713 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2714 if ( $encryption eq 'crypt' ) {
2717 $saltset[int(rand(64))].$saltset[int(rand(64))]
2719 } elsif ( $encryption eq 'md5' ) {
2720 return unix_md5_crypt( $self->_password );
2721 } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2722 my $pass = sha1_base64( $self->_password );
2723 $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2725 } elsif ( $encryption eq 'blowfish' ) {
2726 croak "unknown encryption method $encryption";
2728 croak "unknown encryption method $encryption";
2733 if ( length($self->_password) == 13
2734 || $self->_password =~ /^\$(1|2a?)\$/
2735 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2741 #XXX this could be replaced with Authen::Passphrase stuff
2743 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2744 if ( $encryption eq 'crypt' ) {
2747 $saltset[int(rand(64))].$saltset[int(rand(64))]
2749 } elsif ( $encryption eq 'md5' ) {
2750 return unix_md5_crypt( $self->_password );
2751 } elsif ( $encryption eq 'blowfish' ) {
2752 croak "unknown encryption method $encryption";
2754 croak "unknown encryption method $encryption";
2763 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2765 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2766 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2767 "{MD5}5426824942db4253f87a1009fd5d2d4".
2769 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2770 to work the same as the B</crypt_password> method.
2776 #eventually should check a "password-encoding" field
2778 if ( $self->_password_encoding eq 'ldap' ) {
2780 return $self->_password;
2782 } elsif ( $self->_password_encoding eq 'crypt' ) {
2784 if ( length($self->_password) == 13 ) { #crypt
2785 return '{CRYPT}'. $self->_password;
2786 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2788 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2789 # die "Blowfish encryption not supported in this context, svcnum ".
2790 # $self->svcnum. "\n";
2792 warn "encryption method not (yet?) supported in LDAP context";
2793 return '{CRYPT}*'; #unsupported, should not auth
2796 } elsif ( $self->_password_encoding eq 'plain' ) {
2798 return '{PLAIN}'. $self->_password;
2800 #return '{CLEARTEXT}'. $self->_password; #?
2804 if ( length($self->_password) == 13 ) { #crypt
2805 return '{CRYPT}'. $self->_password;
2806 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2808 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2809 warn "Blowfish encryption not supported in this context, svcnum ".
2810 $self->svcnum. "\n";
2813 #are these two necessary anymore?
2814 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2815 return '{SSHA}'. $1;
2816 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2817 return '{NS-MTA-MD5}'. $1;
2820 return '{PLAIN}'. $self->_password;
2822 #return '{CLEARTEXT}'. $self->_password; #?
2824 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2825 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2826 #if ( $encryption eq 'crypt' ) {
2827 # return '{CRYPT}'. crypt(
2829 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2831 #} elsif ( $encryption eq 'md5' ) {
2832 # unix_md5_crypt( $self->_password );
2833 #} elsif ( $encryption eq 'blowfish' ) {
2834 # croak "unknown encryption method $encryption";
2836 # croak "unknown encryption method $encryption";
2844 =item domain_slash_username
2846 Returns $domain/$username/
2850 sub domain_slash_username {
2852 $self->domain. '/'. $self->username. '/';
2855 =item virtual_maildir
2857 Returns $domain/maildirs/$username/
2861 sub virtual_maildir {
2863 $self->domain. '/maildirs/'. $self->username. '/';
2868 =head1 CLASS METHODS
2872 =item search HASHREF
2874 Class method which returns a qsearch hash expression to search for parameters
2875 specified in HASHREF. Valid parameters are
2889 Arrayref of pkgparts
2895 Arrayref of additional WHERE clauses, will be ANDed together.
2906 my ($class, $params) = @_;
2911 if ( $params->{'domain'} ) {
2912 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2913 #preserve previous behavior & bubble up an error if $svc_domain not found?
2914 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2918 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2919 push @where, "domsvc = $1";
2923 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2926 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2927 push @where, "agentnum = $1";
2931 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2932 push @where, "custnum = $1";
2936 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2937 #XXX untaint or sql quote
2939 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2943 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2944 push @where, "popnum = $1";
2948 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2949 push @where, "svcpart = $1";
2953 # here is the agent virtualization
2954 #if ($params->{CurrentUser}) {
2956 # qsearchs('access_user', { username => $params->{CurrentUser} });
2958 # if ($access_user) {
2959 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2961 # push @where, "1=0";
2964 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2965 'table' => 'cust_main',
2966 'null_right' => 'View/link unlinked services',
2970 push @where, @{ $params->{'where'} } if $params->{'where'};
2972 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2974 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2975 ' LEFT JOIN part_svc USING ( svcpart ) '.
2976 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2977 ' LEFT JOIN cust_main USING ( custnum ) ';
2979 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2980 #if ( keys %svc_acct ) {
2981 # $count_query .= ' WHERE '.
2982 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2988 'table' => 'svc_acct',
2989 'hashref' => {}, # \%svc_acct,
2990 'select' => join(', ',
2993 'cust_main.custnum',
2994 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2996 'addl_from' => $addl_from,
2997 'extra_sql' => $extra_sql,
2998 'order_by' => $params->{'order_by'},
2999 'count_query' => $count_query,
3012 This is the FS::svc_acct job-queue-able version. It still uses
3013 FS::Misc::send_email under-the-hood.
3020 eval "use FS::Misc qw(send_email)";
3023 $opt{mimetype} ||= 'text/plain';
3024 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3026 my $error = send_email(
3027 'from' => $opt{from},
3029 'subject' => $opt{subject},
3030 'content-type' => $opt{mimetype},
3031 'body' => [ map "$_\n", split("\n", $opt{body}) ],
3033 die $error if $error;
3036 =item check_and_rebuild_fuzzyfiles
3040 sub check_and_rebuild_fuzzyfiles {
3041 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3042 -e "$dir/svc_acct.username"
3043 or &rebuild_fuzzyfiles;
3046 =item rebuild_fuzzyfiles
3050 sub rebuild_fuzzyfiles {
3052 use Fcntl qw(:flock);
3054 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3058 open(USERNAMELOCK,">>$dir/svc_acct.username")
3059 or die "can't open $dir/svc_acct.username: $!";
3060 flock(USERNAMELOCK,LOCK_EX)
3061 or die "can't lock $dir/svc_acct.username: $!";
3063 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
3065 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
3066 or die "can't open $dir/svc_acct.username.tmp: $!";
3067 print USERNAMECACHE join("\n", @all_username), "\n";
3068 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
3070 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
3080 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3081 open(USERNAMECACHE,"<$dir/svc_acct.username")
3082 or die "can't open $dir/svc_acct.username: $!";
3083 my @array = map { chomp; $_; } <USERNAMECACHE>;
3084 close USERNAMECACHE;
3088 =item append_fuzzyfiles USERNAME
3092 sub append_fuzzyfiles {
3093 my $username = shift;
3095 &check_and_rebuild_fuzzyfiles;
3097 use Fcntl qw(:flock);
3099 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3101 open(USERNAME,">>$dir/svc_acct.username")
3102 or die "can't open $dir/svc_acct.username: $!";
3103 flock(USERNAME,LOCK_EX)
3104 or die "can't lock $dir/svc_acct.username: $!";
3106 print USERNAME "$username\n";
3108 flock(USERNAME,LOCK_UN)
3109 or die "can't unlock $dir/svc_acct.username: $!";
3116 =item reached_threshold
3118 Performs some activities when svc_acct thresholds (such as number of seconds
3119 remaining) are reached.
3123 sub reached_threshold {
3126 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3127 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3129 if ( $opt{'op'} eq '+' ){
3130 $svc_acct->setfield( $opt{'column'}.'_threshold',
3131 int($svc_acct->getfield($opt{'column'})
3132 * ( $conf->exists('svc_acct-usage_threshold')
3133 ? $conf->config('svc_acct-usage_threshold')/100
3138 my $error = $svc_acct->replace;
3139 die $error if $error;
3140 }elsif ( $opt{'op'} eq '-' ){
3142 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3143 return '' if ($threshold eq '' );
3145 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3146 my $error = $svc_acct->replace;
3147 die $error if $error; # email next time, i guess
3149 if ( $warning_template ) {
3150 eval "use FS::Misc qw(send_email)";
3153 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
3154 my $cust_main = $cust_pkg->cust_main;
3156 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3157 $cust_main->invoicing_list,
3158 ($opt{'to'} ? $opt{'to'} : ())
3161 my $mimetype = $warning_mimetype;
3162 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3164 my $body = $warning_template->fill_in( HASH => {
3165 'custnum' => $cust_main->custnum,
3166 'username' => $svc_acct->username,
3167 'password' => $svc_acct->_password,
3168 'first' => $cust_main->first,
3169 'last' => $cust_main->getfield('last'),
3170 'pkg' => $cust_pkg->part_pkg->pkg,
3171 'column' => $opt{'column'},
3172 'amount' => $opt{'column'} =~/bytes/
3173 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3174 : $svc_acct->getfield($opt{'column'}),
3175 'threshold' => $opt{'column'} =~/bytes/
3176 ? FS::UI::bytecount::display_bytecount($threshold)
3181 my $error = send_email(
3182 'from' => $warning_from,
3184 'subject' => $warning_subject,
3185 'content-type' => $mimetype,
3186 'body' => [ map "$_\n", split("\n", $body) ],
3188 die $error if $error;
3191 die "unknown op: " . $opt{'op'};
3199 The $recref stuff in sub check should be cleaned up.
3201 The suspend, unsuspend and cancel methods update the database, but not the
3202 current object. This is probably a bug as it's unexpected and
3205 insertion of RADIUS group stuff in insert could be done with child_objects now
3206 (would probably clean up export of them too)
3208 _op_usage and set_usage bypass the history... maybe they shouldn't
3212 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3213 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3214 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3215 L<freeside-queued>), L<FS::svc_acct_pop>,
3216 schema.html from the base documentation.