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 calling export-specific suspend hooks. If there is
603 an error, returns the error, otherwise returns false.
605 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
611 my %hash = $self->hash;
612 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
613 || $hash{_password} eq '*'
615 $hash{_password} = '*SUSPENDED* '.$hash{_password};
616 my $new = new FS::svc_acct ( \%hash );
617 my $error = $new->replace($self);
618 return $error if $error;
621 $self->SUPER::suspend;
626 Unsuspends this account by by calling export-specific suspend hooks. If there
627 is an error, returns the error, otherwise returns false.
629 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
635 my %hash = $self->hash;
636 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
637 $hash{_password} = $1;
638 my $new = new FS::svc_acct ( \%hash );
639 my $error = $new->replace($self);
640 return $error if $error;
643 $self->SUPER::unsuspend;
648 Just returns false (no error) for now.
650 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
654 Checks all fields to make sure this is a valid service. If there is an error,
655 returns the error, otherwise returns false. Called by the insert and replace
658 Sets any fixed values; see L<FS::part_svc>.
665 my($recref) = $self->hashref;
667 my $x = $self->setfixed;
668 return $x unless ref($x);
671 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
673 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
676 my $error = $self->ut_numbern('svcnum')
677 #|| $self->ut_number('domsvc')
678 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
679 || $self->ut_textn('sec_phrase')
681 return $error if $error;
683 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
684 if ( $username_uppercase ) {
685 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
686 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
687 $recref->{username} = $1;
689 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
690 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
691 $recref->{username} = $1;
694 if ( $username_letterfirst ) {
695 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
696 } elsif ( $username_letter ) {
697 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
699 if ( $username_noperiod ) {
700 $recref->{username} =~ /\./ and return gettext('illegal_username');
702 if ( $username_nounderscore ) {
703 $recref->{username} =~ /_/ and return gettext('illegal_username');
705 if ( $username_nodash ) {
706 $recref->{username} =~ /\-/ and return gettext('illegal_username');
708 unless ( $username_ampersand ) {
709 $recref->{username} =~ /\&/ and return gettext('illegal_username');
712 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
713 $recref->{popnum} = $1;
714 return "Unknown popnum" unless
715 ! $recref->{popnum} ||
716 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
718 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
720 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
721 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
723 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
724 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
725 #not all systems use gid=uid
726 #you can set a fixed gid in part_svc
728 return "Only root can have uid 0"
729 if $recref->{uid} == 0
730 && $recref->{username} ne 'root'
731 && $recref->{username} ne 'toor';
734 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
735 or return "Illegal directory: ". $recref->{dir};
737 return "Illegal directory"
738 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
739 return "Illegal directory"
740 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
741 unless ( $recref->{dir} ) {
742 $recref->{dir} = $dir_prefix . '/';
743 if ( $dirhash > 0 ) {
744 for my $h ( 1 .. $dirhash ) {
745 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
747 } elsif ( $dirhash < 0 ) {
748 for my $h ( reverse $dirhash .. -1 ) {
749 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
752 $recref->{dir} .= $recref->{username};
756 unless ( $recref->{username} eq 'sync' ) {
757 if ( grep $_ eq $recref->{shell}, @shells ) {
758 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
760 return "Illegal shell \`". $self->shell. "\'; ".
761 $conf->dir. "/shells contains: @shells";
764 $recref->{shell} = '/bin/sync';
768 $recref->{gid} ne '' ?
769 return "Can't have gid without uid" : ( $recref->{gid}='' );
770 $recref->{dir} ne '' ?
771 return "Can't have directory without uid" : ( $recref->{dir}='' );
772 $recref->{shell} ne '' ?
773 return "Can't have shell without uid" : ( $recref->{shell}='' );
776 # $error = $self->ut_textn('finger');
777 # return $error if $error;
778 $self->getfield('finger') =~
779 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
780 or return "Illegal finger: ". $self->getfield('finger');
781 $self->setfield('finger', $1);
783 $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
784 $recref->{quota} = $1;
786 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
787 if ( $recref->{slipip} eq '' ) {
788 $recref->{slipip} = '';
789 } elsif ( $recref->{slipip} eq '0e0' ) {
790 $recref->{slipip} = '0e0';
792 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
793 or return "Illegal slipip: ". $self->slipip;
794 $recref->{slipip} = $1;
799 #arbitrary RADIUS stuff; allow ut_textn for now
800 foreach ( grep /^radius_/, fields('svc_acct') ) {
804 #generate a password if it is blank
805 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
806 unless ( $recref->{_password} );
808 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
809 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
810 $recref->{_password} = $1.$3;
811 #uncomment this to encrypt password immediately upon entry, or run
812 #bin/crypt_pw in cron to give new users a window during which their
813 #password is available to techs, for faxing, etc. (also be aware of
815 #$recref->{password} = $1.
816 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
818 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
819 $recref->{_password} = $1.$3;
820 } elsif ( $recref->{_password} eq '*' ) {
821 $recref->{_password} = '*';
822 } elsif ( $recref->{_password} eq '!' ) {
823 $recref->{_password} = '!';
824 } elsif ( $recref->{_password} eq '!!' ) {
825 $recref->{_password} = '!!';
827 #return "Illegal password";
828 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
829 FS::Msgcat::_gettext('illegal_password_characters').
830 ": ". $recref->{_password};
838 Depriciated, use radius_reply instead.
843 carp "FS::svc_acct::radius depriciated, use radius_reply";
849 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
850 reply attributes of this record.
852 Note that this is now the preferred method for reading RADIUS attributes -
853 accessing the columns directly is discouraged, as the column names are
854 expected to change in the future.
863 my($column, $attrib) = ($1, $2);
864 #$attrib =~ s/_/\-/g;
865 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
866 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
867 if ( $self->slipip && $self->slipip ne '0e0' ) {
868 $reply{$radius_ip} = $self->slipip;
875 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
876 check attributes of this record.
878 Note that this is now the preferred method for reading RADIUS attributes -
879 accessing the columns directly is discouraged, as the column names are
880 expected to change in the future.
886 my $password = $self->_password;
887 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
888 ( $pw_attrib => $password,
891 my($column, $attrib) = ($1, $2);
892 #$attrib =~ s/_/\-/g;
893 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
894 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
900 Returns the domain associated with this account.
906 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
907 my $svc_domain = $self->svc_domain
908 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
914 Returns the FS::svc_domain record for this account's domain (see
923 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
928 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
934 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
939 Returns an email address associated with the account.
945 $self->username. '@'. $self->domain;
948 =item seconds_since TIMESTAMP
950 Returns the number of seconds this account has been online since TIMESTAMP,
951 according to the session monitor (see L<FS::Session>).
953 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
954 L<Time::Local> and L<Date::Parse> for conversion functions.
958 #note: POD here, implementation in FS::cust_svc
961 $self->cust_svc->seconds_since(@_);
964 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
966 Returns the numbers of seconds this account has been online between
967 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
968 external SQL radacct table, specified via sqlradius export. Sessions which
969 started in the specified range but are still open are counted from session
970 start to the end of the range (unless they are over 1 day old, in which case
971 they are presumed missing their stop record and not counted). Also, sessions
972 which end in the range but started earlier are counted from the start of the
973 range to session end. Finally, sessions which start before the range but end
974 after are counted for the entire range.
976 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
977 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
982 #note: POD here, implementation in FS::cust_svc
983 sub seconds_since_sqlradacct {
985 $self->cust_svc->seconds_since_sqlradacct(@_);
988 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
990 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
991 in this package for sessions ending between TIMESTAMP_START (inclusive) and
992 TIMESTAMP_END (exclusive).
994 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
995 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1000 #note: POD here, implementation in FS::cust_svc
1001 sub attribute_since_sqlradacct {
1003 $self->cust_svc->attribute_since_sqlradacct(@_);
1006 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1008 Returns an array of hash references of this customers login history for the
1009 given time range. (document this better)
1013 sub get_session_history_sqlradacct {
1015 $self->cust_svc->get_session_history_sqlradacct(@_);
1020 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1026 if ( $self->usergroup ) {
1027 #when provisioning records, export callback runs in svc_Common.pm before
1028 #radius_usergroup records can be inserted...
1029 @{$self->usergroup};
1031 map { $_->groupname }
1032 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1044 This is the FS::svc_acct job-queue-able version. It still uses
1045 FS::Misc::send_email under-the-hood.
1052 eval "use FS::Misc qw(send_email)";
1055 $opt{mimetype} ||= 'text/plain';
1056 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1058 my $error = send_email(
1059 'from' => $opt{from},
1061 'subject' => $opt{subject},
1062 'content-type' => $opt{mimetype},
1063 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1065 die $error if $error;
1068 =item check_and_rebuild_fuzzyfiles
1072 sub check_and_rebuild_fuzzyfiles {
1073 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1074 -e "$dir/svc_acct.username"
1075 or &rebuild_fuzzyfiles;
1078 =item rebuild_fuzzyfiles
1082 sub rebuild_fuzzyfiles {
1084 use Fcntl qw(:flock);
1086 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1090 open(USERNAMELOCK,">>$dir/svc_acct.username")
1091 or die "can't open $dir/svc_acct.username: $!";
1092 flock(USERNAMELOCK,LOCK_EX)
1093 or die "can't lock $dir/svc_acct.username: $!";
1095 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1097 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1098 or die "can't open $dir/svc_acct.username.tmp: $!";
1099 print USERNAMECACHE join("\n", @all_username), "\n";
1100 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1102 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1112 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1113 open(USERNAMECACHE,"<$dir/svc_acct.username")
1114 or die "can't open $dir/svc_acct.username: $!";
1115 my @array = map { chomp; $_; } <USERNAMECACHE>;
1116 close USERNAMECACHE;
1120 =item append_fuzzyfiles USERNAME
1124 sub append_fuzzyfiles {
1125 my $username = shift;
1127 &check_and_rebuild_fuzzyfiles;
1129 use Fcntl qw(:flock);
1131 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1133 open(USERNAME,">>$dir/svc_acct.username")
1134 or die "can't open $dir/svc_acct.username: $!";
1135 flock(USERNAME,LOCK_EX)
1136 or die "can't lock $dir/svc_acct.username: $!";
1138 print USERNAME "$username\n";
1140 flock(USERNAME,LOCK_UN)
1141 or die "can't unlock $dir/svc_acct.username: $!";
1149 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1153 sub radius_usergroup_selector {
1154 my $sel_groups = shift;
1155 my %sel_groups = map { $_=>1 } @$sel_groups;
1157 my $selectname = shift || 'radius_usergroup';
1160 my $sth = $dbh->prepare(
1161 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1162 ) or die $dbh->errstr;
1163 $sth->execute() or die $sth->errstr;
1164 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1168 function ${selectname}_doadd(object) {
1169 var myvalue = object.${selectname}_add.value;
1170 var optionName = new Option(myvalue,myvalue,false,true);
1171 var length = object.$selectname.length;
1172 object.$selectname.options[length] = optionName;
1173 object.${selectname}_add.value = "";
1176 <SELECT MULTIPLE NAME="$selectname">
1179 foreach my $group ( @all_groups ) {
1181 if ( $sel_groups{$group} ) {
1182 $html .= ' SELECTED';
1183 $sel_groups{$group} = 0;
1185 $html .= ">$group</OPTION>\n";
1187 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1188 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1190 $html .= '</SELECT>';
1192 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1193 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1202 The $recref stuff in sub check should be cleaned up.
1204 The suspend, unsuspend and cancel methods update the database, but not the
1205 current object. This is probably a bug as it's unexpected and
1208 radius_usergroup_selector? putting web ui components in here? they should
1209 probably live somewhere else...
1213 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1214 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1215 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1216 L<freeside-queued>), L<FS::svc_acct_pop>,
1217 schema.html from the base documentation.