4 use vars qw( @ISA $DEBUG $me $conf
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
10 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
12 $radius_password $radius_ip
18 use FS::UID qw( datasrc );
20 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
25 use FS::cust_main_invoice;
29 use FS::radius_usergroup;
32 use FS::Msgcat qw(gettext);
36 @ISA = qw( FS::svc_Common );
40 $me = '[FS::svc_acct]';
42 #ask FS::UID to run this stuff for us later
43 $FS::UID::callback{'FS::svc_acct'} = sub {
45 $dir_prefix = $conf->config('home');
46 @shells = $conf->config('shells');
47 $usernamemin = $conf->config('usernamemin') || 2;
48 $usernamemax = $conf->config('usernamemax');
49 $passwordmin = $conf->config('passwordmin') || 6;
50 $passwordmax = $conf->config('passwordmax') || 8;
51 $username_letter = $conf->exists('username-letter');
52 $username_letterfirst = $conf->exists('username-letterfirst');
53 $username_noperiod = $conf->exists('username-noperiod');
54 $username_nounderscore = $conf->exists('username-nounderscore');
55 $username_nodash = $conf->exists('username-nodash');
56 $username_uppercase = $conf->exists('username-uppercase');
57 $username_ampersand = $conf->exists('username-ampersand');
58 $dirhash = $conf->config('dirhash') || 0;
59 if ( $conf->exists('welcome_email') ) {
60 $welcome_template = new Text::Template (
62 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
63 ) or warn "can't create welcome email template: $Text::Template::ERROR";
64 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
65 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
66 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
68 $welcome_template = '';
70 $welcome_subject = '';
71 $welcome_mimetype = '';
73 $smtpmachine = $conf->config('smtpmachine');
74 $radius_password = $conf->config('radius-password') || 'Password';
75 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
78 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
79 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
83 my ( $hashref, $cache ) = @_;
84 if ( $hashref->{'svc_acct_svcnum'} ) {
85 $self->{'_domsvc'} = FS::svc_domain->new( {
86 'svcnum' => $hashref->{'domsvc'},
87 'domain' => $hashref->{'svc_acct_domain'},
88 'catchall' => $hashref->{'svc_acct_catchall'},
95 FS::svc_acct - Object methods for svc_acct records
101 $record = new FS::svc_acct \%hash;
102 $record = new FS::svc_acct { 'column' => 'value' };
104 $error = $record->insert;
106 $error = $new_record->replace($old_record);
108 $error = $record->delete;
110 $error = $record->check;
112 $error = $record->suspend;
114 $error = $record->unsuspend;
116 $error = $record->cancel;
118 %hash = $record->radius;
120 %hash = $record->radius_reply;
122 %hash = $record->radius_check;
124 $domain = $record->domain;
126 $svc_domain = $record->svc_domain;
128 $email = $record->email;
130 $seconds_since = $record->seconds_since($timestamp);
134 An FS::svc_acct object represents an account. FS::svc_acct inherits from
135 FS::svc_Common. The following fields are currently supported:
139 =item svcnum - primary key (assigned automatcially for new accounts)
143 =item _password - generated if blank
145 =item sec_phrase - security phrase
147 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
155 =item dir - set automatically if blank (and uid is not)
159 =item quota - (unimplementd)
161 =item slipip - IP address
165 =item domsvc - svcnum from svc_domain
167 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
177 Creates a new account. To add the account to the database, see L<"insert">.
181 sub table { 'svc_acct'; }
183 =item insert [ , OPTION => VALUE ... ]
185 Adds this account to the database. If there is an error, returns the error,
186 otherwise returns false.
188 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
189 defined. An FS::cust_svc record will be created and inserted.
191 The additional field I<usergroup> can optionally be defined; if so it should
192 contain an arrayref of group names. See L<FS::radius_usergroup>.
194 The additional field I<child_objects> can optionally be defined; if so it
195 should contain an arrayref of FS::tablename objects. They will have their
196 svcnum fields set and will be inserted after this record, but before any
199 Currently available options are: I<depend_jobnum>
201 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
202 jobnums), all provisioning jobs will have a dependancy on the supplied
203 jobnum(s) (they will not run until the specific job(s) complete(s)).
205 (TODOC: L<FS::queue> and L<freeside-queued>)
207 (TODOC: new exports!)
216 local $SIG{HUP} = 'IGNORE';
217 local $SIG{INT} = 'IGNORE';
218 local $SIG{QUIT} = 'IGNORE';
219 local $SIG{TERM} = 'IGNORE';
220 local $SIG{TSTP} = 'IGNORE';
221 local $SIG{PIPE} = 'IGNORE';
223 my $oldAutoCommit = $FS::UID::AutoCommit;
224 local $FS::UID::AutoCommit = 0;
227 $error = $self->check;
228 return $error if $error;
230 #no, duplicate checking just got a whole lot more complicated
231 #(perhaps keep this check with a config option to turn on?)
233 #return gettext('username_in_use'). ": ". $self->username
234 # if qsearchs( 'svc_acct', { 'username' => $self->username,
235 # 'domsvc' => $self->domsvc,
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 #new duplicate username/username@domain/uid checking
250 #this is Pg-specific. what to do for mysql etc?
251 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
252 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
253 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
255 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
257 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
258 unless ( $part_svc ) {
259 $dbh->rollback if $oldAutoCommit;
260 return 'unknown svcpart '. $self->svcpart;
263 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
264 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
265 'domsvc' => $self->domsvc } );
267 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
268 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
269 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
274 if ( @dup_user || @dup_userdomain || @dup_uid ) {
275 my $exports = FS::part_export::export_info('svc_acct');
276 my %conflict_user_svcpart;
277 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
279 foreach my $part_export ( $part_svc->part_export ) {
281 #this will catch to the same exact export
282 my @svcparts = map { $_->svcpart } $part_export->export_svc;
284 #this will catch to exports w/same exporthost+type ???
285 #my @other_part_export = qsearch('part_export', {
286 # 'machine' => $part_export->machine,
287 # 'exporttype' => $part_export->exporttype,
289 #foreach my $other_part_export ( @other_part_export ) {
290 # push @svcparts, map { $_->svcpart }
291 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
294 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
295 #silly kludge to avoid uninitialized value errors
296 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
297 ? $exports->{$part_export->exporttype}{'nodomain'}
299 if ( $nodomain =~ /^Y/i ) {
300 $conflict_user_svcpart{$_} = $part_export->exportnum
303 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
308 foreach my $dup_user ( @dup_user ) {
309 my $dup_svcpart = $dup_user->cust_svc->svcpart;
310 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
311 $dbh->rollback if $oldAutoCommit;
312 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
313 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
317 foreach my $dup_userdomain ( @dup_userdomain ) {
318 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
319 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
320 $dbh->rollback if $oldAutoCommit;
321 return "duplicate username\@domain: conflicts with svcnum ".
322 $dup_userdomain->svcnum. " via exportnum ".
323 $conflict_userdomain_svcpart{$dup_svcpart};
327 foreach my $dup_uid ( @dup_uid ) {
328 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
329 if ( exists($conflict_user_svcpart{$dup_svcpart})
330 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
331 $dbh->rollback if $oldAutoCommit;
332 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
333 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
334 || $conflict_userdomain_svcpart{$dup_svcpart};
340 #see? i told you it was more complicated
343 $error = $self->SUPER::insert(
344 'jobnums' => \@jobnums,
345 'child_objects' => $self->child_objects,
349 $dbh->rollback if $oldAutoCommit;
353 if ( $self->usergroup ) {
354 foreach my $groupname ( @{$self->usergroup} ) {
355 my $radius_usergroup = new FS::radius_usergroup ( {
356 svcnum => $self->svcnum,
357 groupname => $groupname,
359 my $error = $radius_usergroup->insert;
361 $dbh->rollback if $oldAutoCommit;
367 #false laziness with sub replace (and cust_main)
368 my $queue = new FS::queue {
369 'svcnum' => $self->svcnum,
370 'job' => 'FS::svc_acct::append_fuzzyfiles'
372 $error = $queue->insert($self->username);
374 $dbh->rollback if $oldAutoCommit;
375 return "queueing job (transaction rolled back): $error";
378 my $cust_pkg = $self->cust_svc->cust_pkg;
381 my $cust_main = $cust_pkg->cust_main;
383 if ( $conf->exists('emailinvoiceauto') ) {
384 my @invoicing_list = $cust_main->invoicing_list;
385 push @invoicing_list, $self->email;
386 $cust_main->invoicing_list(\@invoicing_list);
391 if ( $welcome_template && $cust_pkg ) {
392 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
394 my $wqueue = new FS::queue {
395 'svcnum' => $self->svcnum,
396 'job' => 'FS::svc_acct::send_email'
398 my $error = $wqueue->insert(
400 'from' => $welcome_from,
401 'subject' => $welcome_subject,
402 'mimetype' => $welcome_mimetype,
403 'body' => $welcome_template->fill_in( HASH => {
404 'custnum' => $self->custnum,
405 'username' => $self->username,
406 'password' => $self->_password,
407 'first' => $cust_main->first,
408 'last' => $cust_main->getfield('last'),
409 'pkg' => $cust_pkg->part_pkg->pkg,
413 $dbh->rollback if $oldAutoCommit;
414 return "error queuing welcome email: $error";
417 if ( $options{'depend_jobnum'} ) {
418 warn "$me depend_jobnum found; adding to welcome email dependancies"
420 if ( ref($options{'depend_jobnum'}) ) {
421 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
422 "to welcome email dependancies"
424 push @jobnums, @{ $options{'depend_jobnum'} };
426 warn "$me adding job $options{'depend_jobnum'} ".
427 "to welcome email dependancies"
429 push @jobnums, $options{'depend_jobnum'};
433 foreach my $jobnum ( @jobnums ) {
434 my $error = $wqueue->depend_insert($jobnum);
436 $dbh->rollback if $oldAutoCommit;
437 return "error queuing welcome email job dependancy: $error";
447 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
453 Deletes this account from the database. If there is an error, returns the
454 error, otherwise returns false.
456 The corresponding FS::cust_svc record will be deleted as well.
458 (TODOC: new exports!)
465 return "can't delete system account" if $self->_check_system;
467 return "Can't delete an account which is a (svc_forward) source!"
468 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
470 return "Can't delete an account which is a (svc_forward) destination!"
471 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
473 return "Can't delete an account with (svc_www) web service!"
474 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
476 # what about records in session ? (they should refer to history table)
478 local $SIG{HUP} = 'IGNORE';
479 local $SIG{INT} = 'IGNORE';
480 local $SIG{QUIT} = 'IGNORE';
481 local $SIG{TERM} = 'IGNORE';
482 local $SIG{TSTP} = 'IGNORE';
483 local $SIG{PIPE} = 'IGNORE';
485 my $oldAutoCommit = $FS::UID::AutoCommit;
486 local $FS::UID::AutoCommit = 0;
489 foreach my $cust_main_invoice (
490 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
492 unless ( defined($cust_main_invoice) ) {
493 warn "WARNING: something's wrong with qsearch";
496 my %hash = $cust_main_invoice->hash;
497 $hash{'dest'} = $self->email;
498 my $new = new FS::cust_main_invoice \%hash;
499 my $error = $new->replace($cust_main_invoice);
501 $dbh->rollback if $oldAutoCommit;
506 foreach my $svc_domain (
507 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
509 my %hash = new FS::svc_domain->hash;
510 $hash{'catchall'} = '';
511 my $new = new FS::svc_domain \%hash;
512 my $error = $new->replace($svc_domain);
514 $dbh->rollback if $oldAutoCommit;
519 foreach my $radius_usergroup (
520 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
522 my $error = $radius_usergroup->delete;
524 $dbh->rollback if $oldAutoCommit;
529 my $error = $self->SUPER::delete;
531 $dbh->rollback if $oldAutoCommit;
535 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
539 =item replace OLD_RECORD
541 Replaces OLD_RECORD with this one in the database. If there is an error,
542 returns the error, otherwise returns false.
544 The additional field I<usergroup> can optionally be defined; if so it should
545 contain an arrayref of group names. See L<FS::radius_usergroup>.
551 my ( $new, $old ) = ( shift, shift );
553 warn "$me replacing $old with $new\n" if $DEBUG;
555 return "can't modify system account" if $old->_check_system;
557 return "Username in use"
558 if $old->username ne $new->username &&
559 qsearchs( 'svc_acct', { 'username' => $new->username,
560 'domsvc' => $new->domsvc,
563 #no warnings 'numeric'; #alas, a 5.006-ism
565 return "Can't change uid!" if $old->uid != $new->uid;
568 #change homdir when we change username
569 $new->setfield('dir', '') if $old->username ne $new->username;
571 local $SIG{HUP} = 'IGNORE';
572 local $SIG{INT} = 'IGNORE';
573 local $SIG{QUIT} = 'IGNORE';
574 local $SIG{TERM} = 'IGNORE';
575 local $SIG{TSTP} = 'IGNORE';
576 local $SIG{PIPE} = 'IGNORE';
578 my $oldAutoCommit = $FS::UID::AutoCommit;
579 local $FS::UID::AutoCommit = 0;
582 # redundant, but so $new->usergroup gets set
583 $error = $new->check;
584 return $error if $error;
586 $old->usergroup( [ $old->radius_groups ] );
587 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
588 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
589 if ( $new->usergroup ) {
590 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
591 my @newgroups = @{$new->usergroup};
592 foreach my $oldgroup ( @{$old->usergroup} ) {
593 if ( grep { $oldgroup eq $_ } @newgroups ) {
594 @newgroups = grep { $oldgroup ne $_ } @newgroups;
597 my $radius_usergroup = qsearchs('radius_usergroup', {
598 svcnum => $old->svcnum,
599 groupname => $oldgroup,
601 my $error = $radius_usergroup->delete;
603 $dbh->rollback if $oldAutoCommit;
604 return "error deleting radius_usergroup $oldgroup: $error";
608 foreach my $newgroup ( @newgroups ) {
609 my $radius_usergroup = new FS::radius_usergroup ( {
610 svcnum => $new->svcnum,
611 groupname => $newgroup,
613 my $error = $radius_usergroup->insert;
615 $dbh->rollback if $oldAutoCommit;
616 return "error adding radius_usergroup $newgroup: $error";
622 $error = $new->SUPER::replace($old);
624 $dbh->rollback if $oldAutoCommit;
625 return $error if $error;
628 if ( $new->username ne $old->username ) {
629 #false laziness with sub insert (and cust_main)
630 my $queue = new FS::queue {
631 'svcnum' => $new->svcnum,
632 'job' => 'FS::svc_acct::append_fuzzyfiles'
634 $error = $queue->insert($new->username);
636 $dbh->rollback if $oldAutoCommit;
637 return "queueing job (transaction rolled back): $error";
641 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
647 Suspends this account by calling export-specific suspend hooks. If there is
648 an error, returns the error, otherwise returns false.
650 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
656 return "can't suspend system account" if $self->_check_system;
657 $self->SUPER::suspend;
662 Unsuspends this account by by calling export-specific suspend hooks. If there
663 is an error, returns the error, otherwise returns false.
665 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
671 my %hash = $self->hash;
672 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
673 $hash{_password} = $1;
674 my $new = new FS::svc_acct ( \%hash );
675 my $error = $new->replace($self);
676 return $error if $error;
679 $self->SUPER::unsuspend;
684 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
686 If the B<auto_unset_catchall> configuration option is set, this method will
687 automatically remove any references to the canceled service in the catchall
688 field of svc_domain. This allows packages that contain both a svc_domain and
689 its catchall svc_acct to be canceled in one step.
694 # Only one thing to do at this level
696 foreach my $svc_domain (
697 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
698 if($conf->exists('auto_unset_catchall')) {
699 my %hash = $svc_domain->hash;
700 $hash{catchall} = '';
701 my $new = new FS::svc_domain ( \%hash );
702 my $error = $new->replace($svc_domain);
703 return $error if $error;
705 return "cannot unprovision svc_acct #".$self->svcnum.
706 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
710 $self->SUPER::cancel;
716 Checks all fields to make sure this is a valid service. If there is an error,
717 returns the error, otherwise returns false. Called by the insert and replace
720 Sets any fixed values; see L<FS::part_svc>.
727 my($recref) = $self->hashref;
729 my $x = $self->setfixed;
730 return $x unless ref($x);
733 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
735 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
738 my $error = $self->ut_numbern('svcnum')
739 #|| $self->ut_number('domsvc')
740 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
741 || $self->ut_textn('sec_phrase')
743 return $error if $error;
745 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
746 if ( $username_uppercase ) {
747 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
748 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
749 $recref->{username} = $1;
751 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
752 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
753 $recref->{username} = $1;
756 if ( $username_letterfirst ) {
757 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
758 } elsif ( $username_letter ) {
759 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
761 if ( $username_noperiod ) {
762 $recref->{username} =~ /\./ and return gettext('illegal_username');
764 if ( $username_nounderscore ) {
765 $recref->{username} =~ /_/ and return gettext('illegal_username');
767 if ( $username_nodash ) {
768 $recref->{username} =~ /\-/ and return gettext('illegal_username');
770 unless ( $username_ampersand ) {
771 $recref->{username} =~ /\&/ and return gettext('illegal_username');
774 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
775 $recref->{popnum} = $1;
776 return "Unknown popnum" unless
777 ! $recref->{popnum} ||
778 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
780 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
782 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
783 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
785 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
786 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
787 #not all systems use gid=uid
788 #you can set a fixed gid in part_svc
790 return "Only root can have uid 0"
791 if $recref->{uid} == 0
792 && $recref->{username} ne 'root'
793 && $recref->{username} ne 'toor';
796 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
797 or return "Illegal directory: ". $recref->{dir};
799 return "Illegal directory"
800 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
801 return "Illegal directory"
802 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
803 unless ( $recref->{dir} ) {
804 $recref->{dir} = $dir_prefix . '/';
805 if ( $dirhash > 0 ) {
806 for my $h ( 1 .. $dirhash ) {
807 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
809 } elsif ( $dirhash < 0 ) {
810 for my $h ( reverse $dirhash .. -1 ) {
811 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
814 $recref->{dir} .= $recref->{username};
818 unless ( $recref->{username} eq 'sync' ) {
819 if ( grep $_ eq $recref->{shell}, @shells ) {
820 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
822 return "Illegal shell \`". $self->shell. "\'; ".
823 $conf->dir. "/shells contains: @shells";
826 $recref->{shell} = '/bin/sync';
830 $recref->{gid} ne '' ?
831 return "Can't have gid without uid" : ( $recref->{gid}='' );
832 $recref->{dir} ne '' ?
833 return "Can't have directory without uid" : ( $recref->{dir}='' );
834 $recref->{shell} ne '' ?
835 return "Can't have shell without uid" : ( $recref->{shell}='' );
838 # $error = $self->ut_textn('finger');
839 # return $error if $error;
840 if ( $self->getfield('finger') eq '' ) {
841 my $cust_pkg = $self->svcnum
842 ? $self->cust_svc->cust_pkg
843 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
845 my $cust_main = $cust_pkg->cust_main;
846 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
849 $self->getfield('finger') =~
850 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
851 or return "Illegal finger: ". $self->getfield('finger');
852 $self->setfield('finger', $1);
854 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
855 $recref->{quota} = $1;
857 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
858 if ( $recref->{slipip} eq '' ) {
859 $recref->{slipip} = '';
860 } elsif ( $recref->{slipip} eq '0e0' ) {
861 $recref->{slipip} = '0e0';
863 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
864 or return "Illegal slipip: ". $self->slipip;
865 $recref->{slipip} = $1;
870 #arbitrary RADIUS stuff; allow ut_textn for now
871 foreach ( grep /^radius_/, fields('svc_acct') ) {
875 #generate a password if it is blank
876 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
877 unless ( $recref->{_password} );
879 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
880 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
881 $recref->{_password} = $1.$3;
882 #uncomment this to encrypt password immediately upon entry, or run
883 #bin/crypt_pw in cron to give new users a window during which their
884 #password is available to techs, for faxing, etc. (also be aware of
886 #$recref->{password} = $1.
887 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
889 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
890 $recref->{_password} = $1.$3;
891 } elsif ( $recref->{_password} eq '*' ) {
892 $recref->{_password} = '*';
893 } elsif ( $recref->{_password} eq '!' ) {
894 $recref->{_password} = '!';
895 } elsif ( $recref->{_password} eq '!!' ) {
896 $recref->{_password} = '!!';
898 #return "Illegal password";
899 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
900 FS::Msgcat::_gettext('illegal_password_characters').
901 ": ". $recref->{_password};
913 scalar( grep { $self->username eq $_ || $self->email eq $_ }
914 $conf->config('system_usernames')
920 Depriciated, use radius_reply instead.
925 carp "FS::svc_acct::radius depriciated, use radius_reply";
931 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
932 reply attributes of this record.
934 Note that this is now the preferred method for reading RADIUS attributes -
935 accessing the columns directly is discouraged, as the column names are
936 expected to change in the future.
945 my($column, $attrib) = ($1, $2);
946 #$attrib =~ s/_/\-/g;
947 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
948 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
949 if ( $self->slipip && $self->slipip ne '0e0' ) {
950 $reply{$radius_ip} = $self->slipip;
957 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
958 check attributes of this record.
960 Note that this is now the preferred method for reading RADIUS attributes -
961 accessing the columns directly is discouraged, as the column names are
962 expected to change in the future.
968 my $password = $self->_password;
969 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
970 ( $pw_attrib => $password,
973 my($column, $attrib) = ($1, $2);
974 #$attrib =~ s/_/\-/g;
975 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
976 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
982 Returns the domain associated with this account.
988 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
989 my $svc_domain = $self->svc_domain
990 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
996 Returns the FS::svc_domain record for this account's domain (see
1004 ? $self->{'_domsvc'}
1005 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1010 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1016 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1021 Returns an email address associated with the account.
1027 $self->username. '@'. $self->domain;
1032 Returns an array of FS::acct_snarf records associated with the account.
1033 If the acct_snarf table does not exist or there are no associated records,
1034 an empty list is returned
1040 return () unless dbdef->table('acct_snarf');
1041 eval "use FS::acct_snarf;";
1043 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1046 =item seconds_since TIMESTAMP
1048 Returns the number of seconds this account has been online since TIMESTAMP,
1049 according to the session monitor (see L<FS::Session>).
1051 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1052 L<Time::Local> and L<Date::Parse> for conversion functions.
1056 #note: POD here, implementation in FS::cust_svc
1059 $self->cust_svc->seconds_since(@_);
1062 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1064 Returns the numbers of seconds this account has been online between
1065 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1066 external SQL radacct table, specified via sqlradius export. Sessions which
1067 started in the specified range but are still open are counted from session
1068 start to the end of the range (unless they are over 1 day old, in which case
1069 they are presumed missing their stop record and not counted). Also, sessions
1070 which end in the range but started earlier are counted from the start of the
1071 range to session end. Finally, sessions which start before the range but end
1072 after are counted for the entire range.
1074 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1075 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1080 #note: POD here, implementation in FS::cust_svc
1081 sub seconds_since_sqlradacct {
1083 $self->cust_svc->seconds_since_sqlradacct(@_);
1086 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1088 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1089 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1090 TIMESTAMP_END (exclusive).
1092 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1093 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1098 #note: POD here, implementation in FS::cust_svc
1099 sub attribute_since_sqlradacct {
1101 $self->cust_svc->attribute_since_sqlradacct(@_);
1104 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1106 Returns an array of hash references of this customers login history for the
1107 given time range. (document this better)
1111 sub get_session_history_sqlradacct {
1113 $self->cust_svc->get_session_history_sqlradacct(@_);
1118 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1124 if ( $self->usergroup ) {
1125 #when provisioning records, export callback runs in svc_Common.pm before
1126 #radius_usergroup records can be inserted...
1127 @{$self->usergroup};
1129 map { $_->groupname }
1130 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1134 =item clone_suspended
1136 Constructor used by FS::part_export::_export_suspend fallback. Document
1141 sub clone_suspended {
1143 my %hash = $self->hash;
1144 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1145 new FS::svc_acct \%hash;
1148 =item clone_kludge_unsuspend
1150 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1155 sub clone_kludge_unsuspend {
1157 my %hash = $self->hash;
1158 $hash{_password} = '';
1159 new FS::svc_acct \%hash;
1162 =item check_password
1164 Checks the supplied password against the (possibly encrypted) password in the
1165 database. Returns true for a sucessful authentication, false for no match.
1167 Currently supported encryptions are: classic DES crypt() and MD5
1171 sub check_password {
1172 my($self, $check_password) = @_;
1174 #remove old-style SUSPENDED kludge, they should be allowed to login to
1175 #self-service and pay up
1176 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1178 #eventually should check a "password-encoding" field
1179 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1181 } elsif ( length($password) < 13 ) { #plaintext
1182 $check_password eq $password;
1183 } elsif ( length($password) == 13 ) { #traditional DES crypt
1184 crypt($check_password, $password) eq $password;
1185 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1186 unix_md5_crypt($check_password, $password) eq $password;
1187 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1188 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1189 $self->svcnum. "\n";
1192 warn "Can't check password: Unrecognized encryption for svcnum ".
1193 $self->svcnum. "\n";
1199 =item crypt_password
1201 Returns an encrypted password, either by passing through an encrypted password
1202 in the database or by encrypting a plaintext password from the database.
1206 sub crypt_password {
1208 #false laziness w/shellcommands.pm
1209 #eventually should check a "password-encoding" field
1210 if ( length($self->_password) == 13
1211 || $self->_password =~ /^\$(1|2a?)\$/ ) {
1216 $saltset[int(rand(64))].$saltset[int(rand(64))]
1221 =item virtual_maildir
1223 Returns $domain/maildirs/$username/
1227 sub virtual_maildir {
1229 $self->domain. '/maildirs/'. $self->username. '/';
1240 This is the FS::svc_acct job-queue-able version. It still uses
1241 FS::Misc::send_email under-the-hood.
1248 eval "use FS::Misc qw(send_email)";
1251 $opt{mimetype} ||= 'text/plain';
1252 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1254 my $error = send_email(
1255 'from' => $opt{from},
1257 'subject' => $opt{subject},
1258 'content-type' => $opt{mimetype},
1259 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1261 die $error if $error;
1264 =item check_and_rebuild_fuzzyfiles
1268 sub check_and_rebuild_fuzzyfiles {
1269 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1270 -e "$dir/svc_acct.username"
1271 or &rebuild_fuzzyfiles;
1274 =item rebuild_fuzzyfiles
1278 sub rebuild_fuzzyfiles {
1280 use Fcntl qw(:flock);
1282 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1286 open(USERNAMELOCK,">>$dir/svc_acct.username")
1287 or die "can't open $dir/svc_acct.username: $!";
1288 flock(USERNAMELOCK,LOCK_EX)
1289 or die "can't lock $dir/svc_acct.username: $!";
1291 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1293 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1294 or die "can't open $dir/svc_acct.username.tmp: $!";
1295 print USERNAMECACHE join("\n", @all_username), "\n";
1296 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1298 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1308 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1309 open(USERNAMECACHE,"<$dir/svc_acct.username")
1310 or die "can't open $dir/svc_acct.username: $!";
1311 my @array = map { chomp; $_; } <USERNAMECACHE>;
1312 close USERNAMECACHE;
1316 =item append_fuzzyfiles USERNAME
1320 sub append_fuzzyfiles {
1321 my $username = shift;
1323 &check_and_rebuild_fuzzyfiles;
1325 use Fcntl qw(:flock);
1327 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1329 open(USERNAME,">>$dir/svc_acct.username")
1330 or die "can't open $dir/svc_acct.username: $!";
1331 flock(USERNAME,LOCK_EX)
1332 or die "can't lock $dir/svc_acct.username: $!";
1334 print USERNAME "$username\n";
1336 flock(USERNAME,LOCK_UN)
1337 or die "can't unlock $dir/svc_acct.username: $!";
1345 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1349 sub radius_usergroup_selector {
1350 my $sel_groups = shift;
1351 my %sel_groups = map { $_=>1 } @$sel_groups;
1353 my $selectname = shift || 'radius_usergroup';
1356 my $sth = $dbh->prepare(
1357 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1358 ) or die $dbh->errstr;
1359 $sth->execute() or die $sth->errstr;
1360 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1364 function ${selectname}_doadd(object) {
1365 var myvalue = object.${selectname}_add.value;
1366 var optionName = new Option(myvalue,myvalue,false,true);
1367 var length = object.$selectname.length;
1368 object.$selectname.options[length] = optionName;
1369 object.${selectname}_add.value = "";
1372 <SELECT MULTIPLE NAME="$selectname">
1375 foreach my $group ( @all_groups ) {
1377 if ( $sel_groups{$group} ) {
1378 $html .= ' SELECTED';
1379 $sel_groups{$group} = 0;
1381 $html .= ">$group</OPTION>\n";
1383 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1384 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1386 $html .= '</SELECT>';
1388 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1389 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1398 The $recref stuff in sub check should be cleaned up.
1400 The suspend, unsuspend and cancel methods update the database, but not the
1401 current object. This is probably a bug as it's unexpected and
1404 radius_usergroup_selector? putting web ui components in here? they should
1405 probably live somewhere else...
1407 insertion of RADIUS group stuff in insert could be done with child_objects now
1408 (would probably clean up export of them too)
1412 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1413 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1414 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1415 L<freeside-queued>), L<FS::svc_acct_pop>,
1416 schema.html from the base documentation.