4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
9 $username_uppercase $username_percent
10 $password_noampersand $password_noexclamation
11 $warning_template $warning_from $warning_subject $warning_mimetype
14 $radius_password $radius_ip
20 use Crypt::PasswdMD5 1.2;
22 use Authen::Passphrase;
23 use FS::UID qw( datasrc );
25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
26 use FS::Msgcat qw(gettext);
27 use FS::UI::bytecount;
32 use FS::cust_main_invoice;
36 use FS::radius_usergroup;
43 @ISA = qw( FS::svc_Common );
46 $me = '[FS::svc_acct]';
48 #ask FS::UID to run this stuff for us later
49 $FS::UID::callback{'FS::svc_acct'} = sub {
51 $dir_prefix = $conf->config('home');
52 @shells = $conf->config('shells');
53 $usernamemin = $conf->config('usernamemin') || 2;
54 $usernamemax = $conf->config('usernamemax');
55 $passwordmin = $conf->config('passwordmin') || 6;
56 $passwordmax = $conf->config('passwordmax') || 8;
57 $username_letter = $conf->exists('username-letter');
58 $username_letterfirst = $conf->exists('username-letterfirst');
59 $username_noperiod = $conf->exists('username-noperiod');
60 $username_nounderscore = $conf->exists('username-nounderscore');
61 $username_nodash = $conf->exists('username-nodash');
62 $username_uppercase = $conf->exists('username-uppercase');
63 $username_ampersand = $conf->exists('username-ampersand');
64 $username_percent = $conf->exists('username-percent');
65 $password_noampersand = $conf->exists('password-noexclamation');
66 $password_noexclamation = $conf->exists('password-noexclamation');
67 $dirhash = $conf->config('dirhash') || 0;
68 if ( $conf->exists('warning_email') ) {
69 $warning_template = new Text::Template (
71 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
72 ) or warn "can't create warning email template: $Text::Template::ERROR";
73 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
74 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
75 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
76 $warning_cc = $conf->config('warning_email-cc');
78 $warning_template = '';
80 $warning_subject = '';
81 $warning_mimetype = '';
84 $smtpmachine = $conf->config('smtpmachine');
85 $radius_password = $conf->config('radius-password') || 'Password';
86 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
87 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
90 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
91 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
95 my ( $hashref, $cache ) = @_;
96 if ( $hashref->{'svc_acct_svcnum'} ) {
97 $self->{'_domsvc'} = FS::svc_domain->new( {
98 'svcnum' => $hashref->{'domsvc'},
99 'domain' => $hashref->{'svc_acct_domain'},
100 'catchall' => $hashref->{'svc_acct_catchall'},
107 FS::svc_acct - Object methods for svc_acct records
113 $record = new FS::svc_acct \%hash;
114 $record = new FS::svc_acct { 'column' => 'value' };
116 $error = $record->insert;
118 $error = $new_record->replace($old_record);
120 $error = $record->delete;
122 $error = $record->check;
124 $error = $record->suspend;
126 $error = $record->unsuspend;
128 $error = $record->cancel;
130 %hash = $record->radius;
132 %hash = $record->radius_reply;
134 %hash = $record->radius_check;
136 $domain = $record->domain;
138 $svc_domain = $record->svc_domain;
140 $email = $record->email;
142 $seconds_since = $record->seconds_since($timestamp);
146 An FS::svc_acct object represents an account. FS::svc_acct inherits from
147 FS::svc_Common. The following fields are currently supported:
151 =item svcnum - primary key (assigned automatcially for new accounts)
155 =item _password - generated if blank
157 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
159 =item sec_phrase - security phrase
161 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
169 =item dir - set automatically if blank (and uid is not)
173 =item quota - (unimplementd)
175 =item slipip - IP address
185 =item domsvc - svcnum from svc_domain
187 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
189 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
199 Creates a new account. To add the account to the database, see L<"insert">.
206 'longname_plural' => 'Access accounts and mailboxes',
207 'sorts' => [ 'username', 'uid', ],
208 'display_weight' => 10,
209 'cancel_weight' => 50,
211 'dir' => 'Home directory',
214 def_label => 'UID (set to fixed and blank for no UIDs)',
217 'slipip' => 'IP address',
218 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
220 label => 'Access number',
222 select_table => 'svc_acct_pop',
223 select_key => 'popnum',
224 select_label => 'city',
230 disable_default => 1,
237 disable_inventory => 1,
240 '_password' => 'Password',
243 def_label => 'GID (when blank, defaults to UID)',
247 #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
249 def_label=> 'Shell (set to blank for no shell tracking)',
251 select_list => [ $conf->config('shells') ],
252 disable_inventory => 1,
255 'finger' => 'Real name (GECOS)',
258 #def_label => 'svcnum from svc_domain',
260 select_table => 'svc_domain',
261 select_key => 'svcnum',
262 select_label => 'domain',
263 disable_inventory => 1,
267 label => 'RADIUS groups',
268 type => 'radius_usergroup_selector',
269 disable_inventory => 1,
272 'seconds' => { label => 'Seconds',
274 disable_inventory => 1,
277 'upbytes' => { label => 'Upload',
279 disable_inventory => 1,
281 'format' => \&FS::UI::bytecount::display_bytecount,
282 'parse' => \&FS::UI::bytecount::parse_bytecount,
284 'downbytes' => { label => 'Download',
286 disable_inventory => 1,
288 'format' => \&FS::UI::bytecount::display_bytecount,
289 'parse' => \&FS::UI::bytecount::parse_bytecount,
291 'totalbytes'=> { label => 'Total up and download',
293 disable_inventory => 1,
295 'format' => \&FS::UI::bytecount::display_bytecount,
296 'parse' => \&FS::UI::bytecount::parse_bytecount,
298 'seconds_threshold' => { label => 'Seconds',
300 disable_inventory => 1,
303 'upbytes_threshold' => { label => 'Upload',
305 disable_inventory => 1,
307 'format' => \&FS::UI::bytecount::display_bytecount,
308 'parse' => \&FS::UI::bytecount::parse_bytecount,
310 'downbytes_threshold' => { label => 'Download',
312 disable_inventory => 1,
314 'format' => \&FS::UI::bytecount::display_bytecount,
315 'parse' => \&FS::UI::bytecount::parse_bytecount,
317 'totalbytes_threshold'=> { label => 'Total up and download',
319 disable_inventory => 1,
321 'format' => \&FS::UI::bytecount::display_bytecount,
322 'parse' => \&FS::UI::bytecount::parse_bytecount,
328 sub table { 'svc_acct'; }
332 #false laziness with edit/svc_acct.cgi
334 my( $self, $groups ) = @_;
335 if ( ref($groups) eq 'ARRAY' ) {
337 } elsif ( length($groups) ) {
338 [ split(/\s*,\s*/, $groups) ];
346 =item search_sql STRING
348 Class method which returns an SQL fragment to search for the given string.
353 my( $class, $string ) = @_;
354 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
355 my( $username, $domain ) = ( $1, $2 );
356 my $q_username = dbh->quote($username);
357 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
359 "svc_acct.username = $q_username AND ( ".
360 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
365 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
367 $class->search_sql_field('slipip', $string ).
369 $class->search_sql_field('username', $string ).
372 $class->search_sql_field('username', $string);
376 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
378 Returns the "username@domain" string for this account.
380 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
392 =item insert [ , OPTION => VALUE ... ]
394 Adds this account to the database. If there is an error, returns the error,
395 otherwise returns false.
397 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
398 defined. An FS::cust_svc record will be created and inserted.
400 The additional field I<usergroup> can optionally be defined; if so it should
401 contain an arrayref of group names. See L<FS::radius_usergroup>.
403 The additional field I<child_objects> can optionally be defined; if so it
404 should contain an arrayref of FS::tablename objects. They will have their
405 svcnum fields set and will be inserted after this record, but before any
406 exports are run. Each element of the array can also optionally be a
407 two-element array reference containing the child object and the name of an
408 alternate field to be filled in with the newly-inserted svcnum, for example
409 C<[ $svc_forward, 'srcsvc' ]>
411 Currently available options are: I<depend_jobnum>
413 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
414 jobnums), all provisioning jobs will have a dependancy on the supplied
415 jobnum(s) (they will not run until the specific job(s) complete(s)).
417 (TODOC: L<FS::queue> and L<freeside-queued>)
419 (TODOC: new exports!)
428 warn "[$me] insert called on $self: ". Dumper($self).
429 "\nwith options: ". Dumper(%options);
432 local $SIG{HUP} = 'IGNORE';
433 local $SIG{INT} = 'IGNORE';
434 local $SIG{QUIT} = 'IGNORE';
435 local $SIG{TERM} = 'IGNORE';
436 local $SIG{TSTP} = 'IGNORE';
437 local $SIG{PIPE} = 'IGNORE';
439 my $oldAutoCommit = $FS::UID::AutoCommit;
440 local $FS::UID::AutoCommit = 0;
443 my $error = $self->check;
444 return $error if $error;
446 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
447 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
448 unless ( $cust_svc ) {
449 $dbh->rollback if $oldAutoCommit;
450 return "no cust_svc record found for svcnum ". $self->svcnum;
452 $self->pkgnum($cust_svc->pkgnum);
453 $self->svcpart($cust_svc->svcpart);
456 $error = $self->_check_duplicate;
458 $dbh->rollback if $oldAutoCommit;
463 $error = $self->SUPER::insert(
464 'jobnums' => \@jobnums,
465 'child_objects' => $self->child_objects,
469 $dbh->rollback if $oldAutoCommit;
473 if ( $self->usergroup ) {
474 foreach my $groupname ( @{$self->usergroup} ) {
475 my $radius_usergroup = new FS::radius_usergroup ( {
476 svcnum => $self->svcnum,
477 groupname => $groupname,
479 my $error = $radius_usergroup->insert;
481 $dbh->rollback if $oldAutoCommit;
487 unless ( $skip_fuzzyfiles ) {
488 $error = $self->queue_fuzzyfiles_update;
490 $dbh->rollback if $oldAutoCommit;
491 return "updating fuzzy search cache: $error";
495 my $cust_pkg = $self->cust_svc->cust_pkg;
498 my $cust_main = $cust_pkg->cust_main;
499 my $agentnum = $cust_main->agentnum;
501 if ( $conf->exists('emailinvoiceautoalways')
502 || $conf->exists('emailinvoiceauto')
503 && ! $cust_main->invoicing_list_emailonly
505 my @invoicing_list = $cust_main->invoicing_list;
506 push @invoicing_list, $self->email;
507 $cust_main->invoicing_list(\@invoicing_list);
511 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
512 = ('','','','','','');
514 if ( $conf->exists('welcome_email', $agentnum) ) {
515 $welcome_template = new Text::Template (
517 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
518 ) or warn "can't create welcome email template: $Text::Template::ERROR";
519 $welcome_from = $conf->config('welcome_email-from', $agentnum);
520 # || 'your-isp-is-dum'
521 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
523 $welcome_subject_template = new Text::Template (
525 SOURCE => $welcome_subject,
526 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
527 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
530 if ( $welcome_template && $cust_pkg ) {
531 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
535 'custnum' => $self->custnum,
536 'username' => $self->username,
537 'password' => $self->_password,
538 'first' => $cust_main->first,
539 'last' => $cust_main->getfield('last'),
540 'pkg' => $cust_pkg->part_pkg->pkg,
542 my $wqueue = new FS::queue {
543 'svcnum' => $self->svcnum,
544 'job' => 'FS::svc_acct::send_email'
546 my $error = $wqueue->insert(
548 'from' => $welcome_from,
549 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
550 'mimetype' => $welcome_mimetype,
551 'body' => $welcome_template->fill_in( HASH => \%hash, ),
554 $dbh->rollback if $oldAutoCommit;
555 return "error queuing welcome email: $error";
558 if ( $options{'depend_jobnum'} ) {
559 warn "$me depend_jobnum found; adding to welcome email dependancies"
561 if ( ref($options{'depend_jobnum'}) ) {
562 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
563 "to welcome email dependancies"
565 push @jobnums, @{ $options{'depend_jobnum'} };
567 warn "$me adding job $options{'depend_jobnum'} ".
568 "to welcome email dependancies"
570 push @jobnums, $options{'depend_jobnum'};
574 foreach my $jobnum ( @jobnums ) {
575 my $error = $wqueue->depend_insert($jobnum);
577 $dbh->rollback if $oldAutoCommit;
578 return "error queuing welcome email job dependancy: $error";
588 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
594 Deletes this account from the database. If there is an error, returns the
595 error, otherwise returns false.
597 The corresponding FS::cust_svc record will be deleted as well.
599 (TODOC: new exports!)
606 return "can't delete system account" if $self->_check_system;
608 return "Can't delete an account which is a (svc_forward) source!"
609 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
611 return "Can't delete an account which is a (svc_forward) destination!"
612 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
614 return "Can't delete an account with (svc_www) web service!"
615 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
617 # what about records in session ? (they should refer to history table)
619 local $SIG{HUP} = 'IGNORE';
620 local $SIG{INT} = 'IGNORE';
621 local $SIG{QUIT} = 'IGNORE';
622 local $SIG{TERM} = 'IGNORE';
623 local $SIG{TSTP} = 'IGNORE';
624 local $SIG{PIPE} = 'IGNORE';
626 my $oldAutoCommit = $FS::UID::AutoCommit;
627 local $FS::UID::AutoCommit = 0;
630 foreach my $cust_main_invoice (
631 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
633 unless ( defined($cust_main_invoice) ) {
634 warn "WARNING: something's wrong with qsearch";
637 my %hash = $cust_main_invoice->hash;
638 $hash{'dest'} = $self->email;
639 my $new = new FS::cust_main_invoice \%hash;
640 my $error = $new->replace($cust_main_invoice);
642 $dbh->rollback if $oldAutoCommit;
647 foreach my $svc_domain (
648 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
650 my %hash = new FS::svc_domain->hash;
651 $hash{'catchall'} = '';
652 my $new = new FS::svc_domain \%hash;
653 my $error = $new->replace($svc_domain);
655 $dbh->rollback if $oldAutoCommit;
660 my $error = $self->SUPER::delete;
662 $dbh->rollback if $oldAutoCommit;
666 foreach my $radius_usergroup (
667 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
669 my $error = $radius_usergroup->delete;
671 $dbh->rollback if $oldAutoCommit;
676 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
680 =item replace OLD_RECORD
682 Replaces OLD_RECORD with this one in the database. If there is an error,
683 returns the error, otherwise returns false.
685 The additional field I<usergroup> can optionally be defined; if so it should
686 contain an arrayref of group names. See L<FS::radius_usergroup>.
692 my ( $new, $old ) = ( shift, shift );
694 warn "$me replacing $old with $new\n" if $DEBUG;
696 # We absolutely have to have an old vs. new record to make this work.
697 if (!defined($old)) {
698 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
701 return "can't modify system account" if $old->_check_system;
704 #no warnings 'numeric'; #alas, a 5.006-ism
707 foreach my $xid (qw( uid gid )) {
709 return "Can't change $xid!"
710 if ! $conf->exists("svc_acct-edit_$xid")
711 && $old->$xid() != $new->$xid()
712 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
717 #change homdir when we change username
718 $new->setfield('dir', '') if $old->username ne $new->username;
720 local $SIG{HUP} = 'IGNORE';
721 local $SIG{INT} = 'IGNORE';
722 local $SIG{QUIT} = 'IGNORE';
723 local $SIG{TERM} = 'IGNORE';
724 local $SIG{TSTP} = 'IGNORE';
725 local $SIG{PIPE} = 'IGNORE';
727 my $oldAutoCommit = $FS::UID::AutoCommit;
728 local $FS::UID::AutoCommit = 0;
731 # redundant, but so $new->usergroup gets set
732 $error = $new->check;
733 return $error if $error;
735 $old->usergroup( [ $old->radius_groups ] );
737 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
738 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
740 if ( $new->usergroup ) {
741 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
742 my @newgroups = @{$new->usergroup};
743 foreach my $oldgroup ( @{$old->usergroup} ) {
744 if ( grep { $oldgroup eq $_ } @newgroups ) {
745 @newgroups = grep { $oldgroup ne $_ } @newgroups;
748 my $radius_usergroup = qsearchs('radius_usergroup', {
749 svcnum => $old->svcnum,
750 groupname => $oldgroup,
752 my $error = $radius_usergroup->delete;
754 $dbh->rollback if $oldAutoCommit;
755 return "error deleting radius_usergroup $oldgroup: $error";
759 foreach my $newgroup ( @newgroups ) {
760 my $radius_usergroup = new FS::radius_usergroup ( {
761 svcnum => $new->svcnum,
762 groupname => $newgroup,
764 my $error = $radius_usergroup->insert;
766 $dbh->rollback if $oldAutoCommit;
767 return "error adding radius_usergroup $newgroup: $error";
773 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
774 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
775 $error = $new->_check_duplicate;
777 $dbh->rollback if $oldAutoCommit;
782 $error = $new->SUPER::replace($old);
784 $dbh->rollback if $oldAutoCommit;
785 return $error if $error;
788 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
789 $error = $new->queue_fuzzyfiles_update;
791 $dbh->rollback if $oldAutoCommit;
792 return "updating fuzzy search cache: $error";
796 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
800 =item queue_fuzzyfiles_update
802 Used by insert & replace to update the fuzzy search cache
806 sub queue_fuzzyfiles_update {
809 local $SIG{HUP} = 'IGNORE';
810 local $SIG{INT} = 'IGNORE';
811 local $SIG{QUIT} = 'IGNORE';
812 local $SIG{TERM} = 'IGNORE';
813 local $SIG{TSTP} = 'IGNORE';
814 local $SIG{PIPE} = 'IGNORE';
816 my $oldAutoCommit = $FS::UID::AutoCommit;
817 local $FS::UID::AutoCommit = 0;
820 my $queue = new FS::queue {
821 'svcnum' => $self->svcnum,
822 'job' => 'FS::svc_acct::append_fuzzyfiles'
824 my $error = $queue->insert($self->username);
826 $dbh->rollback if $oldAutoCommit;
827 return "queueing job (transaction rolled back): $error";
830 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
838 Suspends this account by calling export-specific suspend hooks. If there is
839 an error, returns the error, otherwise returns false.
841 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
847 return "can't suspend system account" if $self->_check_system;
848 $self->SUPER::suspend;
853 Unsuspends this account by by calling export-specific suspend hooks. If there
854 is an error, returns the error, otherwise returns false.
856 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
862 my %hash = $self->hash;
863 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
864 $hash{_password} = $1;
865 my $new = new FS::svc_acct ( \%hash );
866 my $error = $new->replace($self);
867 return $error if $error;
870 $self->SUPER::unsuspend;
875 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
877 If the B<auto_unset_catchall> configuration option is set, this method will
878 automatically remove any references to the canceled service in the catchall
879 field of svc_domain. This allows packages that contain both a svc_domain and
880 its catchall svc_acct to be canceled in one step.
885 # Only one thing to do at this level
887 foreach my $svc_domain (
888 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
889 if($conf->exists('auto_unset_catchall')) {
890 my %hash = $svc_domain->hash;
891 $hash{catchall} = '';
892 my $new = new FS::svc_domain ( \%hash );
893 my $error = $new->replace($svc_domain);
894 return $error if $error;
896 return "cannot unprovision svc_acct #".$self->svcnum.
897 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
901 $self->SUPER::cancel;
907 Checks all fields to make sure this is a valid service. If there is an error,
908 returns the error, otherwise returns false. Called by the insert and replace
911 Sets any fixed values; see L<FS::part_svc>.
918 my($recref) = $self->hashref;
920 my $x = $self->setfixed( $self->_fieldhandlers );
921 return $x unless ref($x);
924 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
926 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
929 my $error = $self->ut_numbern('svcnum')
930 #|| $self->ut_number('domsvc')
931 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
932 || $self->ut_textn('sec_phrase')
933 || $self->ut_snumbern('seconds')
934 || $self->ut_snumbern('upbytes')
935 || $self->ut_snumbern('downbytes')
936 || $self->ut_snumbern('totalbytes')
937 || $self->ut_enum( '_password_encoding',
938 [ '', qw( plain crypt ldap ) ]
941 return $error if $error;
943 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
944 if ( $username_uppercase ) {
945 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
946 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
947 $recref->{username} = $1;
949 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
950 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
951 $recref->{username} = $1;
954 if ( $username_letterfirst ) {
955 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
956 } elsif ( $username_letter ) {
957 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
959 if ( $username_noperiod ) {
960 $recref->{username} =~ /\./ and return gettext('illegal_username');
962 if ( $username_nounderscore ) {
963 $recref->{username} =~ /_/ and return gettext('illegal_username');
965 if ( $username_nodash ) {
966 $recref->{username} =~ /\-/ and return gettext('illegal_username');
968 unless ( $username_ampersand ) {
969 $recref->{username} =~ /\&/ and return gettext('illegal_username');
971 unless ( $username_percent ) {
972 $recref->{username} =~ /\%/ and return gettext('illegal_username');
975 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
976 $recref->{popnum} = $1;
977 return "Unknown popnum" unless
978 ! $recref->{popnum} ||
979 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
981 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
983 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
984 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
986 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
987 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
988 #not all systems use gid=uid
989 #you can set a fixed gid in part_svc
991 return "Only root can have uid 0"
992 if $recref->{uid} == 0
993 && $recref->{username} !~ /^(root|toor|smtp)$/;
995 unless ( $recref->{username} eq 'sync' ) {
996 if ( grep $_ eq $recref->{shell}, @shells ) {
997 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
999 return "Illegal shell \`". $self->shell. "\'; ".
1000 "shells configuration value contains: @shells";
1003 $recref->{shell} = '/bin/sync';
1007 $recref->{gid} ne '' ?
1008 return "Can't have gid without uid" : ( $recref->{gid}='' );
1009 #$recref->{dir} ne '' ?
1010 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1011 $recref->{shell} ne '' ?
1012 return "Can't have shell without uid" : ( $recref->{shell}='' );
1015 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1017 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1018 or return "Illegal directory: ". $recref->{dir};
1019 $recref->{dir} = $1;
1020 return "Illegal directory"
1021 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1022 return "Illegal directory"
1023 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1024 unless ( $recref->{dir} ) {
1025 $recref->{dir} = $dir_prefix . '/';
1026 if ( $dirhash > 0 ) {
1027 for my $h ( 1 .. $dirhash ) {
1028 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1030 } elsif ( $dirhash < 0 ) {
1031 for my $h ( reverse $dirhash .. -1 ) {
1032 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1035 $recref->{dir} .= $recref->{username};
1041 # $error = $self->ut_textn('finger');
1042 # return $error if $error;
1043 if ( $self->getfield('finger') eq '' ) {
1044 my $cust_pkg = $self->svcnum
1045 ? $self->cust_svc->cust_pkg
1046 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1048 my $cust_main = $cust_pkg->cust_main;
1049 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1052 $self->getfield('finger') =~
1053 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1054 or return "Illegal finger: ". $self->getfield('finger');
1055 $self->setfield('finger', $1);
1057 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1058 $recref->{quota} = $1;
1060 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1061 if ( $recref->{slipip} eq '' ) {
1062 $recref->{slipip} = '';
1063 } elsif ( $recref->{slipip} eq '0e0' ) {
1064 $recref->{slipip} = '0e0';
1066 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1067 or return "Illegal slipip: ". $self->slipip;
1068 $recref->{slipip} = $1;
1073 #arbitrary RADIUS stuff; allow ut_textn for now
1074 foreach ( grep /^radius_/, fields('svc_acct') ) {
1075 $self->ut_textn($_);
1078 if ( $recref->{_password_encoding} eq 'ldap' ) {
1080 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1081 $recref->{_password} = uc($1).$2;
1083 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1086 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1088 if ( $recref->{_password} =~
1089 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1090 /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1093 $recref->{_password} = $1.$2;
1096 return 'Illegal (crypt-encoded) password';
1099 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1101 #generate a password if it is blank
1102 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1103 unless length( $recref->{_password} );
1105 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1106 $recref->{_password} = $1;
1108 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1109 FS::Msgcat::_gettext('illegal_password_characters').
1110 ": ". $recref->{_password};
1113 if ( $password_noampersand ) {
1114 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1116 if ( $password_noexclamation ) {
1117 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1122 #carp "warning: _password_encoding unspecified\n";
1124 #generate a password if it is blank
1125 unless ( length( $recref->{_password} ) ) {
1127 $recref->{_password} =
1128 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1129 $recref->{_password_encoding} = 'plain';
1133 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1134 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1135 $recref->{_password} = $1.$3;
1136 $recref->{_password_encoding} = 'plain';
1137 } elsif ( $recref->{_password} =~
1138 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1140 $recref->{_password} = $1.$3;
1141 $recref->{_password_encoding} = 'crypt';
1142 } elsif ( $recref->{_password} eq '*' ) {
1143 $recref->{_password} = '*';
1144 $recref->{_password_encoding} = 'crypt';
1145 } elsif ( $recref->{_password} eq '!' ) {
1146 $recref->{_password_encoding} = 'crypt';
1147 $recref->{_password} = '!';
1148 } elsif ( $recref->{_password} eq '!!' ) {
1149 $recref->{_password} = '!!';
1150 $recref->{_password_encoding} = 'crypt';
1152 #return "Illegal password";
1153 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1154 FS::Msgcat::_gettext('illegal_password_characters').
1155 ": ". $recref->{_password};
1162 $self->SUPER::check;
1168 Internal function to check the username against the list of system usernames
1169 from the I<system_usernames> configuration value. Returns true if the username
1170 is listed on the system username list.
1176 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1177 $conf->config('system_usernames')
1181 =item _check_duplicate
1183 Internal function to check for duplicates usernames, username@domain pairs and
1186 If the I<global_unique-username> configuration value is set to B<username> or
1187 B<username@domain>, enforces global username or username@domain uniqueness.
1189 In all cases, check for duplicate uids and usernames or username@domain pairs
1190 per export and with identical I<svcpart> values.
1194 sub _check_duplicate {
1197 my $global_unique = $conf->config('global_unique-username') || 'none';
1198 return '' if $global_unique eq 'disabled';
1200 #this is Pg-specific. what to do for mysql etc?
1201 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
1202 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1203 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1205 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1207 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1208 unless ( $part_svc ) {
1209 return 'unknown svcpart '. $self->svcpart;
1212 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1213 qsearch( 'svc_acct', { 'username' => $self->username } );
1214 return gettext('username_in_use')
1215 if $global_unique eq 'username' && @dup_user;
1217 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1218 qsearch( 'svc_acct', { 'username' => $self->username,
1219 'domsvc' => $self->domsvc } );
1220 return gettext('username_in_use')
1221 if $global_unique eq 'username@domain' && @dup_userdomain;
1224 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1225 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1226 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1227 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1232 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1233 my $exports = FS::part_export::export_info('svc_acct');
1234 my %conflict_user_svcpart;
1235 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1237 foreach my $part_export ( $part_svc->part_export ) {
1239 #this will catch to the same exact export
1240 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1242 #this will catch to exports w/same exporthost+type ???
1243 #my @other_part_export = qsearch('part_export', {
1244 # 'machine' => $part_export->machine,
1245 # 'exporttype' => $part_export->exporttype,
1247 #foreach my $other_part_export ( @other_part_export ) {
1248 # push @svcparts, map { $_->svcpart }
1249 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1252 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1253 #silly kludge to avoid uninitialized value errors
1254 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1255 ? $exports->{$part_export->exporttype}{'nodomain'}
1257 if ( $nodomain =~ /^Y/i ) {
1258 $conflict_user_svcpart{$_} = $part_export->exportnum
1261 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1266 foreach my $dup_user ( @dup_user ) {
1267 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1268 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1269 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1270 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1274 foreach my $dup_userdomain ( @dup_userdomain ) {
1275 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1276 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1277 return "duplicate username\@domain: conflicts with svcnum ".
1278 $dup_userdomain->svcnum. " via exportnum ".
1279 $conflict_userdomain_svcpart{$dup_svcpart};
1283 foreach my $dup_uid ( @dup_uid ) {
1284 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1285 if ( exists($conflict_user_svcpart{$dup_svcpart})
1286 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1287 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1288 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1289 || $conflict_userdomain_svcpart{$dup_svcpart};
1301 Depriciated, use radius_reply instead.
1306 carp "FS::svc_acct::radius depriciated, use radius_reply";
1307 $_[0]->radius_reply;
1312 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1313 reply attributes of this record.
1315 Note that this is now the preferred method for reading RADIUS attributes -
1316 accessing the columns directly is discouraged, as the column names are
1317 expected to change in the future.
1324 return %{ $self->{'radius_reply'} }
1325 if exists $self->{'radius_reply'};
1330 my($column, $attrib) = ($1, $2);
1331 #$attrib =~ s/_/\-/g;
1332 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1333 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1335 if ( $self->slipip && $self->slipip ne '0e0' ) {
1336 $reply{$radius_ip} = $self->slipip;
1339 if ( $self->seconds !~ /^$/ ) {
1340 $reply{'Session-Timeout'} = $self->seconds;
1348 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1349 check attributes of this record.
1351 Note that this is now the preferred method for reading RADIUS attributes -
1352 accessing the columns directly is discouraged, as the column names are
1353 expected to change in the future.
1360 return %{ $self->{'radius_check'} }
1361 if exists $self->{'radius_check'};
1366 my($column, $attrib) = ($1, $2);
1367 #$attrib =~ s/_/\-/g;
1368 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1369 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1371 my $password = $self->_password;
1372 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1374 my $cust_svc = $self->cust_svc;
1375 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1377 my $cust_pkg = $cust_svc->cust_pkg;
1378 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1379 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1388 This method instructs the object to "snapshot" or freeze RADIUS check and
1389 reply attributes to the current values.
1393 #bah, my english is too broken this morning
1394 #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
1395 #the FS::cust_pkg's replace method to trigger the correct export updates when
1396 #package dates change)
1401 $self->{$_} = { $self->$_() }
1402 foreach qw( radius_reply radius_check );
1406 =item forget_snapshot
1408 This methos instructs the object to forget any previously snapshotted
1409 RADIUS check and reply attributes.
1413 sub forget_snapshot {
1417 foreach qw( radius_reply radius_check );
1421 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1423 Returns the domain associated with this account.
1425 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1432 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1433 my $svc_domain = $self->svc_domain(@_)
1434 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1435 $svc_domain->domain;
1440 Returns the FS::svc_domain record for this account's domain (see
1445 # FS::h_svc_acct has a history-aware svc_domain override
1450 ? $self->{'_domsvc'}
1451 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1456 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1460 #inherited from svc_Common
1462 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1464 Returns an email address associated with the account.
1466 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1473 $self->username. '@'. $self->domain(@_);
1478 Returns an array of FS::acct_snarf records associated with the account.
1479 If the acct_snarf table does not exist or there are no associated records,
1480 an empty list is returned
1486 return () unless dbdef->table('acct_snarf');
1487 eval "use FS::acct_snarf;";
1489 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1492 =item decrement_upbytes OCTETS
1494 Decrements the I<upbytes> field of this record by the given amount. If there
1495 is an error, returns the error, otherwise returns false.
1499 sub decrement_upbytes {
1500 shift->_op_usage('-', 'upbytes', @_);
1503 =item increment_upbytes OCTETS
1505 Increments the I<upbytes> field of this record by the given amount. If there
1506 is an error, returns the error, otherwise returns false.
1510 sub increment_upbytes {
1511 shift->_op_usage('+', 'upbytes', @_);
1514 =item decrement_downbytes OCTETS
1516 Decrements the I<downbytes> field of this record by the given amount. If there
1517 is an error, returns the error, otherwise returns false.
1521 sub decrement_downbytes {
1522 shift->_op_usage('-', 'downbytes', @_);
1525 =item increment_downbytes OCTETS
1527 Increments the I<downbytes> field of this record by the given amount. If there
1528 is an error, returns the error, otherwise returns false.
1532 sub increment_downbytes {
1533 shift->_op_usage('+', 'downbytes', @_);
1536 =item decrement_totalbytes OCTETS
1538 Decrements the I<totalbytes> field of this record by the given amount. If there
1539 is an error, returns the error, otherwise returns false.
1543 sub decrement_totalbytes {
1544 shift->_op_usage('-', 'totalbytes', @_);
1547 =item increment_totalbytes OCTETS
1549 Increments the I<totalbytes> field of this record by the given amount. If there
1550 is an error, returns the error, otherwise returns false.
1554 sub increment_totalbytes {
1555 shift->_op_usage('+', 'totalbytes', @_);
1558 =item decrement_seconds SECONDS
1560 Decrements the I<seconds> field of this record by the given amount. If there
1561 is an error, returns the error, otherwise returns false.
1565 sub decrement_seconds {
1566 shift->_op_usage('-', 'seconds', @_);
1569 =item increment_seconds SECONDS
1571 Increments the I<seconds> field of this record by the given amount. If there
1572 is an error, returns the error, otherwise returns false.
1576 sub increment_seconds {
1577 shift->_op_usage('+', 'seconds', @_);
1585 my %op2condition = (
1586 '-' => sub { my($self, $column, $amount) = @_;
1587 $self->$column - $amount <= 0;
1589 '+' => sub { my($self, $column, $amount) = @_;
1590 $self->$column + $amount > 0;
1593 my %op2warncondition = (
1594 '-' => sub { my($self, $column, $amount) = @_;
1595 my $threshold = $column . '_threshold';
1596 $self->$column - $amount <= $self->$threshold + 0;
1598 '+' => sub { my($self, $column, $amount) = @_;
1599 $self->$column + $amount > 0;
1604 my( $self, $op, $column, $amount ) = @_;
1606 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1607 ' ('. $self->email. "): $op $amount\n"
1610 return '' unless $amount;
1612 local $SIG{HUP} = 'IGNORE';
1613 local $SIG{INT} = 'IGNORE';
1614 local $SIG{QUIT} = 'IGNORE';
1615 local $SIG{TERM} = 'IGNORE';
1616 local $SIG{TSTP} = 'IGNORE';
1617 local $SIG{PIPE} = 'IGNORE';
1619 my $oldAutoCommit = $FS::UID::AutoCommit;
1620 local $FS::UID::AutoCommit = 0;
1623 my $sql = "UPDATE svc_acct SET $column = ".
1624 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1625 " $op ? WHERE svcnum = ?";
1629 my $sth = $dbh->prepare( $sql )
1630 or die "Error preparing $sql: ". $dbh->errstr;
1631 my $rv = $sth->execute($amount, $self->svcnum);
1632 die "Error executing $sql: ". $sth->errstr
1633 unless defined($rv);
1634 die "Can't update $column for svcnum". $self->svcnum
1637 my $action = $op2action{$op};
1639 if ( &{$op2condition{$op}}($self, $column, $amount) ) {
1640 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1641 if ($part_export->option('overlimit_groups')) {
1643 my $other = new FS::svc_acct $self->hashref;
1644 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1645 ($self, $part_export->option('overlimit_groups'));
1646 $other->usergroup( $groups );
1647 if ($action eq 'suspend'){
1648 $new = $other; $old = $self;
1650 $new = $self; $old = $other;
1652 my $error = $part_export->export_replace($new, $old);
1653 $error ||= $self->overlimit($action);
1655 $dbh->rollback if $oldAutoCommit;
1656 return "Error replacing radius groups in export, ${op}: $error";
1662 if ( $conf->exists("svc_acct-usage_$action")
1663 && &{$op2condition{$op}}($self, $column, $amount) ) {
1664 #my $error = $self->$action();
1665 my $error = $self->cust_svc->cust_pkg->$action();
1666 $error ||= $self->overlimit($action);
1668 $dbh->rollback if $oldAutoCommit;
1669 return "Error ${action}ing: $error";
1673 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1674 my $wqueue = new FS::queue {
1675 'svcnum' => $self->svcnum,
1676 'job' => 'FS::svc_acct::reached_threshold',
1681 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1685 my $error = $wqueue->insert(
1686 'svcnum' => $self->svcnum,
1688 'column' => $column,
1692 $dbh->rollback if $oldAutoCommit;
1693 return "Error queuing threshold activity: $error";
1697 warn "$me update successful; committing\n"
1699 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1705 my( $self, $valueref ) = @_;
1707 warn "$me set_usage called for svcnum ". $self->svcnum.
1708 ' ('. $self->email. "): ".
1709 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1712 local $SIG{HUP} = 'IGNORE';
1713 local $SIG{INT} = 'IGNORE';
1714 local $SIG{QUIT} = 'IGNORE';
1715 local $SIG{TERM} = 'IGNORE';
1716 local $SIG{TSTP} = 'IGNORE';
1717 local $SIG{PIPE} = 'IGNORE';
1719 local $FS::svc_Common::noexport_hack = 1;
1720 my $oldAutoCommit = $FS::UID::AutoCommit;
1721 local $FS::UID::AutoCommit = 0;
1726 foreach my $field (keys %$valueref){
1727 $reset = 1 if $valueref->{$field};
1728 $self->setfield($field, $valueref->{$field});
1729 $self->setfield( $field.'_threshold',
1730 int($self->getfield($field)
1731 * ( $conf->exists('svc_acct-usage_threshold')
1732 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1737 $handyhash{$field} = $self->getfield($field);
1738 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1740 #my $error = $self->replace; #NO! we avoid the call to ->check for
1741 #die $error if $error; #services not explicity changed via the UI
1743 my $sql = "UPDATE svc_acct SET " .
1744 join (',', map { "$_ = ?" } (keys %handyhash) ).
1745 " WHERE svcnum = ?";
1750 if (scalar(keys %handyhash)) {
1751 my $sth = $dbh->prepare( $sql )
1752 or die "Error preparing $sql: ". $dbh->errstr;
1753 my $rv = $sth->execute((grep{$_} values %handyhash), $self->svcnum);
1754 die "Error executing $sql: ". $sth->errstr
1755 unless defined($rv);
1756 die "Can't update usage for svcnum ". $self->svcnum
1761 my $error = $self->overlimit('unsuspend');
1763 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1764 if ($part_export->option('overlimit_groups')) {
1765 my $old = new FS::svc_acct $self->hashref;
1766 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1767 ($self, $part_export->option('overlimit_groups'));
1768 $old->usergroup( $groups );
1769 $error ||= $part_export->export_replace($self, $old);
1773 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1774 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1777 $dbh->rollback if $oldAutoCommit;
1778 return "Error unsuspending: $error";
1782 warn "$me update successful; committing\n"
1784 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1790 =item recharge HASHREF
1792 Increments usage columns by the amount specified in HASHREF as
1793 column=>amount pairs.
1798 my ($self, $vhash) = @_;
1801 warn "[$me] recharge called on $self: ". Dumper($self).
1802 "\nwith vhash: ". Dumper($vhash);
1805 my $oldAutoCommit = $FS::UID::AutoCommit;
1806 local $FS::UID::AutoCommit = 0;
1810 foreach my $column (keys %$vhash){
1811 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1815 $dbh->rollback if $oldAutoCommit;
1817 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1822 =item is_rechargeable
1824 Returns true if this svc_account can be "recharged" and false otherwise.
1828 sub is_rechargable {
1830 $self->seconds ne ''
1831 || $self->upbytes ne ''
1832 || $self->downbytes ne ''
1833 || $self->totalbytes ne '';
1836 =item seconds_since TIMESTAMP
1838 Returns the number of seconds this account has been online since TIMESTAMP,
1839 according to the session monitor (see L<FS::Session>).
1841 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1842 L<Time::Local> and L<Date::Parse> for conversion functions.
1846 #note: POD here, implementation in FS::cust_svc
1849 $self->cust_svc->seconds_since(@_);
1852 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1854 Returns the numbers of seconds this account has been online between
1855 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1856 external SQL radacct table, specified via sqlradius export. Sessions which
1857 started in the specified range but are still open are counted from session
1858 start to the end of the range (unless they are over 1 day old, in which case
1859 they are presumed missing their stop record and not counted). Also, sessions
1860 which end in the range but started earlier are counted from the start of the
1861 range to session end. Finally, sessions which start before the range but end
1862 after are counted for the entire range.
1864 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1865 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1870 #note: POD here, implementation in FS::cust_svc
1871 sub seconds_since_sqlradacct {
1873 $self->cust_svc->seconds_since_sqlradacct(@_);
1876 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1878 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1879 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1880 TIMESTAMP_END (exclusive).
1882 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1883 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1888 #note: POD here, implementation in FS::cust_svc
1889 sub attribute_since_sqlradacct {
1891 $self->cust_svc->attribute_since_sqlradacct(@_);
1894 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1896 Returns an array of hash references of this customers login history for the
1897 given time range. (document this better)
1901 sub get_session_history {
1903 $self->cust_svc->get_session_history(@_);
1906 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1911 my($self, $start, $end, %opt ) = @_;
1913 my $did = $self->username; #yup
1915 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1917 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1919 #SELECT $for_update * FROM cdr
1920 # WHERE calldate >= $start #need a conversion
1921 # AND calldate < $end #ditto
1922 # AND ( charged_party = "$did"
1923 # OR charged_party = "$prefix$did" #if length($prefix);
1924 # OR ( ( charged_party IS NULL OR charged_party = '' )
1926 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1929 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1932 if ( length($prefix) ) {
1934 " AND ( charged_party = '$did'
1935 OR charged_party = '$prefix$did'
1936 OR ( ( charged_party IS NULL OR charged_party = '' )
1938 ( src = '$did' OR src = '$prefix$did' )
1944 " AND ( charged_party = '$did'
1945 OR ( ( charged_party IS NULL OR charged_party = '' )
1955 'select' => "$for_update *",
1958 #( freesidestatus IS NULL OR freesidestatus = '' )
1959 'freesidestatus' => '',
1961 'extra_sql' => $charged_or_src,
1969 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1975 if ( $self->usergroup ) {
1976 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1977 unless ref($self->usergroup) eq 'ARRAY';
1978 #when provisioning records, export callback runs in svc_Common.pm before
1979 #radius_usergroup records can be inserted...
1980 @{$self->usergroup};
1982 map { $_->groupname }
1983 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1987 =item clone_suspended
1989 Constructor used by FS::part_export::_export_suspend fallback. Document
1994 sub clone_suspended {
1996 my %hash = $self->hash;
1997 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1998 new FS::svc_acct \%hash;
2001 =item clone_kludge_unsuspend
2003 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2008 sub clone_kludge_unsuspend {
2010 my %hash = $self->hash;
2011 $hash{_password} = '';
2012 new FS::svc_acct \%hash;
2015 =item check_password
2017 Checks the supplied password against the (possibly encrypted) password in the
2018 database. Returns true for a successful authentication, false for no match.
2020 Currently supported encryptions are: classic DES crypt() and MD5
2024 sub check_password {
2025 my($self, $check_password) = @_;
2027 #remove old-style SUSPENDED kludge, they should be allowed to login to
2028 #self-service and pay up
2029 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2031 if ( $self->_password_encoding eq 'ldap' ) {
2033 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2034 return $auth->match($check_password);
2036 } elsif ( $self->_password_encoding eq 'crypt' ) {
2038 my $auth = from_crypt Authen::Passphrase $self->_password;
2039 return $auth->match($check_password);
2041 } elsif ( $self->_password_encoding eq 'plain' ) {
2043 return $check_password eq $password;
2047 #XXX this could be replaced with Authen::Passphrase stuff
2049 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2051 } elsif ( length($password) < 13 ) { #plaintext
2052 $check_password eq $password;
2053 } elsif ( length($password) == 13 ) { #traditional DES crypt
2054 crypt($check_password, $password) eq $password;
2055 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2056 unix_md5_crypt($check_password, $password) eq $password;
2057 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2058 warn "Can't check password: Blowfish encryption not yet supported, ".
2059 "svcnum ". $self->svcnum. "\n";
2062 warn "Can't check password: Unrecognized encryption for svcnum ".
2063 $self->svcnum. "\n";
2071 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2073 Returns an encrypted password, either by passing through an encrypted password
2074 in the database or by encrypting a plaintext password from the database.
2076 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2077 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2078 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2079 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2080 encryption type is only used if the password is not already encrypted in the
2085 sub crypt_password {
2088 if ( $self->_password_encoding eq 'ldap' ) {
2090 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2093 #XXX this could be replaced with Authen::Passphrase stuff
2095 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2096 if ( $encryption eq 'crypt' ) {
2099 $saltset[int(rand(64))].$saltset[int(rand(64))]
2101 } elsif ( $encryption eq 'md5' ) {
2102 unix_md5_crypt( $self->_password );
2103 } elsif ( $encryption eq 'blowfish' ) {
2104 croak "unknown encryption method $encryption";
2106 croak "unknown encryption method $encryption";
2109 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2113 } elsif ( $self->_password_encoding eq 'crypt' ) {
2115 return $self->_password;
2117 } elsif ( $self->_password_encoding eq 'plain' ) {
2119 #XXX this could be replaced with Authen::Passphrase stuff
2121 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2122 if ( $encryption eq 'crypt' ) {
2125 $saltset[int(rand(64))].$saltset[int(rand(64))]
2127 } elsif ( $encryption eq 'md5' ) {
2128 unix_md5_crypt( $self->_password );
2129 } elsif ( $encryption eq 'blowfish' ) {
2130 croak "unknown encryption method $encryption";
2132 croak "unknown encryption method $encryption";
2137 if ( length($self->_password) == 13
2138 || $self->_password =~ /^\$(1|2a?)\$/
2139 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2145 #XXX this could be replaced with Authen::Passphrase stuff
2147 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2148 if ( $encryption eq 'crypt' ) {
2151 $saltset[int(rand(64))].$saltset[int(rand(64))]
2153 } elsif ( $encryption eq 'md5' ) {
2154 unix_md5_crypt( $self->_password );
2155 } elsif ( $encryption eq 'blowfish' ) {
2156 croak "unknown encryption method $encryption";
2158 croak "unknown encryption method $encryption";
2167 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2169 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2170 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2171 "{MD5}5426824942db4253f87a1009fd5d2d4".
2173 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2174 to work the same as the B</crypt_password> method.
2180 #eventually should check a "password-encoding" field
2182 if ( $self->_password_encoding eq 'ldap' ) {
2184 return $self->_password;
2186 } elsif ( $self->_password_encoding eq 'crypt' ) {
2188 if ( length($self->_password) == 13 ) { #crypt
2189 return '{CRYPT}'. $self->_password;
2190 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2192 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2193 # die "Blowfish encryption not supported in this context, svcnum ".
2194 # $self->svcnum. "\n";
2196 warn "encryption method not (yet?) supported in LDAP context";
2197 return '{CRYPT}*'; #unsupported, should not auth
2200 } elsif ( $self->_password_encoding eq 'plain' ) {
2202 return '{PLAIN}'. $self->_password;
2204 #return '{CLEARTEXT}'. $self->_password; #?
2208 if ( length($self->_password) == 13 ) { #crypt
2209 return '{CRYPT}'. $self->_password;
2210 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2212 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2213 warn "Blowfish encryption not supported in this context, svcnum ".
2214 $self->svcnum. "\n";
2217 #are these two necessary anymore?
2218 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2219 return '{SSHA}'. $1;
2220 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2221 return '{NS-MTA-MD5}'. $1;
2224 return '{PLAIN}'. $self->_password;
2226 #return '{CLEARTEXT}'. $self->_password; #?
2228 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2229 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2230 #if ( $encryption eq 'crypt' ) {
2231 # return '{CRYPT}'. crypt(
2233 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2235 #} elsif ( $encryption eq 'md5' ) {
2236 # unix_md5_crypt( $self->_password );
2237 #} elsif ( $encryption eq 'blowfish' ) {
2238 # croak "unknown encryption method $encryption";
2240 # croak "unknown encryption method $encryption";
2248 =item domain_slash_username
2250 Returns $domain/$username/
2254 sub domain_slash_username {
2256 $self->domain. '/'. $self->username. '/';
2259 =item virtual_maildir
2261 Returns $domain/maildirs/$username/
2265 sub virtual_maildir {
2267 $self->domain. '/maildirs/'. $self->username. '/';
2278 This is the FS::svc_acct job-queue-able version. It still uses
2279 FS::Misc::send_email under-the-hood.
2286 eval "use FS::Misc qw(send_email)";
2289 $opt{mimetype} ||= 'text/plain';
2290 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2292 my $error = send_email(
2293 'from' => $opt{from},
2295 'subject' => $opt{subject},
2296 'content-type' => $opt{mimetype},
2297 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2299 die $error if $error;
2302 =item check_and_rebuild_fuzzyfiles
2306 sub check_and_rebuild_fuzzyfiles {
2307 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2308 -e "$dir/svc_acct.username"
2309 or &rebuild_fuzzyfiles;
2312 =item rebuild_fuzzyfiles
2316 sub rebuild_fuzzyfiles {
2318 use Fcntl qw(:flock);
2320 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2324 open(USERNAMELOCK,">>$dir/svc_acct.username")
2325 or die "can't open $dir/svc_acct.username: $!";
2326 flock(USERNAMELOCK,LOCK_EX)
2327 or die "can't lock $dir/svc_acct.username: $!";
2329 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2331 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2332 or die "can't open $dir/svc_acct.username.tmp: $!";
2333 print USERNAMECACHE join("\n", @all_username), "\n";
2334 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2336 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2346 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2347 open(USERNAMECACHE,"<$dir/svc_acct.username")
2348 or die "can't open $dir/svc_acct.username: $!";
2349 my @array = map { chomp; $_; } <USERNAMECACHE>;
2350 close USERNAMECACHE;
2354 =item append_fuzzyfiles USERNAME
2358 sub append_fuzzyfiles {
2359 my $username = shift;
2361 &check_and_rebuild_fuzzyfiles;
2363 use Fcntl qw(:flock);
2365 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
2367 open(USERNAME,">>$dir/svc_acct.username")
2368 or die "can't open $dir/svc_acct.username: $!";
2369 flock(USERNAME,LOCK_EX)
2370 or die "can't lock $dir/svc_acct.username: $!";
2372 print USERNAME "$username\n";
2374 flock(USERNAME,LOCK_UN)
2375 or die "can't unlock $dir/svc_acct.username: $!";
2383 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2387 sub radius_usergroup_selector {
2388 my $sel_groups = shift;
2389 my %sel_groups = map { $_=>1 } @$sel_groups;
2391 my $selectname = shift || 'radius_usergroup';
2394 my $sth = $dbh->prepare(
2395 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2396 ) or die $dbh->errstr;
2397 $sth->execute() or die $sth->errstr;
2398 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2402 function ${selectname}_doadd(object) {
2403 var myvalue = object.${selectname}_add.value;
2404 var optionName = new Option(myvalue,myvalue,false,true);
2405 var length = object.$selectname.length;
2406 object.$selectname.options[length] = optionName;
2407 object.${selectname}_add.value = "";
2410 <SELECT MULTIPLE NAME="$selectname">
2413 foreach my $group ( @all_groups ) {
2414 $html .= qq(<OPTION VALUE="$group");
2415 if ( $sel_groups{$group} ) {
2416 $html .= ' SELECTED';
2417 $sel_groups{$group} = 0;
2419 $html .= ">$group</OPTION>\n";
2421 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2422 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2424 $html .= '</SELECT>';
2426 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2427 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2432 =item reached_threshold
2434 Performs some activities when svc_acct thresholds (such as number of seconds
2435 remaining) are reached.
2439 sub reached_threshold {
2442 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2443 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2445 if ( $opt{'op'} eq '+' ){
2446 $svc_acct->setfield( $opt{'column'}.'_threshold',
2447 int($svc_acct->getfield($opt{'column'})
2448 * ( $conf->exists('svc_acct-usage_threshold')
2449 ? $conf->config('svc_acct-usage_threshold')/100
2454 my $error = $svc_acct->replace;
2455 die $error if $error;
2456 }elsif ( $opt{'op'} eq '-' ){
2458 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2459 return '' if ($threshold eq '' );
2461 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2462 my $error = $svc_acct->replace;
2463 die $error if $error; # email next time, i guess
2465 if ( $warning_template ) {
2466 eval "use FS::Misc qw(send_email)";
2469 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2470 my $cust_main = $cust_pkg->cust_main;
2472 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2473 $cust_main->invoicing_list,
2474 ($opt{'to'} ? $opt{'to'} : ())
2477 my $mimetype = $warning_mimetype;
2478 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2480 my $body = $warning_template->fill_in( HASH => {
2481 'custnum' => $cust_main->custnum,
2482 'username' => $svc_acct->username,
2483 'password' => $svc_acct->_password,
2484 'first' => $cust_main->first,
2485 'last' => $cust_main->getfield('last'),
2486 'pkg' => $cust_pkg->part_pkg->pkg,
2487 'column' => $opt{'column'},
2488 'amount' => $opt{'column'} =~/bytes/
2489 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2490 : $svc_acct->getfield($opt{'column'}),
2491 'threshold' => $opt{'column'} =~/bytes/
2492 ? FS::UI::bytecount::display_bytecount($threshold)
2497 my $error = send_email(
2498 'from' => $warning_from,
2500 'subject' => $warning_subject,
2501 'content-type' => $mimetype,
2502 'body' => [ map "$_\n", split("\n", $body) ],
2504 die $error if $error;
2507 die "unknown op: " . $opt{'op'};
2515 The $recref stuff in sub check should be cleaned up.
2517 The suspend, unsuspend and cancel methods update the database, but not the
2518 current object. This is probably a bug as it's unexpected and
2521 radius_usergroup_selector? putting web ui components in here? they should
2522 probably live somewhere else...
2524 insertion of RADIUS group stuff in insert could be done with child_objects now
2525 (would probably clean up export of them too)
2529 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2530 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2531 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2532 L<freeside-queued>), L<FS::svc_acct_pop>,
2533 schema.html from the base documentation.