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 The additional field I<child_objects> can optionally be defined; if so it
192 should contain an arrayref of FS::tablename objects. They will have their
193 svcnum fields set and will be inserted after this record, but before any
196 (TODOC: L<FS::queue> and L<freeside-queued>)
198 (TODOC: new exports!)
207 local $SIG{HUP} = 'IGNORE';
208 local $SIG{INT} = 'IGNORE';
209 local $SIG{QUIT} = 'IGNORE';
210 local $SIG{TERM} = 'IGNORE';
211 local $SIG{TSTP} = 'IGNORE';
212 local $SIG{PIPE} = 'IGNORE';
214 my $oldAutoCommit = $FS::UID::AutoCommit;
215 local $FS::UID::AutoCommit = 0;
218 $error = $self->check;
219 return $error if $error;
221 #no, duplicate checking just got a whole lot more complicated
222 #(perhaps keep this check with a config option to turn on?)
224 #return gettext('username_in_use'). ": ". $self->username
225 # if qsearchs( 'svc_acct', { 'username' => $self->username,
226 # 'domsvc' => $self->domsvc,
229 if ( $self->svcnum ) {
230 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
231 unless ( $cust_svc ) {
232 $dbh->rollback if $oldAutoCommit;
233 return "no cust_svc record found for svcnum ". $self->svcnum;
235 $self->pkgnum($cust_svc->pkgnum);
236 $self->svcpart($cust_svc->svcpart);
239 #new duplicate username checking
241 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
242 unless ( $part_svc ) {
243 $dbh->rollback if $oldAutoCommit;
244 return 'unknown svcpart '. $self->svcpart;
247 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
248 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
249 'domsvc' => $self->domsvc } );
251 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
252 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
253 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
258 if ( @dup_user || @dup_userdomain || @dup_uid ) {
259 my $exports = FS::part_export::export_info('svc_acct');
260 my %conflict_user_svcpart;
261 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
263 foreach my $part_export ( $part_svc->part_export ) {
265 #this will catch to the same exact export
266 my @svcparts = map { $_->svcpart }
267 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
269 #this will catch to exports w/same exporthost+type ???
270 #my @other_part_export = qsearch('part_export', {
271 # 'machine' => $part_export->machine,
272 # 'exporttype' => $part_export->exporttype,
274 #foreach my $other_part_export ( @other_part_export ) {
275 # push @svcparts, map { $_->svcpart }
276 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
279 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
280 #silly kludge to avoid uninitialized value errors
281 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
282 ? $exports->{$part_export->exporttype}{'nodomain'}
284 if ( $nodomain =~ /^Y/i ) {
285 $conflict_user_svcpart{$_} = $part_export->exportnum
288 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
293 foreach my $dup_user ( @dup_user ) {
294 my $dup_svcpart = $dup_user->cust_svc->svcpart;
295 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
296 $dbh->rollback if $oldAutoCommit;
297 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
298 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
302 foreach my $dup_userdomain ( @dup_userdomain ) {
303 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
304 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
305 $dbh->rollback if $oldAutoCommit;
306 return "duplicate username\@domain: conflicts with svcnum ".
307 $dup_userdomain->svcnum. " via exportnum ".
308 $conflict_userdomain_svcpart{$dup_svcpart};
312 foreach my $dup_uid ( @dup_uid ) {
313 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
314 if ( exists($conflict_user_svcpart{$dup_svcpart})
315 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
316 $dbh->rollback if $oldAutoCommit;
317 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
318 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
319 || $conflict_userdomain_svcpart{$dup_svcpart};
325 #see? i told you it was more complicated
328 $error = $self->SUPER::insert(\@jobnums, $self->child_objects || [] );
330 $dbh->rollback if $oldAutoCommit;
334 if ( $self->usergroup ) {
335 foreach my $groupname ( @{$self->usergroup} ) {
336 my $radius_usergroup = new FS::radius_usergroup ( {
337 svcnum => $self->svcnum,
338 groupname => $groupname,
340 my $error = $radius_usergroup->insert;
342 $dbh->rollback if $oldAutoCommit;
348 #false laziness with sub replace (and cust_main)
349 my $queue = new FS::queue {
350 'svcnum' => $self->svcnum,
351 'job' => 'FS::svc_acct::append_fuzzyfiles'
353 $error = $queue->insert($self->username);
355 $dbh->rollback if $oldAutoCommit;
356 return "queueing job (transaction rolled back): $error";
359 my $cust_pkg = $self->cust_svc->cust_pkg;
362 my $cust_main = $cust_pkg->cust_main;
364 if ( $conf->exists('emailinvoiceauto') ) {
365 my @invoicing_list = $cust_main->invoicing_list;
366 push @invoicing_list, $self->email;
367 $cust_main->invoicing_list(\@invoicing_list);
372 if ( $welcome_template && $cust_pkg ) {
373 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
375 my $wqueue = new FS::queue {
376 'svcnum' => $self->svcnum,
377 'job' => 'FS::svc_acct::send_email'
379 my $error = $wqueue->insert(
381 'from' => $welcome_from,
382 'subject' => $welcome_subject,
383 'mimetype' => $welcome_mimetype,
384 'body' => $welcome_template->fill_in( HASH => {
385 'custnum' => $self->custnum,
386 'username' => $self->username,
387 'password' => $self->_password,
388 'first' => $cust_main->first,
389 'last' => $cust_main->getfield('last'),
390 'pkg' => $cust_pkg->part_pkg->pkg,
394 $dbh->rollback if $oldAutoCommit;
395 return "error queuing welcome email: $error";
398 foreach my $jobnum ( @jobnums ) {
399 my $error = $wqueue->depend_insert($jobnum);
401 $dbh->rollback if $oldAutoCommit;
402 return "error queuing welcome email job dependancy: $error";
412 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
418 Deletes this account from the database. If there is an error, returns the
419 error, otherwise returns false.
421 The corresponding FS::cust_svc record will be deleted as well.
423 (TODOC: new exports!)
430 return "Can't delete an account which is a (svc_forward) source!"
431 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
433 return "Can't delete an account which is a (svc_forward) destination!"
434 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
436 return "Can't delete an account with (svc_www) web service!"
437 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
439 # what about records in session ? (they should refer to history table)
441 local $SIG{HUP} = 'IGNORE';
442 local $SIG{INT} = 'IGNORE';
443 local $SIG{QUIT} = 'IGNORE';
444 local $SIG{TERM} = 'IGNORE';
445 local $SIG{TSTP} = 'IGNORE';
446 local $SIG{PIPE} = 'IGNORE';
448 my $oldAutoCommit = $FS::UID::AutoCommit;
449 local $FS::UID::AutoCommit = 0;
452 foreach my $cust_main_invoice (
453 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
455 unless ( defined($cust_main_invoice) ) {
456 warn "WARNING: something's wrong with qsearch";
459 my %hash = $cust_main_invoice->hash;
460 $hash{'dest'} = $self->email;
461 my $new = new FS::cust_main_invoice \%hash;
462 my $error = $new->replace($cust_main_invoice);
464 $dbh->rollback if $oldAutoCommit;
469 foreach my $svc_domain (
470 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
472 my %hash = new FS::svc_domain->hash;
473 $hash{'catchall'} = '';
474 my $new = new FS::svc_domain \%hash;
475 my $error = $new->replace($svc_domain);
477 $dbh->rollback if $oldAutoCommit;
482 foreach my $radius_usergroup (
483 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
485 my $error = $radius_usergroup->delete;
487 $dbh->rollback if $oldAutoCommit;
492 my $error = $self->SUPER::delete;
494 $dbh->rollback if $oldAutoCommit;
498 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
502 =item replace OLD_RECORD
504 Replaces OLD_RECORD with this one in the database. If there is an error,
505 returns the error, otherwise returns false.
507 The additional field I<usergroup> can optionally be defined; if so it should
508 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
509 sqlradius export only)
514 my ( $new, $old ) = ( shift, shift );
516 warn "$me replacing $old with $new\n" if $DEBUG;
518 return "Username in use"
519 if $old->username ne $new->username &&
520 qsearchs( 'svc_acct', { 'username' => $new->username,
521 'domsvc' => $new->domsvc,
524 #no warnings 'numeric'; #alas, a 5.006-ism
526 return "Can't change uid!" if $old->uid != $new->uid;
529 #change homdir when we change username
530 $new->setfield('dir', '') if $old->username ne $new->username;
532 local $SIG{HUP} = 'IGNORE';
533 local $SIG{INT} = 'IGNORE';
534 local $SIG{QUIT} = 'IGNORE';
535 local $SIG{TERM} = 'IGNORE';
536 local $SIG{TSTP} = 'IGNORE';
537 local $SIG{PIPE} = 'IGNORE';
539 my $oldAutoCommit = $FS::UID::AutoCommit;
540 local $FS::UID::AutoCommit = 0;
543 # redundant, but so $new->usergroup gets set
544 $error = $new->check;
545 return $error if $error;
547 $old->usergroup( [ $old->radius_groups ] );
548 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
549 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
550 if ( $new->usergroup ) {
551 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
552 my @newgroups = @{$new->usergroup};
553 foreach my $oldgroup ( @{$old->usergroup} ) {
554 if ( grep { $oldgroup eq $_ } @newgroups ) {
555 @newgroups = grep { $oldgroup ne $_ } @newgroups;
558 my $radius_usergroup = qsearchs('radius_usergroup', {
559 svcnum => $old->svcnum,
560 groupname => $oldgroup,
562 my $error = $radius_usergroup->delete;
564 $dbh->rollback if $oldAutoCommit;
565 return "error deleting radius_usergroup $oldgroup: $error";
569 foreach my $newgroup ( @newgroups ) {
570 my $radius_usergroup = new FS::radius_usergroup ( {
571 svcnum => $new->svcnum,
572 groupname => $newgroup,
574 my $error = $radius_usergroup->insert;
576 $dbh->rollback if $oldAutoCommit;
577 return "error adding radius_usergroup $newgroup: $error";
583 $error = $new->SUPER::replace($old);
585 $dbh->rollback if $oldAutoCommit;
586 return $error if $error;
589 if ( $new->username ne $old->username ) {
590 #false laziness with sub insert (and cust_main)
591 my $queue = new FS::queue {
592 'svcnum' => $new->svcnum,
593 'job' => 'FS::svc_acct::append_fuzzyfiles'
595 $error = $queue->insert($new->username);
597 $dbh->rollback if $oldAutoCommit;
598 return "queueing job (transaction rolled back): $error";
602 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
608 Suspends this account by calling export-specific suspend hooks. If there is
609 an error, returns the error, otherwise returns false.
611 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
617 my %hash = $self->hash;
618 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
619 || $hash{_password} eq '*'
621 $hash{_password} = '*SUSPENDED* '.$hash{_password};
622 my $new = new FS::svc_acct ( \%hash );
623 my $error = $new->replace($self);
624 return $error if $error;
627 $self->SUPER::suspend;
632 Unsuspends this account by by calling export-specific suspend hooks. If there
633 is an error, returns the error, otherwise returns false.
635 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
641 my %hash = $self->hash;
642 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
643 $hash{_password} = $1;
644 my $new = new FS::svc_acct ( \%hash );
645 my $error = $new->replace($self);
646 return $error if $error;
649 $self->SUPER::unsuspend;
654 Just returns false (no error) for now.
656 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
660 Checks all fields to make sure this is a valid service. If there is an error,
661 returns the error, otherwise returns false. Called by the insert and replace
664 Sets any fixed values; see L<FS::part_svc>.
671 my($recref) = $self->hashref;
673 my $x = $self->setfixed;
674 return $x unless ref($x);
677 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
679 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
682 my $error = $self->ut_numbern('svcnum')
683 #|| $self->ut_number('domsvc')
684 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
685 || $self->ut_textn('sec_phrase')
687 return $error if $error;
689 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
690 if ( $username_uppercase ) {
691 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
692 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
693 $recref->{username} = $1;
695 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
696 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
697 $recref->{username} = $1;
700 if ( $username_letterfirst ) {
701 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
702 } elsif ( $username_letter ) {
703 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
705 if ( $username_noperiod ) {
706 $recref->{username} =~ /\./ and return gettext('illegal_username');
708 if ( $username_nounderscore ) {
709 $recref->{username} =~ /_/ and return gettext('illegal_username');
711 if ( $username_nodash ) {
712 $recref->{username} =~ /\-/ and return gettext('illegal_username');
714 unless ( $username_ampersand ) {
715 $recref->{username} =~ /\&/ and return gettext('illegal_username');
718 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
719 $recref->{popnum} = $1;
720 return "Unknown popnum" unless
721 ! $recref->{popnum} ||
722 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
724 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
726 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
727 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
729 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
730 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
731 #not all systems use gid=uid
732 #you can set a fixed gid in part_svc
734 return "Only root can have uid 0"
735 if $recref->{uid} == 0
736 && $recref->{username} ne 'root'
737 && $recref->{username} ne 'toor';
740 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
741 or return "Illegal directory: ". $recref->{dir};
743 return "Illegal directory"
744 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
745 return "Illegal directory"
746 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
747 unless ( $recref->{dir} ) {
748 $recref->{dir} = $dir_prefix . '/';
749 if ( $dirhash > 0 ) {
750 for my $h ( 1 .. $dirhash ) {
751 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
753 } elsif ( $dirhash < 0 ) {
754 for my $h ( reverse $dirhash .. -1 ) {
755 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
758 $recref->{dir} .= $recref->{username};
762 unless ( $recref->{username} eq 'sync' ) {
763 if ( grep $_ eq $recref->{shell}, @shells ) {
764 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
766 return "Illegal shell \`". $self->shell. "\'; ".
767 $conf->dir. "/shells contains: @shells";
770 $recref->{shell} = '/bin/sync';
774 $recref->{gid} ne '' ?
775 return "Can't have gid without uid" : ( $recref->{gid}='' );
776 $recref->{dir} ne '' ?
777 return "Can't have directory without uid" : ( $recref->{dir}='' );
778 $recref->{shell} ne '' ?
779 return "Can't have shell without uid" : ( $recref->{shell}='' );
782 # $error = $self->ut_textn('finger');
783 # return $error if $error;
784 $self->getfield('finger') =~
785 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
786 or return "Illegal finger: ". $self->getfield('finger');
787 $self->setfield('finger', $1);
789 $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
790 $recref->{quota} = $1;
792 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
793 if ( $recref->{slipip} eq '' ) {
794 $recref->{slipip} = '';
795 } elsif ( $recref->{slipip} eq '0e0' ) {
796 $recref->{slipip} = '0e0';
798 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
799 or return "Illegal slipip: ". $self->slipip;
800 $recref->{slipip} = $1;
805 #arbitrary RADIUS stuff; allow ut_textn for now
806 foreach ( grep /^radius_/, fields('svc_acct') ) {
810 #generate a password if it is blank
811 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
812 unless ( $recref->{_password} );
814 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
815 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
816 $recref->{_password} = $1.$3;
817 #uncomment this to encrypt password immediately upon entry, or run
818 #bin/crypt_pw in cron to give new users a window during which their
819 #password is available to techs, for faxing, etc. (also be aware of
821 #$recref->{password} = $1.
822 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
824 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
825 $recref->{_password} = $1.$3;
826 } elsif ( $recref->{_password} eq '*' ) {
827 $recref->{_password} = '*';
828 } elsif ( $recref->{_password} eq '!' ) {
829 $recref->{_password} = '!';
830 } elsif ( $recref->{_password} eq '!!' ) {
831 $recref->{_password} = '!!';
833 #return "Illegal password";
834 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
835 FS::Msgcat::_gettext('illegal_password_characters').
836 ": ". $recref->{_password};
844 Depriciated, use radius_reply instead.
849 carp "FS::svc_acct::radius depriciated, use radius_reply";
855 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
856 reply attributes of this record.
858 Note that this is now the preferred method for reading RADIUS attributes -
859 accessing the columns directly is discouraged, as the column names are
860 expected to change in the future.
869 my($column, $attrib) = ($1, $2);
870 #$attrib =~ s/_/\-/g;
871 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
872 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
873 if ( $self->slipip && $self->slipip ne '0e0' ) {
874 $reply{$radius_ip} = $self->slipip;
881 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
882 check attributes of this record.
884 Note that this is now the preferred method for reading RADIUS attributes -
885 accessing the columns directly is discouraged, as the column names are
886 expected to change in the future.
892 my $password = $self->_password;
893 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
894 ( $pw_attrib => $password,
897 my($column, $attrib) = ($1, $2);
898 #$attrib =~ s/_/\-/g;
899 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
900 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
906 Returns the domain associated with this account.
912 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
913 my $svc_domain = $self->svc_domain
914 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
920 Returns the FS::svc_domain record for this account's domain (see
929 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
934 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
940 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
945 Returns an email address associated with the account.
951 $self->username. '@'. $self->domain;
954 =item seconds_since TIMESTAMP
956 Returns the number of seconds this account has been online since TIMESTAMP,
957 according to the session monitor (see L<FS::Session>).
959 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
960 L<Time::Local> and L<Date::Parse> for conversion functions.
964 #note: POD here, implementation in FS::cust_svc
967 $self->cust_svc->seconds_since(@_);
970 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
972 Returns the numbers of seconds this account has been online between
973 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
974 external SQL radacct table, specified via sqlradius export. Sessions which
975 started in the specified range but are still open are counted from session
976 start to the end of the range (unless they are over 1 day old, in which case
977 they are presumed missing their stop record and not counted). Also, sessions
978 which end in the range but started earlier are counted from the start of the
979 range to session end. Finally, sessions which start before the range but end
980 after are counted for the entire range.
982 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
983 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
988 #note: POD here, implementation in FS::cust_svc
989 sub seconds_since_sqlradacct {
991 $self->cust_svc->seconds_since_sqlradacct(@_);
994 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
996 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
997 in this package for sessions ending between TIMESTAMP_START (inclusive) and
998 TIMESTAMP_END (exclusive).
1000 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1001 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1006 #note: POD here, implementation in FS::cust_svc
1007 sub attribute_since_sqlradacct {
1009 $self->cust_svc->attribute_since_sqlradacct(@_);
1012 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1014 Returns an array of hash references of this customers login history for the
1015 given time range. (document this better)
1019 sub get_session_history_sqlradacct {
1021 $self->cust_svc->get_session_history_sqlradacct(@_);
1026 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1032 if ( $self->usergroup ) {
1033 #when provisioning records, export callback runs in svc_Common.pm before
1034 #radius_usergroup records can be inserted...
1035 @{$self->usergroup};
1037 map { $_->groupname }
1038 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1050 This is the FS::svc_acct job-queue-able version. It still uses
1051 FS::Misc::send_email under-the-hood.
1058 eval "use FS::Misc qw(send_email)";
1061 $opt{mimetype} ||= 'text/plain';
1062 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1064 my $error = send_email(
1065 'from' => $opt{from},
1067 'subject' => $opt{subject},
1068 'content-type' => $opt{mimetype},
1069 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1071 die $error if $error;
1074 =item check_and_rebuild_fuzzyfiles
1078 sub check_and_rebuild_fuzzyfiles {
1079 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1080 -e "$dir/svc_acct.username"
1081 or &rebuild_fuzzyfiles;
1084 =item rebuild_fuzzyfiles
1088 sub rebuild_fuzzyfiles {
1090 use Fcntl qw(:flock);
1092 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1096 open(USERNAMELOCK,">>$dir/svc_acct.username")
1097 or die "can't open $dir/svc_acct.username: $!";
1098 flock(USERNAMELOCK,LOCK_EX)
1099 or die "can't lock $dir/svc_acct.username: $!";
1101 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1103 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1104 or die "can't open $dir/svc_acct.username.tmp: $!";
1105 print USERNAMECACHE join("\n", @all_username), "\n";
1106 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1108 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1118 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1119 open(USERNAMECACHE,"<$dir/svc_acct.username")
1120 or die "can't open $dir/svc_acct.username: $!";
1121 my @array = map { chomp; $_; } <USERNAMECACHE>;
1122 close USERNAMECACHE;
1126 =item append_fuzzyfiles USERNAME
1130 sub append_fuzzyfiles {
1131 my $username = shift;
1133 &check_and_rebuild_fuzzyfiles;
1135 use Fcntl qw(:flock);
1137 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1139 open(USERNAME,">>$dir/svc_acct.username")
1140 or die "can't open $dir/svc_acct.username: $!";
1141 flock(USERNAME,LOCK_EX)
1142 or die "can't lock $dir/svc_acct.username: $!";
1144 print USERNAME "$username\n";
1146 flock(USERNAME,LOCK_UN)
1147 or die "can't unlock $dir/svc_acct.username: $!";
1155 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1159 sub radius_usergroup_selector {
1160 my $sel_groups = shift;
1161 my %sel_groups = map { $_=>1 } @$sel_groups;
1163 my $selectname = shift || 'radius_usergroup';
1166 my $sth = $dbh->prepare(
1167 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1168 ) or die $dbh->errstr;
1169 $sth->execute() or die $sth->errstr;
1170 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1174 function ${selectname}_doadd(object) {
1175 var myvalue = object.${selectname}_add.value;
1176 var optionName = new Option(myvalue,myvalue,false,true);
1177 var length = object.$selectname.length;
1178 object.$selectname.options[length] = optionName;
1179 object.${selectname}_add.value = "";
1182 <SELECT MULTIPLE NAME="$selectname">
1185 foreach my $group ( @all_groups ) {
1187 if ( $sel_groups{$group} ) {
1188 $html .= ' SELECTED';
1189 $sel_groups{$group} = 0;
1191 $html .= ">$group</OPTION>\n";
1193 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1194 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1196 $html .= '</SELECT>';
1198 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1199 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1208 The $recref stuff in sub check should be cleaned up.
1210 The suspend, unsuspend and cancel methods update the database, but not the
1211 current object. This is probably a bug as it's unexpected and
1214 radius_usergroup_selector? putting web ui components in here? they should
1215 probably live somewhere else...
1219 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1220 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1221 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1222 L<freeside-queued>), L<FS::svc_acct_pop>,
1223 schema.html from the base documentation.