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 );
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 (TODOC: L<FS::queue> and L<freeside-queued>)
193 (TODOC: new exports!)
201 local $SIG{HUP} = 'IGNORE';
202 local $SIG{INT} = 'IGNORE';
203 local $SIG{QUIT} = 'IGNORE';
204 local $SIG{TERM} = 'IGNORE';
205 local $SIG{TSTP} = 'IGNORE';
206 local $SIG{PIPE} = 'IGNORE';
208 my $oldAutoCommit = $FS::UID::AutoCommit;
209 local $FS::UID::AutoCommit = 0;
212 $error = $self->check;
213 return $error if $error;
215 #no, duplicate checking just got a whole lot more complicated
216 #(perhaps keep this check with a config option to turn on?)
218 #return gettext('username_in_use'). ": ". $self->username
219 # if qsearchs( 'svc_acct', { 'username' => $self->username,
220 # 'domsvc' => $self->domsvc,
223 if ( $self->svcnum ) {
224 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
225 unless ( $cust_svc ) {
226 $dbh->rollback if $oldAutoCommit;
227 return "no cust_svc record found for svcnum ". $self->svcnum;
229 $self->pkgnum($cust_svc->pkgnum);
230 $self->svcpart($cust_svc->svcpart);
233 #new duplicate username checking
235 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
236 unless ( $part_svc ) {
237 $dbh->rollback if $oldAutoCommit;
238 return 'unknown svcpart '. $self->svcpart;
241 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
242 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
243 'domsvc' => $self->domsvc } );
245 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
246 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
247 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
252 if ( @dup_user || @dup_userdomain || @dup_uid ) {
253 my $exports = FS::part_export::export_info('svc_acct');
254 my %conflict_user_svcpart;
255 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
257 foreach my $part_export ( $part_svc->part_export ) {
259 #this will catch to the same exact export
260 my @svcparts = map { $_->svcpart }
261 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
263 #this will catch to exports w/same exporthost+type ???
264 #my @other_part_export = qsearch('part_export', {
265 # 'machine' => $part_export->machine,
266 # 'exporttype' => $part_export->exporttype,
268 #foreach my $other_part_export ( @other_part_export ) {
269 # push @svcparts, map { $_->svcpart }
270 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
273 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
274 #silly kludge to avoid uninitialized value errors
275 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
276 ? $exports->{$part_export->exporttype}{'nodomain'}
278 if ( $nodomain =~ /^Y/i ) {
279 $conflict_user_svcpart{$_} = $part_export->exportnum
282 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
287 foreach my $dup_user ( @dup_user ) {
288 my $dup_svcpart = $dup_user->cust_svc->svcpart;
289 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
290 $dbh->rollback if $oldAutoCommit;
291 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
292 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
296 foreach my $dup_userdomain ( @dup_userdomain ) {
297 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
298 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
299 $dbh->rollback if $oldAutoCommit;
300 return "duplicate username\@domain: conflicts with svcnum ".
301 $dup_userdomain->svcnum. " via exportnum ".
302 $conflict_userdomain_svcpart{$dup_svcpart};
306 foreach my $dup_uid ( @dup_uid ) {
307 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
308 if ( exists($conflict_user_svcpart{$dup_svcpart})
309 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
310 $dbh->rollback if $oldAutoCommit;
311 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
312 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
313 || $conflict_userdomain_svcpart{$dup_svcpart};
319 #see? i told you it was more complicated
322 $error = $self->SUPER::insert(\@jobnums);
324 $dbh->rollback if $oldAutoCommit;
328 if ( $self->usergroup ) {
329 foreach my $groupname ( @{$self->usergroup} ) {
330 my $radius_usergroup = new FS::radius_usergroup ( {
331 svcnum => $self->svcnum,
332 groupname => $groupname,
334 my $error = $radius_usergroup->insert;
336 $dbh->rollback if $oldAutoCommit;
342 #false laziness with sub replace (and cust_main)
343 my $queue = new FS::queue {
344 'svcnum' => $self->svcnum,
345 'job' => 'FS::svc_acct::append_fuzzyfiles'
347 $error = $queue->insert($self->username);
349 $dbh->rollback if $oldAutoCommit;
350 return "queueing job (transaction rolled back): $error";
353 my $cust_pkg = $self->cust_svc->cust_pkg;
356 my $cust_main = $cust_pkg->cust_main;
358 if ( $conf->exists('emailinvoiceauto') ) {
359 my @invoicing_list = $cust_main->invoicing_list;
360 push @invoicing_list, $self->email;
361 $cust_main->invoicing_list(\@invoicing_list);
366 if ( $welcome_template && $cust_pkg ) {
367 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
369 my $wqueue = new FS::queue {
370 'svcnum' => $self->svcnum,
371 'job' => 'FS::svc_acct::send_email'
373 my $error = $wqueue->insert(
375 'from' => $welcome_from,
376 'subject' => $welcome_subject,
377 'mimetype' => $welcome_mimetype,
378 'body' => $welcome_template->fill_in( HASH => {
379 'custnum' => $self->custnum,
380 'username' => $self->username,
381 'password' => $self->_password,
382 'first' => $cust_main->first,
383 'last' => $cust_main->getfield('last'),
384 'pkg' => $cust_pkg->part_pkg->pkg,
388 $dbh->rollback if $oldAutoCommit;
389 return "error queuing welcome email: $error";
392 foreach my $jobnum ( @jobnums ) {
393 my $error = $wqueue->depend_insert($jobnum);
395 $dbh->rollback if $oldAutoCommit;
396 return "error queuing welcome email job dependancy: $error";
406 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
412 Deletes this account from the database. If there is an error, returns the
413 error, otherwise returns false.
415 The corresponding FS::cust_svc record will be deleted as well.
417 (TODOC: new exports!)
424 return "Can't delete an account which is a (svc_forward) source!"
425 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
427 return "Can't delete an account which is a (svc_forward) destination!"
428 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
430 return "Can't delete an account with (svc_www) web service!"
431 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
433 # what about records in session ? (they should refer to history table)
435 local $SIG{HUP} = 'IGNORE';
436 local $SIG{INT} = 'IGNORE';
437 local $SIG{QUIT} = 'IGNORE';
438 local $SIG{TERM} = 'IGNORE';
439 local $SIG{TSTP} = 'IGNORE';
440 local $SIG{PIPE} = 'IGNORE';
442 my $oldAutoCommit = $FS::UID::AutoCommit;
443 local $FS::UID::AutoCommit = 0;
446 foreach my $cust_main_invoice (
447 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
449 unless ( defined($cust_main_invoice) ) {
450 warn "WARNING: something's wrong with qsearch";
453 my %hash = $cust_main_invoice->hash;
454 $hash{'dest'} = $self->email;
455 my $new = new FS::cust_main_invoice \%hash;
456 my $error = $new->replace($cust_main_invoice);
458 $dbh->rollback if $oldAutoCommit;
463 foreach my $svc_domain (
464 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
466 my %hash = new FS::svc_domain->hash;
467 $hash{'catchall'} = '';
468 my $new = new FS::svc_domain \%hash;
469 my $error = $new->replace($svc_domain);
471 $dbh->rollback if $oldAutoCommit;
476 foreach my $radius_usergroup (
477 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
479 my $error = $radius_usergroup->delete;
481 $dbh->rollback if $oldAutoCommit;
486 my $error = $self->SUPER::delete;
488 $dbh->rollback if $oldAutoCommit;
492 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
496 =item replace OLD_RECORD
498 Replaces OLD_RECORD with this one in the database. If there is an error,
499 returns the error, otherwise returns false.
501 The additional field I<usergroup> can optionally be defined; if so it should
502 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
503 sqlradius export only)
508 my ( $new, $old ) = ( shift, shift );
510 warn "$me replacing $old with $new\n" if $DEBUG;
512 return "Username in use"
513 if $old->username ne $new->username &&
514 qsearchs( 'svc_acct', { 'username' => $new->username,
515 'domsvc' => $new->domsvc,
518 #no warnings 'numeric'; #alas, a 5.006-ism
520 return "Can't change uid!" if $old->uid != $new->uid;
523 #change homdir when we change username
524 $new->setfield('dir', '') if $old->username ne $new->username;
526 local $SIG{HUP} = 'IGNORE';
527 local $SIG{INT} = 'IGNORE';
528 local $SIG{QUIT} = 'IGNORE';
529 local $SIG{TERM} = 'IGNORE';
530 local $SIG{TSTP} = 'IGNORE';
531 local $SIG{PIPE} = 'IGNORE';
533 my $oldAutoCommit = $FS::UID::AutoCommit;
534 local $FS::UID::AutoCommit = 0;
537 # redundant, but so $new->usergroup gets set
538 $error = $new->check;
539 return $error if $error;
541 $old->usergroup( [ $old->radius_groups ] );
542 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
543 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
544 if ( $new->usergroup ) {
545 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
546 my @newgroups = @{$new->usergroup};
547 foreach my $oldgroup ( @{$old->usergroup} ) {
548 if ( grep { $oldgroup eq $_ } @newgroups ) {
549 @newgroups = grep { $oldgroup ne $_ } @newgroups;
552 my $radius_usergroup = qsearchs('radius_usergroup', {
553 svcnum => $old->svcnum,
554 groupname => $oldgroup,
556 my $error = $radius_usergroup->delete;
558 $dbh->rollback if $oldAutoCommit;
559 return "error deleting radius_usergroup $oldgroup: $error";
563 foreach my $newgroup ( @newgroups ) {
564 my $radius_usergroup = new FS::radius_usergroup ( {
565 svcnum => $new->svcnum,
566 groupname => $newgroup,
568 my $error = $radius_usergroup->insert;
570 $dbh->rollback if $oldAutoCommit;
571 return "error adding radius_usergroup $newgroup: $error";
577 $error = $new->SUPER::replace($old);
579 $dbh->rollback if $oldAutoCommit;
580 return $error if $error;
583 if ( $new->username ne $old->username ) {
584 #false laziness with sub insert (and cust_main)
585 my $queue = new FS::queue {
586 'svcnum' => $new->svcnum,
587 'job' => 'FS::svc_acct::append_fuzzyfiles'
589 $error = $queue->insert($new->username);
591 $dbh->rollback if $oldAutoCommit;
592 return "queueing job (transaction rolled back): $error";
596 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
602 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
603 error, returns the error, otherwise returns false.
605 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
607 Calls any export-specific suspend hooks.
613 my %hash = $self->hash;
614 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
615 || $hash{_password} eq '*'
617 $hash{_password} = '*SUSPENDED* '.$hash{_password};
618 my $new = new FS::svc_acct ( \%hash );
619 my $error = $new->replace($self);
620 return $error if $error;
623 $self->SUPER::suspend;
628 Unsuspends this account by removing *SUSPENDED* from the password. If there is
629 an error, returns the error, otherwise returns false.
631 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
633 Calls any export-specific unsuspend hooks.
639 my %hash = $self->hash;
640 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
641 $hash{_password} = $1;
642 my $new = new FS::svc_acct ( \%hash );
643 my $error = $new->replace($self);
644 return $error if $error;
647 $self->SUPER::unsuspend;
652 Just returns false (no error) for now.
654 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
658 Checks all fields to make sure this is a valid service. If there is an error,
659 returns the error, otherwise returns false. Called by the insert and replace
662 Sets any fixed values; see L<FS::part_svc>.
669 my($recref) = $self->hashref;
671 my $x = $self->setfixed;
672 return $x unless ref($x);
675 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
677 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
680 my $error = $self->ut_numbern('svcnum')
681 #|| $self->ut_number('domsvc')
682 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
683 || $self->ut_textn('sec_phrase')
685 return $error if $error;
687 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
688 if ( $username_uppercase ) {
689 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
690 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
691 $recref->{username} = $1;
693 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
694 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
695 $recref->{username} = $1;
698 if ( $username_letterfirst ) {
699 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
700 } elsif ( $username_letter ) {
701 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
703 if ( $username_noperiod ) {
704 $recref->{username} =~ /\./ and return gettext('illegal_username');
706 if ( $username_nounderscore ) {
707 $recref->{username} =~ /_/ and return gettext('illegal_username');
709 if ( $username_nodash ) {
710 $recref->{username} =~ /\-/ and return gettext('illegal_username');
712 unless ( $username_ampersand ) {
713 $recref->{username} =~ /\&/ and return gettext('illegal_username');
716 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
717 $recref->{popnum} = $1;
718 return "Unknown popnum" unless
719 ! $recref->{popnum} ||
720 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
722 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
724 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
725 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
727 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
728 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
729 #not all systems use gid=uid
730 #you can set a fixed gid in part_svc
732 return "Only root can have uid 0"
733 if $recref->{uid} == 0
734 && $recref->{username} ne 'root'
735 && $recref->{username} ne 'toor';
738 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
739 or return "Illegal directory: ". $recref->{dir};
741 return "Illegal directory"
742 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
743 return "Illegal directory"
744 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
745 unless ( $recref->{dir} ) {
746 $recref->{dir} = $dir_prefix . '/';
747 if ( $dirhash > 0 ) {
748 for my $h ( 1 .. $dirhash ) {
749 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
751 } elsif ( $dirhash < 0 ) {
752 for my $h ( reverse $dirhash .. -1 ) {
753 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
756 $recref->{dir} .= $recref->{username};
760 unless ( $recref->{username} eq 'sync' ) {
761 if ( grep $_ eq $recref->{shell}, @shells ) {
762 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
764 return "Illegal shell \`". $self->shell. "\'; ".
765 $conf->dir. "/shells contains: @shells";
768 $recref->{shell} = '/bin/sync';
772 $recref->{gid} ne '' ?
773 return "Can't have gid without uid" : ( $recref->{gid}='' );
774 $recref->{dir} ne '' ?
775 return "Can't have directory without uid" : ( $recref->{dir}='' );
776 $recref->{shell} ne '' ?
777 return "Can't have shell without uid" : ( $recref->{shell}='' );
780 # $error = $self->ut_textn('finger');
781 # return $error if $error;
782 $self->getfield('finger') =~
783 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
784 or return "Illegal finger: ". $self->getfield('finger');
785 $self->setfield('finger', $1);
787 $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
788 $recref->{quota} = $1;
790 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
791 if ( $recref->{slipip} eq '' ) {
792 $recref->{slipip} = '';
793 } elsif ( $recref->{slipip} eq '0e0' ) {
794 $recref->{slipip} = '0e0';
796 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
797 or return "Illegal slipip: ". $self->slipip;
798 $recref->{slipip} = $1;
803 #arbitrary RADIUS stuff; allow ut_textn for now
804 foreach ( grep /^radius_/, fields('svc_acct') ) {
808 #generate a password if it is blank
809 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
810 unless ( $recref->{_password} );
812 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
813 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
814 $recref->{_password} = $1.$3;
815 #uncomment this to encrypt password immediately upon entry, or run
816 #bin/crypt_pw in cron to give new users a window during which their
817 #password is available to techs, for faxing, etc. (also be aware of
819 #$recref->{password} = $1.
820 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
822 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
823 $recref->{_password} = $1.$3;
824 } elsif ( $recref->{_password} eq '*' ) {
825 $recref->{_password} = '*';
826 } elsif ( $recref->{_password} eq '!' ) {
827 $recref->{_password} = '!';
828 } elsif ( $recref->{_password} eq '!!' ) {
829 $recref->{_password} = '!!';
831 #return "Illegal password";
832 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
833 FS::Msgcat::_gettext('illegal_password_characters').
834 ": ". $recref->{_password};
842 Depriciated, use radius_reply instead.
847 carp "FS::svc_acct::radius depriciated, use radius_reply";
853 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
854 reply attributes of this record.
856 Note that this is now the preferred method for reading RADIUS attributes -
857 accessing the columns directly is discouraged, as the column names are
858 expected to change in the future.
867 my($column, $attrib) = ($1, $2);
868 #$attrib =~ s/_/\-/g;
869 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
870 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
871 if ( $self->slipip && $self->slipip ne '0e0' ) {
872 $reply{$radius_ip} = $self->slipip;
879 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
880 check attributes of this record.
882 Note that this is now the preferred method for reading RADIUS attributes -
883 accessing the columns directly is discouraged, as the column names are
884 expected to change in the future.
890 my $password = $self->_password;
891 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
892 ( $pw_attrib => $password,
895 my($column, $attrib) = ($1, $2);
896 #$attrib =~ s/_/\-/g;
897 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
898 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
904 Returns the domain associated with this account.
910 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
911 my $svc_domain = $self->svc_domain
912 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
918 Returns the FS::svc_domain record for this account's domain (see
927 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
932 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
938 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
943 Returns an email address associated with the account.
949 $self->username. '@'. $self->domain;
952 =item seconds_since TIMESTAMP
954 Returns the number of seconds this account has been online since TIMESTAMP,
955 according to the session monitor (see L<FS::Session>).
957 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
958 L<Time::Local> and L<Date::Parse> for conversion functions.
962 #note: POD here, implementation in FS::cust_svc
965 $self->cust_svc->seconds_since(@_);
968 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
970 Returns the numbers of seconds this account has been online between
971 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
972 external SQL radacct table, specified via sqlradius export. Sessions which
973 started in the specified range but are still open are counted from session
974 start to the end of the range (unless they are over 1 day old, in which case
975 they are presumed missing their stop record and not counted). Also, sessions
976 which end in the range but started earlier are counted from the start of the
977 range to session end. Finally, sessions which start before the range but end
978 after are counted for the entire range.
980 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
981 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
986 #note: POD here, implementation in FS::cust_svc
987 sub seconds_since_sqlradacct {
989 $self->cust_svc->seconds_since_sqlradacct(@_);
992 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
994 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
995 in this package for sessions ending between TIMESTAMP_START (inclusive) and
996 TIMESTAMP_END (exclusive).
998 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
999 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1004 #note: POD here, implementation in FS::cust_svc
1005 sub attribute_since_sqlradacct {
1007 $self->cust_svc->attribute_since_sqlradacct(@_);
1012 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1018 if ( $self->usergroup ) {
1019 #when provisioning records, export callback runs in svc_Common.pm before
1020 #radius_usergroup records can be inserted...
1021 @{$self->usergroup};
1023 map { $_->groupname }
1024 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1036 This is the FS::svc_acct job-queue-able version. It still uses
1037 FS::Misc::send_email under-the-hood.
1044 eval "use FS::Misc qw(send_email)";
1047 $opt{mimetype} ||= 'text/plain';
1048 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1050 my $error = send_email(
1051 'from' => $opt{from},
1053 'subject' => $opt{subject},
1054 'content-type' => $opt{mimetype},
1055 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1057 die $error if $error;
1060 =item check_and_rebuild_fuzzyfiles
1064 sub check_and_rebuild_fuzzyfiles {
1065 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1066 -e "$dir/svc_acct.username"
1067 or &rebuild_fuzzyfiles;
1070 =item rebuild_fuzzyfiles
1074 sub rebuild_fuzzyfiles {
1076 use Fcntl qw(:flock);
1078 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1082 open(USERNAMELOCK,">>$dir/svc_acct.username")
1083 or die "can't open $dir/svc_acct.username: $!";
1084 flock(USERNAMELOCK,LOCK_EX)
1085 or die "can't lock $dir/svc_acct.username: $!";
1087 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1089 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1090 or die "can't open $dir/svc_acct.username.tmp: $!";
1091 print USERNAMECACHE join("\n", @all_username), "\n";
1092 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1094 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1104 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1105 open(USERNAMECACHE,"<$dir/svc_acct.username")
1106 or die "can't open $dir/svc_acct.username: $!";
1107 my @array = map { chomp; $_; } <USERNAMECACHE>;
1108 close USERNAMECACHE;
1112 =item append_fuzzyfiles USERNAME
1116 sub append_fuzzyfiles {
1117 my $username = shift;
1119 &check_and_rebuild_fuzzyfiles;
1121 use Fcntl qw(:flock);
1123 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1125 open(USERNAME,">>$dir/svc_acct.username")
1126 or die "can't open $dir/svc_acct.username: $!";
1127 flock(USERNAME,LOCK_EX)
1128 or die "can't lock $dir/svc_acct.username: $!";
1130 print USERNAME "$username\n";
1132 flock(USERNAME,LOCK_UN)
1133 or die "can't unlock $dir/svc_acct.username: $!";
1141 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1145 sub radius_usergroup_selector {
1146 my $sel_groups = shift;
1147 my %sel_groups = map { $_=>1 } @$sel_groups;
1149 my $selectname = shift || 'radius_usergroup';
1152 my $sth = $dbh->prepare(
1153 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1154 ) or die $dbh->errstr;
1155 $sth->execute() or die $sth->errstr;
1156 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1160 function ${selectname}_doadd(object) {
1161 var myvalue = object.${selectname}_add.value;
1162 var optionName = new Option(myvalue,myvalue,false,true);
1163 var length = object.$selectname.length;
1164 object.$selectname.options[length] = optionName;
1165 object.${selectname}_add.value = "";
1168 <SELECT MULTIPLE NAME="$selectname">
1171 foreach my $group ( @all_groups ) {
1173 if ( $sel_groups{$group} ) {
1174 $html .= ' SELECTED';
1175 $sel_groups{$group} = 0;
1177 $html .= ">$group</OPTION>\n";
1179 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1180 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1182 $html .= '</SELECT>';
1184 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1185 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1194 The $recref stuff in sub check should be cleaned up.
1196 The suspend, unsuspend and cancel methods update the database, but not the
1197 current object. This is probably a bug as it's unexpected and
1200 radius_usergroup_selector? putting web ui components in here? they should
1201 probably live somewhere else...
1205 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1206 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1207 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1208 L<freeside-queued>), L<FS::svc_acct_pop>,
1209 schema.html from the base documentation.