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,34})$/ ) {
823 $recref->{_password} = $1.$3;
824 } elsif ( $recref->{_password} eq '*' ) {
825 $recref->{_password} = '*';
826 } elsif ( $recref->{_password} eq '!!' ) {
827 $recref->{_password} = '!!';
829 #return "Illegal password";
830 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
831 FS::Msgcat::_gettext('illegal_password_characters').
832 ": ". $recref->{_password};
840 Depriciated, use radius_reply instead.
845 carp "FS::svc_acct::radius depriciated, use radius_reply";
851 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
852 reply attributes of this record.
854 Note that this is now the preferred method for reading RADIUS attributes -
855 accessing the columns directly is discouraged, as the column names are
856 expected to change in the future.
865 my($column, $attrib) = ($1, $2);
866 #$attrib =~ s/_/\-/g;
867 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
868 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
869 if ( $self->slipip && $self->slipip ne '0e0' ) {
870 $reply{$radius_ip} = $self->slipip;
877 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
878 check attributes of this record.
880 Note that this is now the preferred method for reading RADIUS attributes -
881 accessing the columns directly is discouraged, as the column names are
882 expected to change in the future.
888 my $password = $self->_password;
889 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
890 ( $pw_attrib => $password,
893 my($column, $attrib) = ($1, $2);
894 #$attrib =~ s/_/\-/g;
895 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
896 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
902 Returns the domain associated with this account.
908 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
909 my $svc_domain = $self->svc_domain
910 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
916 Returns the FS::svc_domain record for this account's domain (see
925 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
930 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
936 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
941 Returns an email address associated with the account.
947 $self->username. '@'. $self->domain;
950 =item seconds_since TIMESTAMP
952 Returns the number of seconds this account has been online since TIMESTAMP,
953 according to the session monitor (see L<FS::Session>).
955 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
956 L<Time::Local> and L<Date::Parse> for conversion functions.
960 #note: POD here, implementation in FS::cust_svc
963 $self->cust_svc->seconds_since(@_);
966 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
968 Returns the numbers of seconds this account has been online between
969 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
970 external SQL radacct table, specified via sqlradius export. Sessions which
971 started in the specified range but are still open are counted from session
972 start to the end of the range (unless they are over 1 day old, in which case
973 they are presumed missing their stop record and not counted). Also, sessions
974 which end in the range but started earlier are counted from the start of the
975 range to session end. Finally, sessions which start before the range but end
976 after are counted for the entire range.
978 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
979 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
984 #note: POD here, implementation in FS::cust_svc
985 sub seconds_since_sqlradacct {
987 $self->cust_svc->seconds_since_sqlradacct(@_);
990 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
992 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
993 in this package for sessions ending between TIMESTAMP_START (inclusive) and
994 TIMESTAMP_END (exclusive).
996 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
997 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1002 #note: POD here, implementation in FS::cust_svc
1003 sub attribute_since_sqlradacct {
1005 $self->cust_svc->attribute_since_sqlradacct(@_);
1010 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1016 if ( $self->usergroup ) {
1017 #when provisioning records, export callback runs in svc_Common.pm before
1018 #radius_usergroup records can be inserted...
1019 @{$self->usergroup};
1021 map { $_->groupname }
1022 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1034 This is the FS::svc_acct job-queue-able version. It still uses
1035 FS::Misc::send_email under-the-hood.
1042 eval "use FS::Misc qw(send_email)";
1045 $opt{mimetype} ||= 'text/plain';
1046 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1048 my $error = send_email(
1049 'from' => $opt{from},
1051 'subject' => $opt{subject},
1052 'content-type' => $opt{mimetype},
1053 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1055 die $error if $error;
1058 =item check_and_rebuild_fuzzyfiles
1062 sub check_and_rebuild_fuzzyfiles {
1063 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1064 -e "$dir/svc_acct.username"
1065 or &rebuild_fuzzyfiles;
1068 =item rebuild_fuzzyfiles
1072 sub rebuild_fuzzyfiles {
1074 use Fcntl qw(:flock);
1076 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1080 open(USERNAMELOCK,">>$dir/svc_acct.username")
1081 or die "can't open $dir/svc_acct.username: $!";
1082 flock(USERNAMELOCK,LOCK_EX)
1083 or die "can't lock $dir/svc_acct.username: $!";
1085 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1087 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1088 or die "can't open $dir/svc_acct.username.tmp: $!";
1089 print USERNAMECACHE join("\n", @all_username), "\n";
1090 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1092 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1102 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1103 open(USERNAMECACHE,"<$dir/svc_acct.username")
1104 or die "can't open $dir/svc_acct.username: $!";
1105 my @array = map { chomp; $_; } <USERNAMECACHE>;
1106 close USERNAMECACHE;
1110 =item append_fuzzyfiles USERNAME
1114 sub append_fuzzyfiles {
1115 my $username = shift;
1117 &check_and_rebuild_fuzzyfiles;
1119 use Fcntl qw(:flock);
1121 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1123 open(USERNAME,">>$dir/svc_acct.username")
1124 or die "can't open $dir/svc_acct.username: $!";
1125 flock(USERNAME,LOCK_EX)
1126 or die "can't lock $dir/svc_acct.username: $!";
1128 print USERNAME "$username\n";
1130 flock(USERNAME,LOCK_UN)
1131 or die "can't unlock $dir/svc_acct.username: $!";
1139 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1143 sub radius_usergroup_selector {
1144 my $sel_groups = shift;
1145 my %sel_groups = map { $_=>1 } @$sel_groups;
1147 my $selectname = shift || 'radius_usergroup';
1150 my $sth = $dbh->prepare(
1151 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1152 ) or die $dbh->errstr;
1153 $sth->execute() or die $sth->errstr;
1154 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1158 function ${selectname}_doadd(object) {
1159 var myvalue = object.${selectname}_add.value;
1160 var optionName = new Option(myvalue,myvalue,false,true);
1161 var length = object.$selectname.length;
1162 object.$selectname.options[length] = optionName;
1163 object.${selectname}_add.value = "";
1166 <SELECT MULTIPLE NAME="$selectname">
1169 foreach my $group ( @all_groups ) {
1171 if ( $sel_groups{$group} ) {
1172 $html .= ' SELECTED';
1173 $sel_groups{$group} = 0;
1175 $html .= ">$group</OPTION>\n";
1177 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1178 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1180 $html .= '</SELECT>';
1182 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1183 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1192 The $recref stuff in sub check should be cleaned up.
1194 The suspend, unsuspend and cancel methods update the database, but not the
1195 current object. This is probably a bug as it's unexpected and
1198 radius_usergroup_selector? putting web ui components in here? they should
1199 probably live somewhere else...
1203 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1204 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1205 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1206 L<freeside-queued>), L<FS::svc_acct_pop>,
1207 schema.html from the base documentation.