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(@_);
1010 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1012 Returns an array of hash references of this customers login history for the
1013 given time range. (document this better)
1017 sub get_session_history_sqlradacct {
1019 $self->cust_svc->get_session_history_sqlradacct(@_);
1024 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1030 if ( $self->usergroup ) {
1031 #when provisioning records, export callback runs in svc_Common.pm before
1032 #radius_usergroup records can be inserted...
1033 @{$self->usergroup};
1035 map { $_->groupname }
1036 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1048 This is the FS::svc_acct job-queue-able version. It still uses
1049 FS::Misc::send_email under-the-hood.
1056 eval "use FS::Misc qw(send_email)";
1059 $opt{mimetype} ||= 'text/plain';
1060 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1062 my $error = send_email(
1063 'from' => $opt{from},
1065 'subject' => $opt{subject},
1066 'content-type' => $opt{mimetype},
1067 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1069 die $error if $error;
1072 =item check_and_rebuild_fuzzyfiles
1076 sub check_and_rebuild_fuzzyfiles {
1077 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1078 -e "$dir/svc_acct.username"
1079 or &rebuild_fuzzyfiles;
1082 =item rebuild_fuzzyfiles
1086 sub rebuild_fuzzyfiles {
1088 use Fcntl qw(:flock);
1090 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1094 open(USERNAMELOCK,">>$dir/svc_acct.username")
1095 or die "can't open $dir/svc_acct.username: $!";
1096 flock(USERNAMELOCK,LOCK_EX)
1097 or die "can't lock $dir/svc_acct.username: $!";
1099 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1101 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1102 or die "can't open $dir/svc_acct.username.tmp: $!";
1103 print USERNAMECACHE join("\n", @all_username), "\n";
1104 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1106 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1116 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1117 open(USERNAMECACHE,"<$dir/svc_acct.username")
1118 or die "can't open $dir/svc_acct.username: $!";
1119 my @array = map { chomp; $_; } <USERNAMECACHE>;
1120 close USERNAMECACHE;
1124 =item append_fuzzyfiles USERNAME
1128 sub append_fuzzyfiles {
1129 my $username = shift;
1131 &check_and_rebuild_fuzzyfiles;
1133 use Fcntl qw(:flock);
1135 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1137 open(USERNAME,">>$dir/svc_acct.username")
1138 or die "can't open $dir/svc_acct.username: $!";
1139 flock(USERNAME,LOCK_EX)
1140 or die "can't lock $dir/svc_acct.username: $!";
1142 print USERNAME "$username\n";
1144 flock(USERNAME,LOCK_UN)
1145 or die "can't unlock $dir/svc_acct.username: $!";
1153 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1157 sub radius_usergroup_selector {
1158 my $sel_groups = shift;
1159 my %sel_groups = map { $_=>1 } @$sel_groups;
1161 my $selectname = shift || 'radius_usergroup';
1164 my $sth = $dbh->prepare(
1165 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1166 ) or die $dbh->errstr;
1167 $sth->execute() or die $sth->errstr;
1168 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1172 function ${selectname}_doadd(object) {
1173 var myvalue = object.${selectname}_add.value;
1174 var optionName = new Option(myvalue,myvalue,false,true);
1175 var length = object.$selectname.length;
1176 object.$selectname.options[length] = optionName;
1177 object.${selectname}_add.value = "";
1180 <SELECT MULTIPLE NAME="$selectname">
1183 foreach my $group ( @all_groups ) {
1185 if ( $sel_groups{$group} ) {
1186 $html .= ' SELECTED';
1187 $sel_groups{$group} = 0;
1189 $html .= ">$group</OPTION>\n";
1191 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1192 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1194 $html .= '</SELECT>';
1196 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1197 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1206 The $recref stuff in sub check should be cleaned up.
1208 The suspend, unsuspend and cancel methods update the database, but not the
1209 current object. This is probably a bug as it's unexpected and
1212 radius_usergroup_selector? putting web ui components in here? they should
1213 probably live somewhere else...
1217 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1218 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1219 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1220 L<freeside-queued>), L<FS::svc_acct_pop>,
1221 schema.html from the base documentation.