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);
34 @ISA = qw( FS::svc_Common );
38 $me = '[FS::svc_acct]';
40 #ask FS::UID to run this stuff for us later
41 $FS::UID::callback{'FS::svc_acct'} = sub {
43 $dir_prefix = $conf->config('home');
44 @shells = $conf->config('shells');
45 $usernamemin = $conf->config('usernamemin') || 2;
46 $usernamemax = $conf->config('usernamemax');
47 $passwordmin = $conf->config('passwordmin') || 6;
48 $passwordmax = $conf->config('passwordmax') || 8;
49 $username_letter = $conf->exists('username-letter');
50 $username_letterfirst = $conf->exists('username-letterfirst');
51 $username_noperiod = $conf->exists('username-noperiod');
52 $username_nounderscore = $conf->exists('username-nounderscore');
53 $username_nodash = $conf->exists('username-nodash');
54 $username_uppercase = $conf->exists('username-uppercase');
55 $username_ampersand = $conf->exists('username-ampersand');
56 $dirhash = $conf->config('dirhash') || 0;
57 if ( $conf->exists('welcome_email') ) {
58 $welcome_template = new Text::Template (
60 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
61 ) or warn "can't create welcome email template: $Text::Template::ERROR";
62 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
63 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
64 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
66 $welcome_template = '';
68 $welcome_subject = '';
69 $welcome_mimetype = '';
71 $smtpmachine = $conf->config('smtpmachine');
72 $radius_password = $conf->config('radius-password') || 'Password';
73 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
76 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
77 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
81 my ( $hashref, $cache ) = @_;
82 if ( $hashref->{'svc_acct_svcnum'} ) {
83 $self->{'_domsvc'} = FS::svc_domain->new( {
84 'svcnum' => $hashref->{'domsvc'},
85 'domain' => $hashref->{'svc_acct_domain'},
86 'catchall' => $hashref->{'svc_acct_catchall'},
93 FS::svc_acct - Object methods for svc_acct records
99 $record = new FS::svc_acct \%hash;
100 $record = new FS::svc_acct { 'column' => 'value' };
102 $error = $record->insert;
104 $error = $new_record->replace($old_record);
106 $error = $record->delete;
108 $error = $record->check;
110 $error = $record->suspend;
112 $error = $record->unsuspend;
114 $error = $record->cancel;
116 %hash = $record->radius;
118 %hash = $record->radius_reply;
120 %hash = $record->radius_check;
122 $domain = $record->domain;
124 $svc_domain = $record->svc_domain;
126 $email = $record->email;
128 $seconds_since = $record->seconds_since($timestamp);
132 An FS::svc_acct object represents an account. FS::svc_acct inherits from
133 FS::svc_Common. The following fields are currently supported:
137 =item svcnum - primary key (assigned automatcially for new accounts)
141 =item _password - generated if blank
143 =item sec_phrase - security phrase
145 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
153 =item dir - set automatically if blank (and uid is not)
157 =item quota - (unimplementd)
159 =item slipip - IP address
163 =item domsvc - svcnum from svc_domain
165 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
175 Creates a new account. To add the account to the database, see L<"insert">.
179 sub table { 'svc_acct'; }
181 =item insert [ , OPTION => VALUE ... ]
183 Adds this account to the database. If there is an error, returns the error,
184 otherwise returns false.
186 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
187 defined. An FS::cust_svc record will be created and inserted.
189 The additional field I<usergroup> can optionally be defined; if so it should
190 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
191 sqlradius export only)
193 The additional field I<child_objects> can optionally be defined; if so it
194 should contain an arrayref of FS::tablename objects. They will have their
195 svcnum fields set and will be inserted after this record, but before any
198 Currently available options are: I<depend_jobnum>
200 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
201 jobnums), all provisioning jobs will have a dependancy on the supplied
202 jobnum(s) (they will not run until the specific job(s) complete(s)).
204 (TODOC: L<FS::queue> and L<freeside-queued>)
206 (TODOC: new exports!)
215 local $SIG{HUP} = 'IGNORE';
216 local $SIG{INT} = 'IGNORE';
217 local $SIG{QUIT} = 'IGNORE';
218 local $SIG{TERM} = 'IGNORE';
219 local $SIG{TSTP} = 'IGNORE';
220 local $SIG{PIPE} = 'IGNORE';
222 my $oldAutoCommit = $FS::UID::AutoCommit;
223 local $FS::UID::AutoCommit = 0;
226 $error = $self->check;
227 return $error if $error;
229 #no, duplicate checking just got a whole lot more complicated
230 #(perhaps keep this check with a config option to turn on?)
232 #return gettext('username_in_use'). ": ". $self->username
233 # if qsearchs( 'svc_acct', { 'username' => $self->username,
234 # 'domsvc' => $self->domsvc,
237 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
238 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
239 unless ( $cust_svc ) {
240 $dbh->rollback if $oldAutoCommit;
241 return "no cust_svc record found for svcnum ". $self->svcnum;
243 $self->pkgnum($cust_svc->pkgnum);
244 $self->svcpart($cust_svc->svcpart);
247 #new duplicate username checking
249 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
250 unless ( $part_svc ) {
251 $dbh->rollback if $oldAutoCommit;
252 return 'unknown svcpart '. $self->svcpart;
255 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
256 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
257 'domsvc' => $self->domsvc } );
259 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
260 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
261 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
266 if ( @dup_user || @dup_userdomain || @dup_uid ) {
267 my $exports = FS::part_export::export_info('svc_acct');
268 my %conflict_user_svcpart;
269 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
271 foreach my $part_export ( $part_svc->part_export ) {
273 #this will catch to the same exact export
274 my @svcparts = map { $_->svcpart }
275 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
277 #this will catch to exports w/same exporthost+type ???
278 #my @other_part_export = qsearch('part_export', {
279 # 'machine' => $part_export->machine,
280 # 'exporttype' => $part_export->exporttype,
282 #foreach my $other_part_export ( @other_part_export ) {
283 # push @svcparts, map { $_->svcpart }
284 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
287 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
288 #silly kludge to avoid uninitialized value errors
289 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
290 ? $exports->{$part_export->exporttype}{'nodomain'}
292 if ( $nodomain =~ /^Y/i ) {
293 $conflict_user_svcpart{$_} = $part_export->exportnum
296 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
301 foreach my $dup_user ( @dup_user ) {
302 my $dup_svcpart = $dup_user->cust_svc->svcpart;
303 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
304 $dbh->rollback if $oldAutoCommit;
305 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
306 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
310 foreach my $dup_userdomain ( @dup_userdomain ) {
311 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
312 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
313 $dbh->rollback if $oldAutoCommit;
314 return "duplicate username\@domain: conflicts with svcnum ".
315 $dup_userdomain->svcnum. " via exportnum ".
316 $conflict_userdomain_svcpart{$dup_svcpart};
320 foreach my $dup_uid ( @dup_uid ) {
321 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
322 if ( exists($conflict_user_svcpart{$dup_svcpart})
323 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
324 $dbh->rollback if $oldAutoCommit;
325 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
326 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
327 || $conflict_userdomain_svcpart{$dup_svcpart};
333 #see? i told you it was more complicated
336 $error = $self->SUPER::insert(
337 'jobnums' => \@jobnums,
338 'child_objects' => $self->child_objects,
342 $dbh->rollback if $oldAutoCommit;
346 if ( $self->usergroup ) {
347 foreach my $groupname ( @{$self->usergroup} ) {
348 my $radius_usergroup = new FS::radius_usergroup ( {
349 svcnum => $self->svcnum,
350 groupname => $groupname,
352 my $error = $radius_usergroup->insert;
354 $dbh->rollback if $oldAutoCommit;
360 #false laziness with sub replace (and cust_main)
361 my $queue = new FS::queue {
362 'svcnum' => $self->svcnum,
363 'job' => 'FS::svc_acct::append_fuzzyfiles'
365 $error = $queue->insert($self->username);
367 $dbh->rollback if $oldAutoCommit;
368 return "queueing job (transaction rolled back): $error";
371 my $cust_pkg = $self->cust_svc->cust_pkg;
374 my $cust_main = $cust_pkg->cust_main;
376 if ( $conf->exists('emailinvoiceauto') ) {
377 my @invoicing_list = $cust_main->invoicing_list;
378 push @invoicing_list, $self->email;
379 $cust_main->invoicing_list(\@invoicing_list);
384 if ( $welcome_template && $cust_pkg ) {
385 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
387 my $wqueue = new FS::queue {
388 'svcnum' => $self->svcnum,
389 'job' => 'FS::svc_acct::send_email'
391 my $error = $wqueue->insert(
393 'from' => $welcome_from,
394 'subject' => $welcome_subject,
395 'mimetype' => $welcome_mimetype,
396 'body' => $welcome_template->fill_in( HASH => {
397 'custnum' => $self->custnum,
398 'username' => $self->username,
399 'password' => $self->_password,
400 'first' => $cust_main->first,
401 'last' => $cust_main->getfield('last'),
402 'pkg' => $cust_pkg->part_pkg->pkg,
406 $dbh->rollback if $oldAutoCommit;
407 return "error queuing welcome email: $error";
410 if ( $options{'depend_jobnum'} ) {
411 warn "$me depend_jobnum found; adding to welcome email dependancies"
413 if ( ref($options{'depend_jobnum'}) ) {
414 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
415 "to welcome email dependancies"
417 push @jobnums, @{ $options{'depend_jobnum'} };
419 warn "$me adding job $options{'depend_jobnum'} ".
420 "to welcome email dependancies"
422 push @jobnums, $options{'depend_jobnum'};
426 foreach my $jobnum ( @jobnums ) {
427 my $error = $wqueue->depend_insert($jobnum);
429 $dbh->rollback if $oldAutoCommit;
430 return "error queuing welcome email job dependancy: $error";
440 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
446 Deletes this account from the database. If there is an error, returns the
447 error, otherwise returns false.
449 The corresponding FS::cust_svc record will be deleted as well.
451 (TODOC: new exports!)
458 return "can't delete system account" if $self->_check_system;
460 return "Can't delete an account which is a (svc_forward) source!"
461 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
463 return "Can't delete an account which is a (svc_forward) destination!"
464 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
466 return "Can't delete an account with (svc_www) web service!"
467 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
469 # what about records in session ? (they should refer to history table)
471 local $SIG{HUP} = 'IGNORE';
472 local $SIG{INT} = 'IGNORE';
473 local $SIG{QUIT} = 'IGNORE';
474 local $SIG{TERM} = 'IGNORE';
475 local $SIG{TSTP} = 'IGNORE';
476 local $SIG{PIPE} = 'IGNORE';
478 my $oldAutoCommit = $FS::UID::AutoCommit;
479 local $FS::UID::AutoCommit = 0;
482 foreach my $cust_main_invoice (
483 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
485 unless ( defined($cust_main_invoice) ) {
486 warn "WARNING: something's wrong with qsearch";
489 my %hash = $cust_main_invoice->hash;
490 $hash{'dest'} = $self->email;
491 my $new = new FS::cust_main_invoice \%hash;
492 my $error = $new->replace($cust_main_invoice);
494 $dbh->rollback if $oldAutoCommit;
499 foreach my $svc_domain (
500 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
502 my %hash = new FS::svc_domain->hash;
503 $hash{'catchall'} = '';
504 my $new = new FS::svc_domain \%hash;
505 my $error = $new->replace($svc_domain);
507 $dbh->rollback if $oldAutoCommit;
512 foreach my $radius_usergroup (
513 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
515 my $error = $radius_usergroup->delete;
517 $dbh->rollback if $oldAutoCommit;
522 my $error = $self->SUPER::delete;
524 $dbh->rollback if $oldAutoCommit;
528 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
532 =item replace OLD_RECORD
534 Replaces OLD_RECORD with this one in the database. If there is an error,
535 returns the error, otherwise returns false.
537 The additional field I<usergroup> can optionally be defined; if so it should
538 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
539 sqlradius export only)
544 my ( $new, $old ) = ( shift, shift );
546 warn "$me replacing $old with $new\n" if $DEBUG;
548 return "can't modify system account" if $old->_check_system;
550 return "Username in use"
551 if $old->username ne $new->username &&
552 qsearchs( 'svc_acct', { 'username' => $new->username,
553 'domsvc' => $new->domsvc,
556 #no warnings 'numeric'; #alas, a 5.006-ism
558 return "Can't change uid!" if $old->uid != $new->uid;
561 #change homdir when we change username
562 $new->setfield('dir', '') if $old->username ne $new->username;
564 local $SIG{HUP} = 'IGNORE';
565 local $SIG{INT} = 'IGNORE';
566 local $SIG{QUIT} = 'IGNORE';
567 local $SIG{TERM} = 'IGNORE';
568 local $SIG{TSTP} = 'IGNORE';
569 local $SIG{PIPE} = 'IGNORE';
571 my $oldAutoCommit = $FS::UID::AutoCommit;
572 local $FS::UID::AutoCommit = 0;
575 # redundant, but so $new->usergroup gets set
576 $error = $new->check;
577 return $error if $error;
579 $old->usergroup( [ $old->radius_groups ] );
580 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
581 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
582 if ( $new->usergroup ) {
583 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
584 my @newgroups = @{$new->usergroup};
585 foreach my $oldgroup ( @{$old->usergroup} ) {
586 if ( grep { $oldgroup eq $_ } @newgroups ) {
587 @newgroups = grep { $oldgroup ne $_ } @newgroups;
590 my $radius_usergroup = qsearchs('radius_usergroup', {
591 svcnum => $old->svcnum,
592 groupname => $oldgroup,
594 my $error = $radius_usergroup->delete;
596 $dbh->rollback if $oldAutoCommit;
597 return "error deleting radius_usergroup $oldgroup: $error";
601 foreach my $newgroup ( @newgroups ) {
602 my $radius_usergroup = new FS::radius_usergroup ( {
603 svcnum => $new->svcnum,
604 groupname => $newgroup,
606 my $error = $radius_usergroup->insert;
608 $dbh->rollback if $oldAutoCommit;
609 return "error adding radius_usergroup $newgroup: $error";
615 $error = $new->SUPER::replace($old);
617 $dbh->rollback if $oldAutoCommit;
618 return $error if $error;
621 if ( $new->username ne $old->username ) {
622 #false laziness with sub insert (and cust_main)
623 my $queue = new FS::queue {
624 'svcnum' => $new->svcnum,
625 'job' => 'FS::svc_acct::append_fuzzyfiles'
627 $error = $queue->insert($new->username);
629 $dbh->rollback if $oldAutoCommit;
630 return "queueing job (transaction rolled back): $error";
634 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
640 Suspends this account by calling export-specific suspend hooks. If there is
641 an error, returns the error, otherwise returns false.
643 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
649 return "can't suspend system account" if $self->_check_system;
650 $self->SUPER::suspend;
655 Unsuspends this account by by calling export-specific suspend hooks. If there
656 is an error, returns the error, otherwise returns false.
658 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
664 my %hash = $self->hash;
665 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
666 $hash{_password} = $1;
667 my $new = new FS::svc_acct ( \%hash );
668 my $error = $new->replace($self);
669 return $error if $error;
672 $self->SUPER::unsuspend;
677 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
679 If the B<auto_unset_catchall> configuration option is set, this method will
680 automatically remove any references to the canceled service in the catchall
681 field of svc_domain. This allows packages that contain both a svc_domain and
682 its catchall svc_acct to be canceled in one step.
687 # Only one thing to do at this level
689 foreach my $svc_domain (
690 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
691 if($conf->exists('auto_unset_catchall')) {
692 my %hash = $svc_domain->hash;
693 $hash{catchall} = '';
694 my $new = new FS::svc_domain ( \%hash );
695 my $error = $new->replace($svc_domain);
696 return $error if $error;
698 return "cannot unprovision svc_acct #".$self->svcnum.
699 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
703 $self->SUPER::cancel;
709 Checks all fields to make sure this is a valid service. If there is an error,
710 returns the error, otherwise returns false. Called by the insert and replace
713 Sets any fixed values; see L<FS::part_svc>.
720 my($recref) = $self->hashref;
722 my $x = $self->setfixed;
723 return $x unless ref($x);
726 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
728 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
731 my $error = $self->ut_numbern('svcnum')
732 #|| $self->ut_number('domsvc')
733 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
734 || $self->ut_textn('sec_phrase')
736 return $error if $error;
738 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
739 if ( $username_uppercase ) {
740 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
741 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
742 $recref->{username} = $1;
744 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
745 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
746 $recref->{username} = $1;
749 if ( $username_letterfirst ) {
750 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
751 } elsif ( $username_letter ) {
752 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
754 if ( $username_noperiod ) {
755 $recref->{username} =~ /\./ and return gettext('illegal_username');
757 if ( $username_nounderscore ) {
758 $recref->{username} =~ /_/ and return gettext('illegal_username');
760 if ( $username_nodash ) {
761 $recref->{username} =~ /\-/ and return gettext('illegal_username');
763 unless ( $username_ampersand ) {
764 $recref->{username} =~ /\&/ and return gettext('illegal_username');
767 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
768 $recref->{popnum} = $1;
769 return "Unknown popnum" unless
770 ! $recref->{popnum} ||
771 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
773 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
775 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
776 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
778 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
779 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
780 #not all systems use gid=uid
781 #you can set a fixed gid in part_svc
783 return "Only root can have uid 0"
784 if $recref->{uid} == 0
785 && $recref->{username} ne 'root'
786 && $recref->{username} ne 'toor';
789 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
790 or return "Illegal directory: ". $recref->{dir};
792 return "Illegal directory"
793 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
794 return "Illegal directory"
795 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
796 unless ( $recref->{dir} ) {
797 $recref->{dir} = $dir_prefix . '/';
798 if ( $dirhash > 0 ) {
799 for my $h ( 1 .. $dirhash ) {
800 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
802 } elsif ( $dirhash < 0 ) {
803 for my $h ( reverse $dirhash .. -1 ) {
804 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
807 $recref->{dir} .= $recref->{username};
811 unless ( $recref->{username} eq 'sync' ) {
812 if ( grep $_ eq $recref->{shell}, @shells ) {
813 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
815 return "Illegal shell \`". $self->shell. "\'; ".
816 $conf->dir. "/shells contains: @shells";
819 $recref->{shell} = '/bin/sync';
823 $recref->{gid} ne '' ?
824 return "Can't have gid without uid" : ( $recref->{gid}='' );
825 $recref->{dir} ne '' ?
826 return "Can't have directory without uid" : ( $recref->{dir}='' );
827 $recref->{shell} ne '' ?
828 return "Can't have shell without uid" : ( $recref->{shell}='' );
831 # $error = $self->ut_textn('finger');
832 # return $error if $error;
833 $self->getfield('finger') =~
834 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
835 or return "Illegal finger: ". $self->getfield('finger');
836 $self->setfield('finger', $1);
838 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
839 $recref->{quota} = $1;
841 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
842 if ( $recref->{slipip} eq '' ) {
843 $recref->{slipip} = '';
844 } elsif ( $recref->{slipip} eq '0e0' ) {
845 $recref->{slipip} = '0e0';
847 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
848 or return "Illegal slipip: ". $self->slipip;
849 $recref->{slipip} = $1;
854 #arbitrary RADIUS stuff; allow ut_textn for now
855 foreach ( grep /^radius_/, fields('svc_acct') ) {
859 #generate a password if it is blank
860 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
861 unless ( $recref->{_password} );
863 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
864 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
865 $recref->{_password} = $1.$3;
866 #uncomment this to encrypt password immediately upon entry, or run
867 #bin/crypt_pw in cron to give new users a window during which their
868 #password is available to techs, for faxing, etc. (also be aware of
870 #$recref->{password} = $1.
871 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
873 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
874 $recref->{_password} = $1.$3;
875 } elsif ( $recref->{_password} eq '*' ) {
876 $recref->{_password} = '*';
877 } elsif ( $recref->{_password} eq '!' ) {
878 $recref->{_password} = '!';
879 } elsif ( $recref->{_password} eq '!!' ) {
880 $recref->{_password} = '!!';
882 #return "Illegal password";
883 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
884 FS::Msgcat::_gettext('illegal_password_characters').
885 ": ". $recref->{_password};
897 scalar( grep { $self->username eq $_ || $self->email eq $_ }
898 $conf->config('system_usernames')
904 Depriciated, use radius_reply instead.
909 carp "FS::svc_acct::radius depriciated, use radius_reply";
915 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
916 reply attributes of this record.
918 Note that this is now the preferred method for reading RADIUS attributes -
919 accessing the columns directly is discouraged, as the column names are
920 expected to change in the future.
929 my($column, $attrib) = ($1, $2);
930 #$attrib =~ s/_/\-/g;
931 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
932 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
933 if ( $self->slipip && $self->slipip ne '0e0' ) {
934 $reply{$radius_ip} = $self->slipip;
941 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
942 check attributes of this record.
944 Note that this is now the preferred method for reading RADIUS attributes -
945 accessing the columns directly is discouraged, as the column names are
946 expected to change in the future.
952 my $password = $self->_password;
953 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
954 ( $pw_attrib => $password,
957 my($column, $attrib) = ($1, $2);
958 #$attrib =~ s/_/\-/g;
959 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
960 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
966 Returns the domain associated with this account.
972 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
973 my $svc_domain = $self->svc_domain
974 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
980 Returns the FS::svc_domain record for this account's domain (see
989 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
994 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1000 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
1005 Returns an email address associated with the account.
1011 $self->username. '@'. $self->domain;
1016 Returns an array of FS::acct_snarf records associated with the account.
1017 If the acct_snarf table does not exist or there are no associated records,
1018 an empty list is returned
1024 return () unless dbdef->table('acct_snarf');
1025 eval "use FS::acct_snarf;";
1027 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1030 =item seconds_since TIMESTAMP
1032 Returns the number of seconds this account has been online since TIMESTAMP,
1033 according to the session monitor (see L<FS::Session>).
1035 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1036 L<Time::Local> and L<Date::Parse> for conversion functions.
1040 #note: POD here, implementation in FS::cust_svc
1043 $self->cust_svc->seconds_since(@_);
1046 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1048 Returns the numbers of seconds this account has been online between
1049 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1050 external SQL radacct table, specified via sqlradius export. Sessions which
1051 started in the specified range but are still open are counted from session
1052 start to the end of the range (unless they are over 1 day old, in which case
1053 they are presumed missing their stop record and not counted). Also, sessions
1054 which end in the range but started earlier are counted from the start of the
1055 range to session end. Finally, sessions which start before the range but end
1056 after are counted for the entire range.
1058 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1059 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1064 #note: POD here, implementation in FS::cust_svc
1065 sub seconds_since_sqlradacct {
1067 $self->cust_svc->seconds_since_sqlradacct(@_);
1070 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1072 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1073 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1074 TIMESTAMP_END (exclusive).
1076 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1077 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1082 #note: POD here, implementation in FS::cust_svc
1083 sub attribute_since_sqlradacct {
1085 $self->cust_svc->attribute_since_sqlradacct(@_);
1088 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1090 Returns an array of hash references of this customers login history for the
1091 given time range. (document this better)
1095 sub get_session_history_sqlradacct {
1097 $self->cust_svc->get_session_history_sqlradacct(@_);
1102 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1108 if ( $self->usergroup ) {
1109 #when provisioning records, export callback runs in svc_Common.pm before
1110 #radius_usergroup records can be inserted...
1111 @{$self->usergroup};
1113 map { $_->groupname }
1114 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1118 =item clone_suspended
1120 Constructor used by FS::part_export::_export_suspend fallback. Document
1125 sub clone_suspended {
1127 my %hash = $self->hash;
1128 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1129 new FS::svc_acct \%hash;
1132 =item clone_kludge_unsuspend
1134 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1139 sub clone_kludge_unsuspend {
1141 my %hash = $self->hash;
1142 $hash{_password} = '';
1143 new FS::svc_acct \%hash;
1146 =item check_password
1148 Checks the supplied password against the (possibly encrypted) password in the
1149 database. Returns true for a sucessful authentication, false for no match.
1151 Currently supported encryptions are: classic DES crypt() and MD5
1155 sub check_password {
1156 my($self, $check_password) = @_;
1158 #remove old-style SUSPENDED kludge, they should be allowed to login to
1159 #self-service and pay up
1160 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1162 #eventually should check a "password-encoding" field
1163 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1165 } elsif ( length($password) < 13 ) { #plaintext
1166 $check_password eq $password;
1167 } elsif ( length($password) == 13 ) { #traditional DES crypt
1168 crypt($check_password, $password) eq $password;
1169 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1170 unix_md5_crypt($check_password, $password) eq $password;
1171 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1172 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1173 $self->svcnum. "\n";
1176 warn "Can't check password: Unrecognized encryption for svcnum ".
1177 $self->svcnum. "\n";
1191 This is the FS::svc_acct job-queue-able version. It still uses
1192 FS::Misc::send_email under-the-hood.
1199 eval "use FS::Misc qw(send_email)";
1202 $opt{mimetype} ||= 'text/plain';
1203 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1205 my $error = send_email(
1206 'from' => $opt{from},
1208 'subject' => $opt{subject},
1209 'content-type' => $opt{mimetype},
1210 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1212 die $error if $error;
1215 =item check_and_rebuild_fuzzyfiles
1219 sub check_and_rebuild_fuzzyfiles {
1220 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1221 -e "$dir/svc_acct.username"
1222 or &rebuild_fuzzyfiles;
1225 =item rebuild_fuzzyfiles
1229 sub rebuild_fuzzyfiles {
1231 use Fcntl qw(:flock);
1233 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1237 open(USERNAMELOCK,">>$dir/svc_acct.username")
1238 or die "can't open $dir/svc_acct.username: $!";
1239 flock(USERNAMELOCK,LOCK_EX)
1240 or die "can't lock $dir/svc_acct.username: $!";
1242 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1244 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1245 or die "can't open $dir/svc_acct.username.tmp: $!";
1246 print USERNAMECACHE join("\n", @all_username), "\n";
1247 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1249 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1259 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1260 open(USERNAMECACHE,"<$dir/svc_acct.username")
1261 or die "can't open $dir/svc_acct.username: $!";
1262 my @array = map { chomp; $_; } <USERNAMECACHE>;
1263 close USERNAMECACHE;
1267 =item append_fuzzyfiles USERNAME
1271 sub append_fuzzyfiles {
1272 my $username = shift;
1274 &check_and_rebuild_fuzzyfiles;
1276 use Fcntl qw(:flock);
1278 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1280 open(USERNAME,">>$dir/svc_acct.username")
1281 or die "can't open $dir/svc_acct.username: $!";
1282 flock(USERNAME,LOCK_EX)
1283 or die "can't lock $dir/svc_acct.username: $!";
1285 print USERNAME "$username\n";
1287 flock(USERNAME,LOCK_UN)
1288 or die "can't unlock $dir/svc_acct.username: $!";
1296 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1300 sub radius_usergroup_selector {
1301 my $sel_groups = shift;
1302 my %sel_groups = map { $_=>1 } @$sel_groups;
1304 my $selectname = shift || 'radius_usergroup';
1307 my $sth = $dbh->prepare(
1308 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1309 ) or die $dbh->errstr;
1310 $sth->execute() or die $sth->errstr;
1311 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1315 function ${selectname}_doadd(object) {
1316 var myvalue = object.${selectname}_add.value;
1317 var optionName = new Option(myvalue,myvalue,false,true);
1318 var length = object.$selectname.length;
1319 object.$selectname.options[length] = optionName;
1320 object.${selectname}_add.value = "";
1323 <SELECT MULTIPLE NAME="$selectname">
1326 foreach my $group ( @all_groups ) {
1328 if ( $sel_groups{$group} ) {
1329 $html .= ' SELECTED';
1330 $sel_groups{$group} = 0;
1332 $html .= ">$group</OPTION>\n";
1334 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1335 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1337 $html .= '</SELECT>';
1339 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1340 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1349 The $recref stuff in sub check should be cleaned up.
1351 The suspend, unsuspend and cancel methods update the database, but not the
1352 current object. This is probably a bug as it's unexpected and
1355 radius_usergroup_selector? putting web ui components in here? they should
1356 probably live somewhere else...
1358 insertion of RADIUS group stuff in insert could be done with child_objects now
1359 (would probably clean up export of them too)
1363 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1364 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1365 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1366 L<freeside-queued>), L<FS::svc_acct_pop>,
1367 schema.html from the base documentation.