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
17 use FS::UID qw( datasrc );
19 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
24 use FS::cust_main_invoice;
28 use FS::radius_usergroup;
31 use FS::Msgcat qw(gettext);
33 @ISA = qw( FS::svc_Common );
36 $me = '[FS::svc_acct]';
38 #ask FS::UID to run this stuff for us later
39 $FS::UID::callback{'FS::svc_acct'} = sub {
41 $dir_prefix = $conf->config('home');
42 @shells = $conf->config('shells');
43 $usernamemin = $conf->config('usernamemin') || 2;
44 $usernamemax = $conf->config('usernamemax');
45 $passwordmin = $conf->config('passwordmin') || 6;
46 $passwordmax = $conf->config('passwordmax') || 8;
47 $username_letter = $conf->exists('username-letter');
48 $username_letterfirst = $conf->exists('username-letterfirst');
49 $username_noperiod = $conf->exists('username-noperiod');
50 $username_nounderscore = $conf->exists('username-nounderscore');
51 $username_nodash = $conf->exists('username-nodash');
52 $username_uppercase = $conf->exists('username-uppercase');
53 $username_ampersand = $conf->exists('username-ampersand');
54 $dirhash = $conf->config('dirhash') || 0;
55 if ( $conf->exists('welcome_email') ) {
56 $welcome_template = new Text::Template (
58 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
59 ) or warn "can't create welcome email template: $Text::Template::ERROR";
60 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
61 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
62 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
64 $welcome_template = '';
66 $welcome_subject = '';
67 $welcome_mimetype = '';
69 $smtpmachine = $conf->config('smtpmachine');
70 $radius_password = $conf->config('radius-password') || 'Password';
71 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
74 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
75 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
79 my ( $hashref, $cache ) = @_;
80 if ( $hashref->{'svc_acct_svcnum'} ) {
81 $self->{'_domsvc'} = FS::svc_domain->new( {
82 'svcnum' => $hashref->{'domsvc'},
83 'domain' => $hashref->{'svc_acct_domain'},
84 'catchall' => $hashref->{'svc_acct_catchall'},
91 FS::svc_acct - Object methods for svc_acct records
97 $record = new FS::svc_acct \%hash;
98 $record = new FS::svc_acct { 'column' => 'value' };
100 $error = $record->insert;
102 $error = $new_record->replace($old_record);
104 $error = $record->delete;
106 $error = $record->check;
108 $error = $record->suspend;
110 $error = $record->unsuspend;
112 $error = $record->cancel;
114 %hash = $record->radius;
116 %hash = $record->radius_reply;
118 %hash = $record->radius_check;
120 $domain = $record->domain;
122 $svc_domain = $record->svc_domain;
124 $email = $record->email;
126 $seconds_since = $record->seconds_since($timestamp);
130 An FS::svc_acct object represents an account. FS::svc_acct inherits from
131 FS::svc_Common. The following fields are currently supported:
135 =item svcnum - primary key (assigned automatcially for new accounts)
139 =item _password - generated if blank
141 =item sec_phrase - security phrase
143 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
151 =item dir - set automatically if blank (and uid is not)
155 =item quota - (unimplementd)
157 =item slipip - IP address
161 =item domsvc - svcnum from svc_domain
163 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
173 Creates a new account. To add the account to the database, see L<"insert">.
177 sub table { 'svc_acct'; }
181 Adds this account to the database. If there is an error, returns the error,
182 otherwise returns false.
184 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
185 defined. An FS::cust_svc record will be created and inserted.
187 The additional field I<usergroup> can optionally be defined; if so it should
188 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
189 sqlradius export only)
191 The additional field I<child_objects> can optionally be defined; if so it
192 should contain an arrayref of FS::tablename objects. They will have their
193 svcnum fields set and will be inserted after this record, but before any
196 (TODOC: L<FS::queue> and L<freeside-queued>)
198 (TODOC: new exports!)
207 local $SIG{HUP} = 'IGNORE';
208 local $SIG{INT} = 'IGNORE';
209 local $SIG{QUIT} = 'IGNORE';
210 local $SIG{TERM} = 'IGNORE';
211 local $SIG{TSTP} = 'IGNORE';
212 local $SIG{PIPE} = 'IGNORE';
214 my $oldAutoCommit = $FS::UID::AutoCommit;
215 local $FS::UID::AutoCommit = 0;
218 $error = $self->check;
219 return $error if $error;
221 #no, duplicate checking just got a whole lot more complicated
222 #(perhaps keep this check with a config option to turn on?)
224 #return gettext('username_in_use'). ": ". $self->username
225 # if qsearchs( 'svc_acct', { 'username' => $self->username,
226 # 'domsvc' => $self->domsvc,
229 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
230 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
231 unless ( $cust_svc ) {
232 $dbh->rollback if $oldAutoCommit;
233 return "no cust_svc record found for svcnum ". $self->svcnum;
235 $self->pkgnum($cust_svc->pkgnum);
236 $self->svcpart($cust_svc->svcpart);
239 #new duplicate username checking
241 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
242 unless ( $part_svc ) {
243 $dbh->rollback if $oldAutoCommit;
244 return 'unknown svcpart '. $self->svcpart;
247 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
248 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
249 'domsvc' => $self->domsvc } );
251 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
252 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
253 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
258 if ( @dup_user || @dup_userdomain || @dup_uid ) {
259 my $exports = FS::part_export::export_info('svc_acct');
260 my %conflict_user_svcpart;
261 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
263 foreach my $part_export ( $part_svc->part_export ) {
265 #this will catch to the same exact export
266 my @svcparts = map { $_->svcpart }
267 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
269 #this will catch to exports w/same exporthost+type ???
270 #my @other_part_export = qsearch('part_export', {
271 # 'machine' => $part_export->machine,
272 # 'exporttype' => $part_export->exporttype,
274 #foreach my $other_part_export ( @other_part_export ) {
275 # push @svcparts, map { $_->svcpart }
276 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
279 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
280 #silly kludge to avoid uninitialized value errors
281 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
282 ? $exports->{$part_export->exporttype}{'nodomain'}
284 if ( $nodomain =~ /^Y/i ) {
285 $conflict_user_svcpart{$_} = $part_export->exportnum
288 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
293 foreach my $dup_user ( @dup_user ) {
294 my $dup_svcpart = $dup_user->cust_svc->svcpart;
295 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
296 $dbh->rollback if $oldAutoCommit;
297 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
298 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
302 foreach my $dup_userdomain ( @dup_userdomain ) {
303 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
304 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
305 $dbh->rollback if $oldAutoCommit;
306 return "duplicate username\@domain: conflicts with svcnum ".
307 $dup_userdomain->svcnum. " via exportnum ".
308 $conflict_userdomain_svcpart{$dup_svcpart};
312 foreach my $dup_uid ( @dup_uid ) {
313 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
314 if ( exists($conflict_user_svcpart{$dup_svcpart})
315 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
316 $dbh->rollback if $oldAutoCommit;
317 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
318 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
319 || $conflict_userdomain_svcpart{$dup_svcpart};
325 #see? i told you it was more complicated
328 $error = $self->SUPER::insert(\@jobnums, $self->child_objects || [] );
330 $dbh->rollback if $oldAutoCommit;
334 if ( $self->usergroup ) {
335 foreach my $groupname ( @{$self->usergroup} ) {
336 my $radius_usergroup = new FS::radius_usergroup ( {
337 svcnum => $self->svcnum,
338 groupname => $groupname,
340 my $error = $radius_usergroup->insert;
342 $dbh->rollback if $oldAutoCommit;
348 #false laziness with sub replace (and cust_main)
349 my $queue = new FS::queue {
350 'svcnum' => $self->svcnum,
351 'job' => 'FS::svc_acct::append_fuzzyfiles'
353 $error = $queue->insert($self->username);
355 $dbh->rollback if $oldAutoCommit;
356 return "queueing job (transaction rolled back): $error";
359 my $cust_pkg = $self->cust_svc->cust_pkg;
362 my $cust_main = $cust_pkg->cust_main;
364 if ( $conf->exists('emailinvoiceauto') ) {
365 my @invoicing_list = $cust_main->invoicing_list;
366 push @invoicing_list, $self->email;
367 $cust_main->invoicing_list(\@invoicing_list);
372 if ( $welcome_template && $cust_pkg ) {
373 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
375 my $wqueue = new FS::queue {
376 'svcnum' => $self->svcnum,
377 'job' => 'FS::svc_acct::send_email'
379 my $error = $wqueue->insert(
381 'from' => $welcome_from,
382 'subject' => $welcome_subject,
383 'mimetype' => $welcome_mimetype,
384 'body' => $welcome_template->fill_in( HASH => {
385 'custnum' => $self->custnum,
386 'username' => $self->username,
387 'password' => $self->_password,
388 'first' => $cust_main->first,
389 'last' => $cust_main->getfield('last'),
390 'pkg' => $cust_pkg->part_pkg->pkg,
394 $dbh->rollback if $oldAutoCommit;
395 return "error queuing welcome email: $error";
398 foreach my $jobnum ( @jobnums ) {
399 my $error = $wqueue->depend_insert($jobnum);
401 $dbh->rollback if $oldAutoCommit;
402 return "error queuing welcome email job dependancy: $error";
412 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
418 Deletes this account from the database. If there is an error, returns the
419 error, otherwise returns false.
421 The corresponding FS::cust_svc record will be deleted as well.
423 (TODOC: new exports!)
430 return "can't delete system account" if $self->_check_system;
432 return "Can't delete an account which is a (svc_forward) source!"
433 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
435 return "Can't delete an account which is a (svc_forward) destination!"
436 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
438 return "Can't delete an account with (svc_www) web service!"
439 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
441 # what about records in session ? (they should refer to history table)
443 local $SIG{HUP} = 'IGNORE';
444 local $SIG{INT} = 'IGNORE';
445 local $SIG{QUIT} = 'IGNORE';
446 local $SIG{TERM} = 'IGNORE';
447 local $SIG{TSTP} = 'IGNORE';
448 local $SIG{PIPE} = 'IGNORE';
450 my $oldAutoCommit = $FS::UID::AutoCommit;
451 local $FS::UID::AutoCommit = 0;
454 foreach my $cust_main_invoice (
455 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
457 unless ( defined($cust_main_invoice) ) {
458 warn "WARNING: something's wrong with qsearch";
461 my %hash = $cust_main_invoice->hash;
462 $hash{'dest'} = $self->email;
463 my $new = new FS::cust_main_invoice \%hash;
464 my $error = $new->replace($cust_main_invoice);
466 $dbh->rollback if $oldAutoCommit;
471 foreach my $svc_domain (
472 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
474 my %hash = new FS::svc_domain->hash;
475 $hash{'catchall'} = '';
476 my $new = new FS::svc_domain \%hash;
477 my $error = $new->replace($svc_domain);
479 $dbh->rollback if $oldAutoCommit;
484 foreach my $radius_usergroup (
485 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
487 my $error = $radius_usergroup->delete;
489 $dbh->rollback if $oldAutoCommit;
494 my $error = $self->SUPER::delete;
496 $dbh->rollback if $oldAutoCommit;
500 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
504 =item replace OLD_RECORD
506 Replaces OLD_RECORD with this one in the database. If there is an error,
507 returns the error, otherwise returns false.
509 The additional field I<usergroup> can optionally be defined; if so it should
510 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
511 sqlradius export only)
516 my ( $new, $old ) = ( shift, shift );
518 warn "$me replacing $old with $new\n" if $DEBUG;
520 return "can't modify system account" if $old->_check_system;
522 return "Username in use"
523 if $old->username ne $new->username &&
524 qsearchs( 'svc_acct', { 'username' => $new->username,
525 'domsvc' => $new->domsvc,
528 #no warnings 'numeric'; #alas, a 5.006-ism
530 return "Can't change uid!" if $old->uid != $new->uid;
533 #change homdir when we change username
534 $new->setfield('dir', '') if $old->username ne $new->username;
536 local $SIG{HUP} = 'IGNORE';
537 local $SIG{INT} = 'IGNORE';
538 local $SIG{QUIT} = 'IGNORE';
539 local $SIG{TERM} = 'IGNORE';
540 local $SIG{TSTP} = 'IGNORE';
541 local $SIG{PIPE} = 'IGNORE';
543 my $oldAutoCommit = $FS::UID::AutoCommit;
544 local $FS::UID::AutoCommit = 0;
547 # redundant, but so $new->usergroup gets set
548 $error = $new->check;
549 return $error if $error;
551 $old->usergroup( [ $old->radius_groups ] );
552 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
553 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
554 if ( $new->usergroup ) {
555 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
556 my @newgroups = @{$new->usergroup};
557 foreach my $oldgroup ( @{$old->usergroup} ) {
558 if ( grep { $oldgroup eq $_ } @newgroups ) {
559 @newgroups = grep { $oldgroup ne $_ } @newgroups;
562 my $radius_usergroup = qsearchs('radius_usergroup', {
563 svcnum => $old->svcnum,
564 groupname => $oldgroup,
566 my $error = $radius_usergroup->delete;
568 $dbh->rollback if $oldAutoCommit;
569 return "error deleting radius_usergroup $oldgroup: $error";
573 foreach my $newgroup ( @newgroups ) {
574 my $radius_usergroup = new FS::radius_usergroup ( {
575 svcnum => $new->svcnum,
576 groupname => $newgroup,
578 my $error = $radius_usergroup->insert;
580 $dbh->rollback if $oldAutoCommit;
581 return "error adding radius_usergroup $newgroup: $error";
587 $error = $new->SUPER::replace($old);
589 $dbh->rollback if $oldAutoCommit;
590 return $error if $error;
593 if ( $new->username ne $old->username ) {
594 #false laziness with sub insert (and cust_main)
595 my $queue = new FS::queue {
596 'svcnum' => $new->svcnum,
597 'job' => 'FS::svc_acct::append_fuzzyfiles'
599 $error = $queue->insert($new->username);
601 $dbh->rollback if $oldAutoCommit;
602 return "queueing job (transaction rolled back): $error";
606 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
612 Suspends this account by calling export-specific suspend hooks. If there is
613 an error, returns the error, otherwise returns false.
615 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
621 return "can't suspend system account" if $self->_check_system;
622 $self->SUPER::suspend;
627 Unsuspends this account by by calling export-specific suspend hooks. If there
628 is an error, returns the error, otherwise returns false.
630 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
636 my %hash = $self->hash;
637 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
638 $hash{_password} = $1;
639 my $new = new FS::svc_acct ( \%hash );
640 my $error = $new->replace($self);
641 return $error if $error;
644 $self->SUPER::unsuspend;
649 Just returns false (no error) for now.
651 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
655 Checks all fields to make sure this is a valid service. If there is an error,
656 returns the error, otherwise returns false. Called by the insert and replace
659 Sets any fixed values; see L<FS::part_svc>.
666 my($recref) = $self->hashref;
668 my $x = $self->setfixed;
669 return $x unless ref($x);
672 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
674 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
677 my $error = $self->ut_numbern('svcnum')
678 #|| $self->ut_number('domsvc')
679 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
680 || $self->ut_textn('sec_phrase')
682 return $error if $error;
684 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
685 if ( $username_uppercase ) {
686 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
687 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
688 $recref->{username} = $1;
690 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
691 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
692 $recref->{username} = $1;
695 if ( $username_letterfirst ) {
696 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
697 } elsif ( $username_letter ) {
698 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
700 if ( $username_noperiod ) {
701 $recref->{username} =~ /\./ and return gettext('illegal_username');
703 if ( $username_nounderscore ) {
704 $recref->{username} =~ /_/ and return gettext('illegal_username');
706 if ( $username_nodash ) {
707 $recref->{username} =~ /\-/ and return gettext('illegal_username');
709 unless ( $username_ampersand ) {
710 $recref->{username} =~ /\&/ and return gettext('illegal_username');
713 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
714 $recref->{popnum} = $1;
715 return "Unknown popnum" unless
716 ! $recref->{popnum} ||
717 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
719 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
721 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
722 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
724 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
725 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
726 #not all systems use gid=uid
727 #you can set a fixed gid in part_svc
729 return "Only root can have uid 0"
730 if $recref->{uid} == 0
731 && $recref->{username} ne 'root'
732 && $recref->{username} ne 'toor';
735 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
736 or return "Illegal directory: ". $recref->{dir};
738 return "Illegal directory"
739 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
740 return "Illegal directory"
741 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
742 unless ( $recref->{dir} ) {
743 $recref->{dir} = $dir_prefix . '/';
744 if ( $dirhash > 0 ) {
745 for my $h ( 1 .. $dirhash ) {
746 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
748 } elsif ( $dirhash < 0 ) {
749 for my $h ( reverse $dirhash .. -1 ) {
750 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
753 $recref->{dir} .= $recref->{username};
757 unless ( $recref->{username} eq 'sync' ) {
758 if ( grep $_ eq $recref->{shell}, @shells ) {
759 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
761 return "Illegal shell \`". $self->shell. "\'; ".
762 $conf->dir. "/shells contains: @shells";
765 $recref->{shell} = '/bin/sync';
769 $recref->{gid} ne '' ?
770 return "Can't have gid without uid" : ( $recref->{gid}='' );
771 $recref->{dir} ne '' ?
772 return "Can't have directory without uid" : ( $recref->{dir}='' );
773 $recref->{shell} ne '' ?
774 return "Can't have shell without uid" : ( $recref->{shell}='' );
777 # $error = $self->ut_textn('finger');
778 # return $error if $error;
779 $self->getfield('finger') =~
780 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
781 or return "Illegal finger: ". $self->getfield('finger');
782 $self->setfield('finger', $1);
784 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
785 $recref->{quota} = $1;
787 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
788 if ( $recref->{slipip} eq '' ) {
789 $recref->{slipip} = '';
790 } elsif ( $recref->{slipip} eq '0e0' ) {
791 $recref->{slipip} = '0e0';
793 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
794 or return "Illegal slipip: ". $self->slipip;
795 $recref->{slipip} = $1;
800 #arbitrary RADIUS stuff; allow ut_textn for now
801 foreach ( grep /^radius_/, fields('svc_acct') ) {
805 #generate a password if it is blank
806 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
807 unless ( $recref->{_password} );
809 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
810 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
811 $recref->{_password} = $1.$3;
812 #uncomment this to encrypt password immediately upon entry, or run
813 #bin/crypt_pw in cron to give new users a window during which their
814 #password is available to techs, for faxing, etc. (also be aware of
816 #$recref->{password} = $1.
817 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
819 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
820 $recref->{_password} = $1.$3;
821 } elsif ( $recref->{_password} eq '*' ) {
822 $recref->{_password} = '*';
823 } elsif ( $recref->{_password} eq '!' ) {
824 $recref->{_password} = '!';
825 } elsif ( $recref->{_password} eq '!!' ) {
826 $recref->{_password} = '!!';
828 #return "Illegal password";
829 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
830 FS::Msgcat::_gettext('illegal_password_characters').
831 ": ". $recref->{_password};
843 scalar( grep { $self->username eq $_ || $self->email eq $_ }
844 $conf->config('system_usernames')
850 Depriciated, use radius_reply instead.
855 carp "FS::svc_acct::radius depriciated, use radius_reply";
861 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
862 reply attributes of this record.
864 Note that this is now the preferred method for reading RADIUS attributes -
865 accessing the columns directly is discouraged, as the column names are
866 expected to change in the future.
875 my($column, $attrib) = ($1, $2);
876 #$attrib =~ s/_/\-/g;
877 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
878 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
879 if ( $self->slipip && $self->slipip ne '0e0' ) {
880 $reply{$radius_ip} = $self->slipip;
887 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
888 check attributes of this record.
890 Note that this is now the preferred method for reading RADIUS attributes -
891 accessing the columns directly is discouraged, as the column names are
892 expected to change in the future.
898 my $password = $self->_password;
899 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
900 ( $pw_attrib => $password,
903 my($column, $attrib) = ($1, $2);
904 #$attrib =~ s/_/\-/g;
905 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
906 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
912 Returns the domain associated with this account.
918 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
919 my $svc_domain = $self->svc_domain
920 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
926 Returns the FS::svc_domain record for this account's domain (see
935 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
940 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
946 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
951 Returns an email address associated with the account.
957 $self->username. '@'. $self->domain;
962 Returns an array of FS::acct_snarf records associated with the account.
963 If the acct_snarf table does not exist or there are no associated records,
964 an empty list is returned
970 return () unless dbdef->table('acct_snarf');
971 eval "use FS::acct_snarf;";
973 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
976 =item seconds_since TIMESTAMP
978 Returns the number of seconds this account has been online since TIMESTAMP,
979 according to the session monitor (see L<FS::Session>).
981 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
982 L<Time::Local> and L<Date::Parse> for conversion functions.
986 #note: POD here, implementation in FS::cust_svc
989 $self->cust_svc->seconds_since(@_);
992 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
994 Returns the numbers of seconds this account has been online between
995 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
996 external SQL radacct table, specified via sqlradius export. Sessions which
997 started in the specified range but are still open are counted from session
998 start to the end of the range (unless they are over 1 day old, in which case
999 they are presumed missing their stop record and not counted). Also, sessions
1000 which end in the range but started earlier are counted from the start of the
1001 range to session end. Finally, sessions which start before the range but end
1002 after are counted for the entire range.
1004 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1005 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1010 #note: POD here, implementation in FS::cust_svc
1011 sub seconds_since_sqlradacct {
1013 $self->cust_svc->seconds_since_sqlradacct(@_);
1016 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1018 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1019 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1020 TIMESTAMP_END (exclusive).
1022 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1023 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1028 #note: POD here, implementation in FS::cust_svc
1029 sub attribute_since_sqlradacct {
1031 $self->cust_svc->attribute_since_sqlradacct(@_);
1034 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1036 Returns an array of hash references of this customers login history for the
1037 given time range. (document this better)
1041 sub get_session_history_sqlradacct {
1043 $self->cust_svc->get_session_history_sqlradacct(@_);
1048 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1054 if ( $self->usergroup ) {
1055 #when provisioning records, export callback runs in svc_Common.pm before
1056 #radius_usergroup records can be inserted...
1057 @{$self->usergroup};
1059 map { $_->groupname }
1060 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1064 =item clone_suspended
1066 Constructor used by FS::part_export::_export_suspend fallback. Document
1071 sub clone_suspended {
1073 my %hash = $self->hash;
1074 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1075 new FS::svc_acct \%hash;
1078 =item clone_kludge_unsuspend
1080 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1085 sub clone_kludge_unsuspend {
1087 my %hash = $self->hash;
1088 $hash{_password} = '';
1089 new FS::svc_acct \%hash;
1100 This is the FS::svc_acct job-queue-able version. It still uses
1101 FS::Misc::send_email under-the-hood.
1108 eval "use FS::Misc qw(send_email)";
1111 $opt{mimetype} ||= 'text/plain';
1112 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1114 my $error = send_email(
1115 'from' => $opt{from},
1117 'subject' => $opt{subject},
1118 'content-type' => $opt{mimetype},
1119 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1121 die $error if $error;
1124 =item check_and_rebuild_fuzzyfiles
1128 sub check_and_rebuild_fuzzyfiles {
1129 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1130 -e "$dir/svc_acct.username"
1131 or &rebuild_fuzzyfiles;
1134 =item rebuild_fuzzyfiles
1138 sub rebuild_fuzzyfiles {
1140 use Fcntl qw(:flock);
1142 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1146 open(USERNAMELOCK,">>$dir/svc_acct.username")
1147 or die "can't open $dir/svc_acct.username: $!";
1148 flock(USERNAMELOCK,LOCK_EX)
1149 or die "can't lock $dir/svc_acct.username: $!";
1151 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1153 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1154 or die "can't open $dir/svc_acct.username.tmp: $!";
1155 print USERNAMECACHE join("\n", @all_username), "\n";
1156 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1158 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1168 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1169 open(USERNAMECACHE,"<$dir/svc_acct.username")
1170 or die "can't open $dir/svc_acct.username: $!";
1171 my @array = map { chomp; $_; } <USERNAMECACHE>;
1172 close USERNAMECACHE;
1176 =item append_fuzzyfiles USERNAME
1180 sub append_fuzzyfiles {
1181 my $username = shift;
1183 &check_and_rebuild_fuzzyfiles;
1185 use Fcntl qw(:flock);
1187 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1189 open(USERNAME,">>$dir/svc_acct.username")
1190 or die "can't open $dir/svc_acct.username: $!";
1191 flock(USERNAME,LOCK_EX)
1192 or die "can't lock $dir/svc_acct.username: $!";
1194 print USERNAME "$username\n";
1196 flock(USERNAME,LOCK_UN)
1197 or die "can't unlock $dir/svc_acct.username: $!";
1205 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1209 sub radius_usergroup_selector {
1210 my $sel_groups = shift;
1211 my %sel_groups = map { $_=>1 } @$sel_groups;
1213 my $selectname = shift || 'radius_usergroup';
1216 my $sth = $dbh->prepare(
1217 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1218 ) or die $dbh->errstr;
1219 $sth->execute() or die $sth->errstr;
1220 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1224 function ${selectname}_doadd(object) {
1225 var myvalue = object.${selectname}_add.value;
1226 var optionName = new Option(myvalue,myvalue,false,true);
1227 var length = object.$selectname.length;
1228 object.$selectname.options[length] = optionName;
1229 object.${selectname}_add.value = "";
1232 <SELECT MULTIPLE NAME="$selectname">
1235 foreach my $group ( @all_groups ) {
1237 if ( $sel_groups{$group} ) {
1238 $html .= ' SELECTED';
1239 $sel_groups{$group} = 0;
1241 $html .= ">$group</OPTION>\n";
1243 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1244 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1246 $html .= '</SELECT>';
1248 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1249 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1258 The $recref stuff in sub check should be cleaned up.
1260 The suspend, unsuspend and cancel methods update the database, but not the
1261 current object. This is probably a bug as it's unexpected and
1264 radius_usergroup_selector? putting web ui components in here? they should
1265 probably live somewhere else...
1269 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1270 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1271 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1272 L<freeside-queued>), L<FS::svc_acct_pop>,
1273 schema.html from the base documentation.