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
10 $password_noampersand $password_noexclamation
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
13 $radius_password $radius_ip
19 use FS::UID qw( datasrc );
21 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
26 use FS::cust_main_invoice;
30 use FS::radius_usergroup;
33 use FS::Msgcat qw(gettext);
37 @ISA = qw( FS::svc_Common );
41 $me = '[FS::svc_acct]';
43 #ask FS::UID to run this stuff for us later
44 $FS::UID::callback{'FS::svc_acct'} = sub {
46 $dir_prefix = $conf->config('home');
47 @shells = $conf->config('shells');
48 $usernamemin = $conf->config('usernamemin') || 2;
49 $usernamemax = $conf->config('usernamemax');
50 $passwordmin = $conf->config('passwordmin') || 6;
51 $passwordmax = $conf->config('passwordmax') || 8;
52 $username_letter = $conf->exists('username-letter');
53 $username_letterfirst = $conf->exists('username-letterfirst');
54 $username_noperiod = $conf->exists('username-noperiod');
55 $username_nounderscore = $conf->exists('username-nounderscore');
56 $username_nodash = $conf->exists('username-nodash');
57 $username_uppercase = $conf->exists('username-uppercase');
58 $username_ampersand = $conf->exists('username-ampersand');
59 $password_noampersand = $conf->exists('password-noexclamation');
60 $password_noexclamation = $conf->exists('password-noexclamation');
61 $dirhash = $conf->config('dirhash') || 0;
62 if ( $conf->exists('welcome_email') ) {
63 $welcome_template = new Text::Template (
65 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
66 ) or warn "can't create welcome email template: $Text::Template::ERROR";
67 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
68 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
69 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
71 $welcome_template = '';
73 $welcome_subject = '';
74 $welcome_mimetype = '';
76 $smtpmachine = $conf->config('smtpmachine');
77 $radius_password = $conf->config('radius-password') || 'Password';
78 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
81 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
82 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
86 my ( $hashref, $cache ) = @_;
87 if ( $hashref->{'svc_acct_svcnum'} ) {
88 $self->{'_domsvc'} = FS::svc_domain->new( {
89 'svcnum' => $hashref->{'domsvc'},
90 'domain' => $hashref->{'svc_acct_domain'},
91 'catchall' => $hashref->{'svc_acct_catchall'},
98 FS::svc_acct - Object methods for svc_acct records
104 $record = new FS::svc_acct \%hash;
105 $record = new FS::svc_acct { 'column' => 'value' };
107 $error = $record->insert;
109 $error = $new_record->replace($old_record);
111 $error = $record->delete;
113 $error = $record->check;
115 $error = $record->suspend;
117 $error = $record->unsuspend;
119 $error = $record->cancel;
121 %hash = $record->radius;
123 %hash = $record->radius_reply;
125 %hash = $record->radius_check;
127 $domain = $record->domain;
129 $svc_domain = $record->svc_domain;
131 $email = $record->email;
133 $seconds_since = $record->seconds_since($timestamp);
137 An FS::svc_acct object represents an account. FS::svc_acct inherits from
138 FS::svc_Common. The following fields are currently supported:
142 =item svcnum - primary key (assigned automatcially for new accounts)
146 =item _password - generated if blank
148 =item sec_phrase - security phrase
150 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
158 =item dir - set automatically if blank (and uid is not)
162 =item quota - (unimplementd)
164 =item slipip - IP address
168 =item domsvc - svcnum from svc_domain
170 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
172 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
182 Creates a new account. To add the account to the database, see L<"insert">.
186 sub table { 'svc_acct'; }
188 =item insert [ , OPTION => VALUE ... ]
190 Adds this account to the database. If there is an error, returns the error,
191 otherwise returns false.
193 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
194 defined. An FS::cust_svc record will be created and inserted.
196 The additional field I<usergroup> can optionally be defined; if so it should
197 contain an arrayref of group names. See L<FS::radius_usergroup>.
199 The additional field I<child_objects> can optionally be defined; if so it
200 should contain an arrayref of FS::tablename objects. They will have their
201 svcnum fields set and will be inserted after this record, but before any
202 exports are run. Each element of the array can also optionally be a
203 two-element array reference containing the child object and the name of an
204 alternate field to be filled in with the newly-inserted svcnum, for example
205 C<[ $svc_forward, 'srcsvc' ]>
207 Currently available options are: I<depend_jobnum>
209 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
210 jobnums), all provisioning jobs will have a dependancy on the supplied
211 jobnum(s) (they will not run until the specific job(s) complete(s)).
213 (TODOC: L<FS::queue> and L<freeside-queued>)
215 (TODOC: new exports!)
224 local $SIG{HUP} = 'IGNORE';
225 local $SIG{INT} = 'IGNORE';
226 local $SIG{QUIT} = 'IGNORE';
227 local $SIG{TERM} = 'IGNORE';
228 local $SIG{TSTP} = 'IGNORE';
229 local $SIG{PIPE} = 'IGNORE';
231 my $oldAutoCommit = $FS::UID::AutoCommit;
232 local $FS::UID::AutoCommit = 0;
235 $error = $self->check;
236 return $error if $error;
238 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
239 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
240 unless ( $cust_svc ) {
241 $dbh->rollback if $oldAutoCommit;
242 return "no cust_svc record found for svcnum ". $self->svcnum;
244 $self->pkgnum($cust_svc->pkgnum);
245 $self->svcpart($cust_svc->svcpart);
248 $error = $self->_check_duplicate;
250 $dbh->rollback if $oldAutoCommit;
255 $error = $self->SUPER::insert(
256 'jobnums' => \@jobnums,
257 'child_objects' => $self->child_objects,
261 $dbh->rollback if $oldAutoCommit;
265 if ( $self->usergroup ) {
266 foreach my $groupname ( @{$self->usergroup} ) {
267 my $radius_usergroup = new FS::radius_usergroup ( {
268 svcnum => $self->svcnum,
269 groupname => $groupname,
271 my $error = $radius_usergroup->insert;
273 $dbh->rollback if $oldAutoCommit;
279 unless ( $skip_fuzzyfiles ) {
280 $error = $self->queue_fuzzyfiles_update;
282 $dbh->rollback if $oldAutoCommit;
283 return "updating fuzzy search cache: $error";
287 my $cust_pkg = $self->cust_svc->cust_pkg;
290 my $cust_main = $cust_pkg->cust_main;
292 if ( $conf->exists('emailinvoiceauto') ) {
293 my @invoicing_list = $cust_main->invoicing_list;
294 push @invoicing_list, $self->email;
295 $cust_main->invoicing_list(\@invoicing_list);
300 if ( $welcome_template && $cust_pkg ) {
301 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
303 my $wqueue = new FS::queue {
304 'svcnum' => $self->svcnum,
305 'job' => 'FS::svc_acct::send_email'
307 my $error = $wqueue->insert(
309 'from' => $welcome_from,
310 'subject' => $welcome_subject,
311 'mimetype' => $welcome_mimetype,
312 'body' => $welcome_template->fill_in( HASH => {
313 'custnum' => $self->custnum,
314 'username' => $self->username,
315 'password' => $self->_password,
316 'first' => $cust_main->first,
317 'last' => $cust_main->getfield('last'),
318 'pkg' => $cust_pkg->part_pkg->pkg,
322 $dbh->rollback if $oldAutoCommit;
323 return "error queuing welcome email: $error";
326 if ( $options{'depend_jobnum'} ) {
327 warn "$me depend_jobnum found; adding to welcome email dependancies"
329 if ( ref($options{'depend_jobnum'}) ) {
330 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
331 "to welcome email dependancies"
333 push @jobnums, @{ $options{'depend_jobnum'} };
335 warn "$me adding job $options{'depend_jobnum'} ".
336 "to welcome email dependancies"
338 push @jobnums, $options{'depend_jobnum'};
342 foreach my $jobnum ( @jobnums ) {
343 my $error = $wqueue->depend_insert($jobnum);
345 $dbh->rollback if $oldAutoCommit;
346 return "error queuing welcome email job dependancy: $error";
356 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
362 Deletes this account from the database. If there is an error, returns the
363 error, otherwise returns false.
365 The corresponding FS::cust_svc record will be deleted as well.
367 (TODOC: new exports!)
374 return "can't delete system account" if $self->_check_system;
376 return "Can't delete an account which is a (svc_forward) source!"
377 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
379 return "Can't delete an account which is a (svc_forward) destination!"
380 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
382 return "Can't delete an account with (svc_www) web service!"
383 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
385 # what about records in session ? (they should refer to history table)
387 local $SIG{HUP} = 'IGNORE';
388 local $SIG{INT} = 'IGNORE';
389 local $SIG{QUIT} = 'IGNORE';
390 local $SIG{TERM} = 'IGNORE';
391 local $SIG{TSTP} = 'IGNORE';
392 local $SIG{PIPE} = 'IGNORE';
394 my $oldAutoCommit = $FS::UID::AutoCommit;
395 local $FS::UID::AutoCommit = 0;
398 foreach my $cust_main_invoice (
399 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
401 unless ( defined($cust_main_invoice) ) {
402 warn "WARNING: something's wrong with qsearch";
405 my %hash = $cust_main_invoice->hash;
406 $hash{'dest'} = $self->email;
407 my $new = new FS::cust_main_invoice \%hash;
408 my $error = $new->replace($cust_main_invoice);
410 $dbh->rollback if $oldAutoCommit;
415 foreach my $svc_domain (
416 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
418 my %hash = new FS::svc_domain->hash;
419 $hash{'catchall'} = '';
420 my $new = new FS::svc_domain \%hash;
421 my $error = $new->replace($svc_domain);
423 $dbh->rollback if $oldAutoCommit;
428 foreach my $radius_usergroup (
429 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
431 my $error = $radius_usergroup->delete;
433 $dbh->rollback if $oldAutoCommit;
438 my $error = $self->SUPER::delete;
440 $dbh->rollback if $oldAutoCommit;
444 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
448 =item replace OLD_RECORD
450 Replaces OLD_RECORD with this one in the database. If there is an error,
451 returns the error, otherwise returns false.
453 The additional field I<usergroup> can optionally be defined; if so it should
454 contain an arrayref of group names. See L<FS::radius_usergroup>.
460 my ( $new, $old ) = ( shift, shift );
462 warn "$me replacing $old with $new\n" if $DEBUG;
464 return "can't modify system account" if $old->_check_system;
466 return "Username in use"
467 if $old->username ne $new->username &&
468 qsearchs( 'svc_acct', { 'username' => $new->username,
469 'domsvc' => $new->domsvc,
472 #no warnings 'numeric'; #alas, a 5.006-ism
474 return "Can't change uid!" if $old->uid != $new->uid;
477 #change homdir when we change username
478 $new->setfield('dir', '') if $old->username ne $new->username;
480 local $SIG{HUP} = 'IGNORE';
481 local $SIG{INT} = 'IGNORE';
482 local $SIG{QUIT} = 'IGNORE';
483 local $SIG{TERM} = 'IGNORE';
484 local $SIG{TSTP} = 'IGNORE';
485 local $SIG{PIPE} = 'IGNORE';
487 my $oldAutoCommit = $FS::UID::AutoCommit;
488 local $FS::UID::AutoCommit = 0;
491 # redundant, but so $new->usergroup gets set
492 $error = $new->check;
493 return $error if $error;
495 $old->usergroup( [ $old->radius_groups ] );
496 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
497 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
498 if ( $new->usergroup ) {
499 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
500 my @newgroups = @{$new->usergroup};
501 foreach my $oldgroup ( @{$old->usergroup} ) {
502 if ( grep { $oldgroup eq $_ } @newgroups ) {
503 @newgroups = grep { $oldgroup ne $_ } @newgroups;
506 my $radius_usergroup = qsearchs('radius_usergroup', {
507 svcnum => $old->svcnum,
508 groupname => $oldgroup,
510 my $error = $radius_usergroup->delete;
512 $dbh->rollback if $oldAutoCommit;
513 return "error deleting radius_usergroup $oldgroup: $error";
517 foreach my $newgroup ( @newgroups ) {
518 my $radius_usergroup = new FS::radius_usergroup ( {
519 svcnum => $new->svcnum,
520 groupname => $newgroup,
522 my $error = $radius_usergroup->insert;
524 $dbh->rollback if $oldAutoCommit;
525 return "error adding radius_usergroup $newgroup: $error";
531 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
532 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
533 $error = $new->_check_duplicate;
535 $dbh->rollback if $oldAutoCommit;
540 $error = $new->SUPER::replace($old);
542 $dbh->rollback if $oldAutoCommit;
543 return $error if $error;
546 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
547 $error = $new->queue_fuzzyfiles_update;
549 $dbh->rollback if $oldAutoCommit;
550 return "updating fuzzy search cache: $error";
554 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
558 =item queue_fuzzyfiles_update
560 Used by insert & replace to update the fuzzy search cache
564 sub queue_fuzzyfiles_update {
567 local $SIG{HUP} = 'IGNORE';
568 local $SIG{INT} = 'IGNORE';
569 local $SIG{QUIT} = 'IGNORE';
570 local $SIG{TERM} = 'IGNORE';
571 local $SIG{TSTP} = 'IGNORE';
572 local $SIG{PIPE} = 'IGNORE';
574 my $oldAutoCommit = $FS::UID::AutoCommit;
575 local $FS::UID::AutoCommit = 0;
578 my $queue = new FS::queue {
579 'svcnum' => $self->svcnum,
580 'job' => 'FS::svc_acct::append_fuzzyfiles'
582 my $error = $queue->insert($self->username);
584 $dbh->rollback if $oldAutoCommit;
585 return "queueing job (transaction rolled back): $error";
588 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
596 Suspends this account by calling export-specific suspend hooks. If there is
597 an error, returns the error, otherwise returns false.
599 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
605 return "can't suspend system account" if $self->_check_system;
606 $self->SUPER::suspend;
611 Unsuspends this account by by calling export-specific suspend hooks. If there
612 is an error, returns the error, otherwise returns false.
614 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
620 my %hash = $self->hash;
621 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
622 $hash{_password} = $1;
623 my $new = new FS::svc_acct ( \%hash );
624 my $error = $new->replace($self);
625 return $error if $error;
628 $self->SUPER::unsuspend;
633 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
635 If the B<auto_unset_catchall> configuration option is set, this method will
636 automatically remove any references to the canceled service in the catchall
637 field of svc_domain. This allows packages that contain both a svc_domain and
638 its catchall svc_acct to be canceled in one step.
643 # Only one thing to do at this level
645 foreach my $svc_domain (
646 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
647 if($conf->exists('auto_unset_catchall')) {
648 my %hash = $svc_domain->hash;
649 $hash{catchall} = '';
650 my $new = new FS::svc_domain ( \%hash );
651 my $error = $new->replace($svc_domain);
652 return $error if $error;
654 return "cannot unprovision svc_acct #".$self->svcnum.
655 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
659 $self->SUPER::cancel;
665 Checks all fields to make sure this is a valid service. If there is an error,
666 returns the error, otherwise returns false. Called by the insert and replace
669 Sets any fixed values; see L<FS::part_svc>.
676 my($recref) = $self->hashref;
678 my $x = $self->setfixed;
679 return $x unless ref($x);
682 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
684 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
687 my $error = $self->ut_numbern('svcnum')
688 #|| $self->ut_number('domsvc')
689 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
690 || $self->ut_textn('sec_phrase')
692 return $error if $error;
694 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
695 if ( $username_uppercase ) {
696 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
697 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
698 $recref->{username} = $1;
700 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
701 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
702 $recref->{username} = $1;
705 if ( $username_letterfirst ) {
706 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
707 } elsif ( $username_letter ) {
708 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
710 if ( $username_noperiod ) {
711 $recref->{username} =~ /\./ and return gettext('illegal_username');
713 if ( $username_nounderscore ) {
714 $recref->{username} =~ /_/ and return gettext('illegal_username');
716 if ( $username_nodash ) {
717 $recref->{username} =~ /\-/ and return gettext('illegal_username');
719 unless ( $username_ampersand ) {
720 $recref->{username} =~ /\&/ and return gettext('illegal_username');
722 if ( $password_noampersand ) {
723 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
725 if ( $password_noexclamation ) {
726 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
729 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
730 $recref->{popnum} = $1;
731 return "Unknown popnum" unless
732 ! $recref->{popnum} ||
733 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
735 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
737 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
738 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
740 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
741 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
742 #not all systems use gid=uid
743 #you can set a fixed gid in part_svc
745 return "Only root can have uid 0"
746 if $recref->{uid} == 0
747 && $recref->{username} !~ /^(root|toor|smtp)$/;
749 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
750 or return "Illegal directory: ". $recref->{dir};
752 return "Illegal directory"
753 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
754 return "Illegal directory"
755 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
756 unless ( $recref->{dir} ) {
757 $recref->{dir} = $dir_prefix . '/';
758 if ( $dirhash > 0 ) {
759 for my $h ( 1 .. $dirhash ) {
760 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
762 } elsif ( $dirhash < 0 ) {
763 for my $h ( reverse $dirhash .. -1 ) {
764 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
767 $recref->{dir} .= $recref->{username};
771 unless ( $recref->{username} eq 'sync' ) {
772 if ( grep $_ eq $recref->{shell}, @shells ) {
773 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
775 return "Illegal shell \`". $self->shell. "\'; ".
776 $conf->dir. "/shells contains: @shells";
779 $recref->{shell} = '/bin/sync';
783 $recref->{gid} ne '' ?
784 return "Can't have gid without uid" : ( $recref->{gid}='' );
785 $recref->{dir} ne '' ?
786 return "Can't have directory without uid" : ( $recref->{dir}='' );
787 $recref->{shell} ne '' ?
788 return "Can't have shell without uid" : ( $recref->{shell}='' );
791 # $error = $self->ut_textn('finger');
792 # return $error if $error;
793 if ( $self->getfield('finger') eq '' ) {
794 my $cust_pkg = $self->svcnum
795 ? $self->cust_svc->cust_pkg
796 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
798 my $cust_main = $cust_pkg->cust_main;
799 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
802 $self->getfield('finger') =~
803 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
804 or return "Illegal finger: ". $self->getfield('finger');
805 $self->setfield('finger', $1);
807 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
808 $recref->{quota} = $1;
810 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
811 if ( $recref->{slipip} eq '' ) {
812 $recref->{slipip} = '';
813 } elsif ( $recref->{slipip} eq '0e0' ) {
814 $recref->{slipip} = '0e0';
816 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
817 or return "Illegal slipip: ". $self->slipip;
818 $recref->{slipip} = $1;
823 #arbitrary RADIUS stuff; allow ut_textn for now
824 foreach ( grep /^radius_/, fields('svc_acct') ) {
828 #generate a password if it is blank
829 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
830 unless ( $recref->{_password} );
832 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
833 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
834 $recref->{_password} = $1.$3;
835 #uncomment this to encrypt password immediately upon entry, or run
836 #bin/crypt_pw in cron to give new users a window during which their
837 #password is available to techs, for faxing, etc. (also be aware of
839 #$recref->{password} = $1.
840 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
842 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
843 $recref->{_password} = $1.$3;
844 } elsif ( $recref->{_password} eq '*' ) {
845 $recref->{_password} = '*';
846 } elsif ( $recref->{_password} eq '!' ) {
847 $recref->{_password} = '!';
848 } elsif ( $recref->{_password} eq '!!' ) {
849 $recref->{_password} = '!!';
851 #return "Illegal password";
852 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
853 FS::Msgcat::_gettext('illegal_password_characters').
854 ": ". $recref->{_password};
862 Internal function to check the username against the list of system usernames
863 from the I<system_usernames> configuration value. Returns true if the username
864 is listed on the system username list.
870 scalar( grep { $self->username eq $_ || $self->email eq $_ }
871 $conf->config('system_usernames')
875 =item _check_duplicate
877 Internal function to check for duplicates usernames, username@domain pairs and
880 If the I<global_unique-username> configuration value is set to B<username> or
881 B<username@domain>, enforces global username or username@domain uniqueness.
883 In all cases, check for duplicate uids and usernames or username@domain pairs
884 per export and with identical I<svcpart> values.
888 sub _check_duplicate {
891 #this is Pg-specific. what to do for mysql etc?
892 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
893 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
894 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
896 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
898 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
899 unless ( $part_svc ) {
900 return 'unknown svcpart '. $self->svcpart;
903 my $global_unique = $conf->config('global_unique-username') || 'none';
905 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
906 qsearch( 'svc_acct', { 'username' => $self->username } );
907 return gettext('username_in_use')
908 if $global_unique eq 'username' && @dup_user;
910 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
911 qsearch( 'svc_acct', { 'username' => $self->username,
912 'domsvc' => $self->domsvc } );
913 return gettext('username_in_use')
914 if $global_unique eq 'username@domain' && @dup_userdomain;
917 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
918 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
919 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
920 qsearch( 'svc_acct', { 'uid' => $self->uid } );
925 if ( @dup_user || @dup_userdomain || @dup_uid ) {
926 my $exports = FS::part_export::export_info('svc_acct');
927 my %conflict_user_svcpart;
928 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
930 foreach my $part_export ( $part_svc->part_export ) {
932 #this will catch to the same exact export
933 my @svcparts = map { $_->svcpart } $part_export->export_svc;
935 #this will catch to exports w/same exporthost+type ???
936 #my @other_part_export = qsearch('part_export', {
937 # 'machine' => $part_export->machine,
938 # 'exporttype' => $part_export->exporttype,
940 #foreach my $other_part_export ( @other_part_export ) {
941 # push @svcparts, map { $_->svcpart }
942 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
945 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
946 #silly kludge to avoid uninitialized value errors
947 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
948 ? $exports->{$part_export->exporttype}{'nodomain'}
950 if ( $nodomain =~ /^Y/i ) {
951 $conflict_user_svcpart{$_} = $part_export->exportnum
954 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
959 foreach my $dup_user ( @dup_user ) {
960 my $dup_svcpart = $dup_user->cust_svc->svcpart;
961 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
962 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
963 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
967 foreach my $dup_userdomain ( @dup_userdomain ) {
968 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
969 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
970 return "duplicate username\@domain: conflicts with svcnum ".
971 $dup_userdomain->svcnum. " via exportnum ".
972 $conflict_userdomain_svcpart{$dup_svcpart};
976 foreach my $dup_uid ( @dup_uid ) {
977 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
978 if ( exists($conflict_user_svcpart{$dup_svcpart})
979 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
980 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
981 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
982 || $conflict_userdomain_svcpart{$dup_svcpart};
994 Depriciated, use radius_reply instead.
999 carp "FS::svc_acct::radius depriciated, use radius_reply";
1000 $_[0]->radius_reply;
1005 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1006 reply attributes of this record.
1008 Note that this is now the preferred method for reading RADIUS attributes -
1009 accessing the columns directly is discouraged, as the column names are
1010 expected to change in the future.
1019 my($column, $attrib) = ($1, $2);
1020 #$attrib =~ s/_/\-/g;
1021 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1022 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1023 if ( $self->slipip && $self->slipip ne '0e0' ) {
1024 $reply{$radius_ip} = $self->slipip;
1026 if ( $self->seconds !~ /^$/ ) {
1027 $reply{'Session-Timeout'} = $self->seconds;
1034 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1035 check attributes of this record.
1037 Note that this is now the preferred method for reading RADIUS attributes -
1038 accessing the columns directly is discouraged, as the column names are
1039 expected to change in the future.
1045 my $password = $self->_password;
1046 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1047 ( $pw_attrib => $password,
1050 my($column, $attrib) = ($1, $2);
1051 #$attrib =~ s/_/\-/g;
1052 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1053 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
1059 Returns the domain associated with this account.
1065 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1066 my $svc_domain = $self->svc_domain(@_)
1067 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1068 $svc_domain->domain;
1073 Returns the FS::svc_domain record for this account's domain (see
1081 ? $self->{'_domsvc'}
1082 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1087 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1093 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1098 Returns an email address associated with the account.
1104 $self->username. '@'. $self->domain(@_);
1109 Returns an array of FS::acct_snarf records associated with the account.
1110 If the acct_snarf table does not exist or there are no associated records,
1111 an empty list is returned
1117 return () unless dbdef->table('acct_snarf');
1118 eval "use FS::acct_snarf;";
1120 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1123 =item seconds_since TIMESTAMP
1125 Returns the number of seconds this account has been online since TIMESTAMP,
1126 according to the session monitor (see L<FS::Session>).
1128 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1129 L<Time::Local> and L<Date::Parse> for conversion functions.
1133 #note: POD here, implementation in FS::cust_svc
1136 $self->cust_svc->seconds_since(@_);
1139 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1141 Returns the numbers of seconds this account has been online between
1142 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1143 external SQL radacct table, specified via sqlradius export. Sessions which
1144 started in the specified range but are still open are counted from session
1145 start to the end of the range (unless they are over 1 day old, in which case
1146 they are presumed missing their stop record and not counted). Also, sessions
1147 which end in the range but started earlier are counted from the start of the
1148 range to session end. Finally, sessions which start before the range but end
1149 after are counted for the entire range.
1151 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1152 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1157 #note: POD here, implementation in FS::cust_svc
1158 sub seconds_since_sqlradacct {
1160 $self->cust_svc->seconds_since_sqlradacct(@_);
1163 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1165 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1166 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1167 TIMESTAMP_END (exclusive).
1169 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1170 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1175 #note: POD here, implementation in FS::cust_svc
1176 sub attribute_since_sqlradacct {
1178 $self->cust_svc->attribute_since_sqlradacct(@_);
1181 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1183 Returns an array of hash references of this customers login history for the
1184 given time range. (document this better)
1188 sub get_session_history {
1190 $self->cust_svc->get_session_history(@_);
1195 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1201 if ( $self->usergroup ) {
1202 #when provisioning records, export callback runs in svc_Common.pm before
1203 #radius_usergroup records can be inserted...
1204 @{$self->usergroup};
1206 map { $_->groupname }
1207 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1211 =item clone_suspended
1213 Constructor used by FS::part_export::_export_suspend fallback. Document
1218 sub clone_suspended {
1220 my %hash = $self->hash;
1221 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1222 new FS::svc_acct \%hash;
1225 =item clone_kludge_unsuspend
1227 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1232 sub clone_kludge_unsuspend {
1234 my %hash = $self->hash;
1235 $hash{_password} = '';
1236 new FS::svc_acct \%hash;
1239 =item check_password
1241 Checks the supplied password against the (possibly encrypted) password in the
1242 database. Returns true for a sucessful authentication, false for no match.
1244 Currently supported encryptions are: classic DES crypt() and MD5
1248 sub check_password {
1249 my($self, $check_password) = @_;
1251 #remove old-style SUSPENDED kludge, they should be allowed to login to
1252 #self-service and pay up
1253 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1255 #eventually should check a "password-encoding" field
1256 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1258 } elsif ( length($password) < 13 ) { #plaintext
1259 $check_password eq $password;
1260 } elsif ( length($password) == 13 ) { #traditional DES crypt
1261 crypt($check_password, $password) eq $password;
1262 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1263 unix_md5_crypt($check_password, $password) eq $password;
1264 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1265 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1266 $self->svcnum. "\n";
1269 warn "Can't check password: Unrecognized encryption for svcnum ".
1270 $self->svcnum. "\n";
1276 =item crypt_password
1278 Returns an encrypted password, either by passing through an encrypted password
1279 in the database or by encrypting a plaintext password from the database.
1283 sub crypt_password {
1285 #false laziness w/shellcommands.pm
1286 #eventually should check a "password-encoding" field
1287 if ( length($self->_password) == 13
1288 || $self->_password =~ /^\$(1|2a?)\$/ ) {
1293 $saltset[int(rand(64))].$saltset[int(rand(64))]
1298 =item virtual_maildir
1300 Returns $domain/maildirs/$username/
1304 sub virtual_maildir {
1306 $self->domain. '/maildirs/'. $self->username. '/';
1317 This is the FS::svc_acct job-queue-able version. It still uses
1318 FS::Misc::send_email under-the-hood.
1325 eval "use FS::Misc qw(send_email)";
1328 $opt{mimetype} ||= 'text/plain';
1329 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1331 my $error = send_email(
1332 'from' => $opt{from},
1334 'subject' => $opt{subject},
1335 'content-type' => $opt{mimetype},
1336 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1338 die $error if $error;
1341 =item check_and_rebuild_fuzzyfiles
1345 sub check_and_rebuild_fuzzyfiles {
1346 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1347 -e "$dir/svc_acct.username"
1348 or &rebuild_fuzzyfiles;
1351 =item rebuild_fuzzyfiles
1355 sub rebuild_fuzzyfiles {
1357 use Fcntl qw(:flock);
1359 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1363 open(USERNAMELOCK,">>$dir/svc_acct.username")
1364 or die "can't open $dir/svc_acct.username: $!";
1365 flock(USERNAMELOCK,LOCK_EX)
1366 or die "can't lock $dir/svc_acct.username: $!";
1368 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1370 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1371 or die "can't open $dir/svc_acct.username.tmp: $!";
1372 print USERNAMECACHE join("\n", @all_username), "\n";
1373 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1375 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1385 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1386 open(USERNAMECACHE,"<$dir/svc_acct.username")
1387 or die "can't open $dir/svc_acct.username: $!";
1388 my @array = map { chomp; $_; } <USERNAMECACHE>;
1389 close USERNAMECACHE;
1393 =item append_fuzzyfiles USERNAME
1397 sub append_fuzzyfiles {
1398 my $username = shift;
1400 &check_and_rebuild_fuzzyfiles;
1402 use Fcntl qw(:flock);
1404 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1406 open(USERNAME,">>$dir/svc_acct.username")
1407 or die "can't open $dir/svc_acct.username: $!";
1408 flock(USERNAME,LOCK_EX)
1409 or die "can't lock $dir/svc_acct.username: $!";
1411 print USERNAME "$username\n";
1413 flock(USERNAME,LOCK_UN)
1414 or die "can't unlock $dir/svc_acct.username: $!";
1422 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1426 sub radius_usergroup_selector {
1427 my $sel_groups = shift;
1428 my %sel_groups = map { $_=>1 } @$sel_groups;
1430 my $selectname = shift || 'radius_usergroup';
1433 my $sth = $dbh->prepare(
1434 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1435 ) or die $dbh->errstr;
1436 $sth->execute() or die $sth->errstr;
1437 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1441 function ${selectname}_doadd(object) {
1442 var myvalue = object.${selectname}_add.value;
1443 var optionName = new Option(myvalue,myvalue,false,true);
1444 var length = object.$selectname.length;
1445 object.$selectname.options[length] = optionName;
1446 object.${selectname}_add.value = "";
1449 <SELECT MULTIPLE NAME="$selectname">
1452 foreach my $group ( @all_groups ) {
1453 $html .= qq(<OPTION VALUE="$group");
1454 if ( $sel_groups{$group} ) {
1455 $html .= ' SELECTED';
1456 $sel_groups{$group} = 0;
1458 $html .= ">$group</OPTION>\n";
1460 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1461 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1463 $html .= '</SELECT>';
1465 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1466 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1475 The $recref stuff in sub check should be cleaned up.
1477 The suspend, unsuspend and cancel methods update the database, but not the
1478 current object. This is probably a bug as it's unexpected and
1481 radius_usergroup_selector? putting web ui components in here? they should
1482 probably live somewhere else...
1484 insertion of RADIUS group stuff in insert could be done with child_objects now
1485 (would probably clean up export of them too)
1489 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1490 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1491 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1492 L<freeside-queued>), L<FS::svc_acct_pop>,
1493 schema.html from the base documentation.