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 Just returns false (no error) for now.
679 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
683 Checks all fields to make sure this is a valid service. If there is an error,
684 returns the error, otherwise returns false. Called by the insert and replace
687 Sets any fixed values; see L<FS::part_svc>.
694 my($recref) = $self->hashref;
696 my $x = $self->setfixed;
697 return $x unless ref($x);
700 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
702 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
705 my $error = $self->ut_numbern('svcnum')
706 #|| $self->ut_number('domsvc')
707 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
708 || $self->ut_textn('sec_phrase')
710 return $error if $error;
712 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
713 if ( $username_uppercase ) {
714 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
715 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
716 $recref->{username} = $1;
718 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
719 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
720 $recref->{username} = $1;
723 if ( $username_letterfirst ) {
724 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
725 } elsif ( $username_letter ) {
726 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
728 if ( $username_noperiod ) {
729 $recref->{username} =~ /\./ and return gettext('illegal_username');
731 if ( $username_nounderscore ) {
732 $recref->{username} =~ /_/ and return gettext('illegal_username');
734 if ( $username_nodash ) {
735 $recref->{username} =~ /\-/ and return gettext('illegal_username');
737 unless ( $username_ampersand ) {
738 $recref->{username} =~ /\&/ and return gettext('illegal_username');
741 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
742 $recref->{popnum} = $1;
743 return "Unknown popnum" unless
744 ! $recref->{popnum} ||
745 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
747 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
749 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
750 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
752 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
753 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
754 #not all systems use gid=uid
755 #you can set a fixed gid in part_svc
757 return "Only root can have uid 0"
758 if $recref->{uid} == 0
759 && $recref->{username} ne 'root'
760 && $recref->{username} ne 'toor';
763 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
764 or return "Illegal directory: ". $recref->{dir};
766 return "Illegal directory"
767 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
768 return "Illegal directory"
769 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
770 unless ( $recref->{dir} ) {
771 $recref->{dir} = $dir_prefix . '/';
772 if ( $dirhash > 0 ) {
773 for my $h ( 1 .. $dirhash ) {
774 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
776 } elsif ( $dirhash < 0 ) {
777 for my $h ( reverse $dirhash .. -1 ) {
778 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
781 $recref->{dir} .= $recref->{username};
785 unless ( $recref->{username} eq 'sync' ) {
786 if ( grep $_ eq $recref->{shell}, @shells ) {
787 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
789 return "Illegal shell \`". $self->shell. "\'; ".
790 $conf->dir. "/shells contains: @shells";
793 $recref->{shell} = '/bin/sync';
797 $recref->{gid} ne '' ?
798 return "Can't have gid without uid" : ( $recref->{gid}='' );
799 $recref->{dir} ne '' ?
800 return "Can't have directory without uid" : ( $recref->{dir}='' );
801 $recref->{shell} ne '' ?
802 return "Can't have shell without uid" : ( $recref->{shell}='' );
805 # $error = $self->ut_textn('finger');
806 # return $error if $error;
807 $self->getfield('finger') =~
808 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
809 or return "Illegal finger: ". $self->getfield('finger');
810 $self->setfield('finger', $1);
812 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
813 $recref->{quota} = $1;
815 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
816 if ( $recref->{slipip} eq '' ) {
817 $recref->{slipip} = '';
818 } elsif ( $recref->{slipip} eq '0e0' ) {
819 $recref->{slipip} = '0e0';
821 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
822 or return "Illegal slipip: ". $self->slipip;
823 $recref->{slipip} = $1;
828 #arbitrary RADIUS stuff; allow ut_textn for now
829 foreach ( grep /^radius_/, fields('svc_acct') ) {
833 #generate a password if it is blank
834 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
835 unless ( $recref->{_password} );
837 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
838 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
839 $recref->{_password} = $1.$3;
840 #uncomment this to encrypt password immediately upon entry, or run
841 #bin/crypt_pw in cron to give new users a window during which their
842 #password is available to techs, for faxing, etc. (also be aware of
844 #$recref->{password} = $1.
845 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
847 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
848 $recref->{_password} = $1.$3;
849 } elsif ( $recref->{_password} eq '*' ) {
850 $recref->{_password} = '*';
851 } elsif ( $recref->{_password} eq '!' ) {
852 $recref->{_password} = '!';
853 } elsif ( $recref->{_password} eq '!!' ) {
854 $recref->{_password} = '!!';
856 #return "Illegal password";
857 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
858 FS::Msgcat::_gettext('illegal_password_characters').
859 ": ". $recref->{_password};
871 scalar( grep { $self->username eq $_ || $self->email eq $_ }
872 $conf->config('system_usernames')
878 Depriciated, use radius_reply instead.
883 carp "FS::svc_acct::radius depriciated, use radius_reply";
889 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
890 reply attributes of this record.
892 Note that this is now the preferred method for reading RADIUS attributes -
893 accessing the columns directly is discouraged, as the column names are
894 expected to change in the future.
903 my($column, $attrib) = ($1, $2);
904 #$attrib =~ s/_/\-/g;
905 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
906 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
907 if ( $self->slipip && $self->slipip ne '0e0' ) {
908 $reply{$radius_ip} = $self->slipip;
915 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
916 check 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.
926 my $password = $self->_password;
927 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
928 ( $pw_attrib => $password,
931 my($column, $attrib) = ($1, $2);
932 #$attrib =~ s/_/\-/g;
933 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
934 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
940 Returns the domain associated with this account.
946 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
947 my $svc_domain = $self->svc_domain
948 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
954 Returns the FS::svc_domain record for this account's domain (see
963 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
968 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
974 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
979 Returns an email address associated with the account.
985 $self->username. '@'. $self->domain;
990 Returns an array of FS::acct_snarf records associated with the account.
991 If the acct_snarf table does not exist or there are no associated records,
992 an empty list is returned
998 return () unless dbdef->table('acct_snarf');
999 eval "use FS::acct_snarf;";
1001 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1004 =item seconds_since TIMESTAMP
1006 Returns the number of seconds this account has been online since TIMESTAMP,
1007 according to the session monitor (see L<FS::Session>).
1009 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1010 L<Time::Local> and L<Date::Parse> for conversion functions.
1014 #note: POD here, implementation in FS::cust_svc
1017 $self->cust_svc->seconds_since(@_);
1020 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1022 Returns the numbers of seconds this account has been online between
1023 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1024 external SQL radacct table, specified via sqlradius export. Sessions which
1025 started in the specified range but are still open are counted from session
1026 start to the end of the range (unless they are over 1 day old, in which case
1027 they are presumed missing their stop record and not counted). Also, sessions
1028 which end in the range but started earlier are counted from the start of the
1029 range to session end. Finally, sessions which start before the range but end
1030 after are counted for the entire range.
1032 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1033 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1038 #note: POD here, implementation in FS::cust_svc
1039 sub seconds_since_sqlradacct {
1041 $self->cust_svc->seconds_since_sqlradacct(@_);
1044 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1046 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1047 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1048 TIMESTAMP_END (exclusive).
1050 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1051 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1056 #note: POD here, implementation in FS::cust_svc
1057 sub attribute_since_sqlradacct {
1059 $self->cust_svc->attribute_since_sqlradacct(@_);
1062 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1064 Returns an array of hash references of this customers login history for the
1065 given time range. (document this better)
1069 sub get_session_history_sqlradacct {
1071 $self->cust_svc->get_session_history_sqlradacct(@_);
1076 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1082 if ( $self->usergroup ) {
1083 #when provisioning records, export callback runs in svc_Common.pm before
1084 #radius_usergroup records can be inserted...
1085 @{$self->usergroup};
1087 map { $_->groupname }
1088 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1092 =item clone_suspended
1094 Constructor used by FS::part_export::_export_suspend fallback. Document
1099 sub clone_suspended {
1101 my %hash = $self->hash;
1102 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1103 new FS::svc_acct \%hash;
1106 =item clone_kludge_unsuspend
1108 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1113 sub clone_kludge_unsuspend {
1115 my %hash = $self->hash;
1116 $hash{_password} = '';
1117 new FS::svc_acct \%hash;
1120 =item check_password
1122 Checks the supplied password against the (possibly encrypted) password in the
1123 database. Returns true for a sucessful authentication, false for no match.
1125 Currently supported encryptions are: classic DES crypt() and MD5
1129 sub check_password {
1130 my($self, $check_password) = @_;
1132 #remove old-style SUSPENDED kludge, they should be allowed to login to
1133 #self-service and pay up
1134 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1136 #eventually should check a "password-encoding" field
1137 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1139 } elsif ( length($password) < 13 ) { #plaintext
1140 $check_password eq $password;
1141 } elsif ( length($password) == 13 ) { #traditional DES crypt
1142 crypt($check_password, $password) eq $password;
1143 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1144 unix_md5_crypt($check_password, $password) eq $password;
1145 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1146 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1147 $self->svcnum. "\n";
1150 warn "Can't check password: Unrecognized encryption for svcnum ".
1151 $self->svcnum. "\n";
1165 This is the FS::svc_acct job-queue-able version. It still uses
1166 FS::Misc::send_email under-the-hood.
1173 eval "use FS::Misc qw(send_email)";
1176 $opt{mimetype} ||= 'text/plain';
1177 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1179 my $error = send_email(
1180 'from' => $opt{from},
1182 'subject' => $opt{subject},
1183 'content-type' => $opt{mimetype},
1184 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1186 die $error if $error;
1189 =item check_and_rebuild_fuzzyfiles
1193 sub check_and_rebuild_fuzzyfiles {
1194 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1195 -e "$dir/svc_acct.username"
1196 or &rebuild_fuzzyfiles;
1199 =item rebuild_fuzzyfiles
1203 sub rebuild_fuzzyfiles {
1205 use Fcntl qw(:flock);
1207 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1211 open(USERNAMELOCK,">>$dir/svc_acct.username")
1212 or die "can't open $dir/svc_acct.username: $!";
1213 flock(USERNAMELOCK,LOCK_EX)
1214 or die "can't lock $dir/svc_acct.username: $!";
1216 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1218 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1219 or die "can't open $dir/svc_acct.username.tmp: $!";
1220 print USERNAMECACHE join("\n", @all_username), "\n";
1221 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1223 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1233 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1234 open(USERNAMECACHE,"<$dir/svc_acct.username")
1235 or die "can't open $dir/svc_acct.username: $!";
1236 my @array = map { chomp; $_; } <USERNAMECACHE>;
1237 close USERNAMECACHE;
1241 =item append_fuzzyfiles USERNAME
1245 sub append_fuzzyfiles {
1246 my $username = shift;
1248 &check_and_rebuild_fuzzyfiles;
1250 use Fcntl qw(:flock);
1252 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1254 open(USERNAME,">>$dir/svc_acct.username")
1255 or die "can't open $dir/svc_acct.username: $!";
1256 flock(USERNAME,LOCK_EX)
1257 or die "can't lock $dir/svc_acct.username: $!";
1259 print USERNAME "$username\n";
1261 flock(USERNAME,LOCK_UN)
1262 or die "can't unlock $dir/svc_acct.username: $!";
1270 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1274 sub radius_usergroup_selector {
1275 my $sel_groups = shift;
1276 my %sel_groups = map { $_=>1 } @$sel_groups;
1278 my $selectname = shift || 'radius_usergroup';
1281 my $sth = $dbh->prepare(
1282 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1283 ) or die $dbh->errstr;
1284 $sth->execute() or die $sth->errstr;
1285 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1289 function ${selectname}_doadd(object) {
1290 var myvalue = object.${selectname}_add.value;
1291 var optionName = new Option(myvalue,myvalue,false,true);
1292 var length = object.$selectname.length;
1293 object.$selectname.options[length] = optionName;
1294 object.${selectname}_add.value = "";
1297 <SELECT MULTIPLE NAME="$selectname">
1300 foreach my $group ( @all_groups ) {
1302 if ( $sel_groups{$group} ) {
1303 $html .= ' SELECTED';
1304 $sel_groups{$group} = 0;
1306 $html .= ">$group</OPTION>\n";
1308 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1309 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1311 $html .= '</SELECT>';
1313 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1314 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1323 The $recref stuff in sub check should be cleaned up.
1325 The suspend, unsuspend and cancel methods update the database, but not the
1326 current object. This is probably a bug as it's unexpected and
1329 radius_usergroup_selector? putting web ui components in here? they should
1330 probably live somewhere else...
1332 insertion of RADIUS group stuff in insert could be done with child_objects now
1333 (would probably clean up export of them too)
1337 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1338 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1339 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1340 L<freeside-queued>), L<FS::svc_acct_pop>,
1341 schema.html from the base documentation.