4 use vars qw( @ISA $DEBUG $me $noexport_hack $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
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 $smtpmachine = $conf->config('smtpmachine');
67 $radius_password = $conf->config('radius-password') || 'Password';
70 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
71 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
75 my ( $hashref, $cache ) = @_;
76 if ( $hashref->{'svc_acct_svcnum'} ) {
77 $self->{'_domsvc'} = FS::svc_domain->new( {
78 'svcnum' => $hashref->{'domsvc'},
79 'domain' => $hashref->{'svc_acct_domain'},
80 'catchall' => $hashref->{'svc_acct_catchall'},
87 FS::svc_acct - Object methods for svc_acct records
93 $record = new FS::svc_acct \%hash;
94 $record = new FS::svc_acct { 'column' => 'value' };
96 $error = $record->insert;
98 $error = $new_record->replace($old_record);
100 $error = $record->delete;
102 $error = $record->check;
104 $error = $record->suspend;
106 $error = $record->unsuspend;
108 $error = $record->cancel;
110 %hash = $record->radius;
112 %hash = $record->radius_reply;
114 %hash = $record->radius_check;
116 $domain = $record->domain;
118 $svc_domain = $record->svc_domain;
120 $email = $record->email;
122 $seconds_since = $record->seconds_since($timestamp);
126 An FS::svc_acct object represents an account. FS::svc_acct inherits from
127 FS::svc_Common. The following fields are currently supported:
131 =item svcnum - primary key (assigned automatcially for new accounts)
135 =item _password - generated if blank
137 =item sec_phrase - security phrase
139 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
147 =item dir - set automatically if blank (and uid is not)
151 =item quota - (unimplementd)
153 =item slipip - IP address
157 =item domsvc - svcnum from svc_domain
159 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
169 Creates a new account. To add the account to the database, see L<"insert">.
173 sub table { 'svc_acct'; }
177 Adds this account to the database. If there is an error, returns the error,
178 otherwise returns false.
180 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
181 defined. An FS::cust_svc record will be created and inserted.
183 The additional field I<usergroup> can optionally be defined; if so it should
184 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
185 sqlradius export only)
187 (TODOC: L<FS::queue> and L<freeside-queued>)
189 (TODOC: new exports! $noexport_hack)
197 local $SIG{HUP} = 'IGNORE';
198 local $SIG{INT} = 'IGNORE';
199 local $SIG{QUIT} = 'IGNORE';
200 local $SIG{TERM} = 'IGNORE';
201 local $SIG{TSTP} = 'IGNORE';
202 local $SIG{PIPE} = 'IGNORE';
204 my $oldAutoCommit = $FS::UID::AutoCommit;
205 local $FS::UID::AutoCommit = 0;
208 $error = $self->check;
209 return $error if $error;
211 #no, duplicate checking just got a whole lot more complicated
212 #(perhaps keep this check with a config option to turn on?)
214 #return gettext('username_in_use'). ": ". $self->username
215 # if qsearchs( 'svc_acct', { 'username' => $self->username,
216 # 'domsvc' => $self->domsvc,
219 if ( $self->svcnum ) {
220 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
221 unless ( $cust_svc ) {
222 $dbh->rollback if $oldAutoCommit;
223 return "no cust_svc record found for svcnum ". $self->svcnum;
225 $self->pkgnum($cust_svc->pkgnum);
226 $self->svcpart($cust_svc->svcpart);
229 #new duplicate username checking
231 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
232 unless ( $part_svc ) {
233 $dbh->rollback if $oldAutoCommit;
234 return 'unknown svcpart '. $self->svcpart;
237 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
238 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
239 'domsvc' => $self->domsvc } );
241 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
242 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
243 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
248 if ( @dup_user || @dup_userdomain || @dup_uid ) {
249 my $exports = FS::part_export::export_info('svc_acct');
250 my %conflict_user_svcpart;
251 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
253 foreach my $part_export ( $part_svc->part_export ) {
255 #this will catch to the same exact export
256 my @svcparts = map { $_->svcpart }
257 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
259 #this will catch to exports w/same exporthost+type ???
260 #my @other_part_export = qsearch('part_export', {
261 # 'machine' => $part_export->machine,
262 # 'exporttype' => $part_export->exporttype,
264 #foreach my $other_part_export ( @other_part_export ) {
265 # push @svcparts, map { $_->svcpart }
266 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
269 my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
270 if ( $nodomain =~ /^Y/i ) {
271 $conflict_user_svcpart{$_} = $part_export->exportnum
274 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
279 foreach my $dup_user ( @dup_user ) {
280 my $dup_svcpart = $dup_user->cust_svc->svcpart;
281 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
282 $dbh->rollback if $oldAutoCommit;
283 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
284 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
288 foreach my $dup_userdomain ( @dup_userdomain ) {
289 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
290 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
291 $dbh->rollback if $oldAutoCommit;
292 return "duplicate username\@domain: conflicts with svcnum ".
293 $dup_userdomain->svcnum. " via exportnum ".
294 $conflict_userdomain_svcpart{$dup_svcpart};
298 foreach my $dup_uid ( @dup_uid ) {
299 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
300 if ( exists($conflict_user_svcpart{$dup_svcpart})
301 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
302 $dbh->rollback if $oldAutoCommit;
303 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
304 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
305 || $conflict_userdomain_svcpart{$dup_svcpart};
311 #see? i told you it was more complicated
314 $error = $self->SUPER::insert(\@jobnums);
316 $dbh->rollback if $oldAutoCommit;
320 if ( $self->usergroup ) {
321 foreach my $groupname ( @{$self->usergroup} ) {
322 my $radius_usergroup = new FS::radius_usergroup ( {
323 svcnum => $self->svcnum,
324 groupname => $groupname,
326 my $error = $radius_usergroup->insert;
328 $dbh->rollback if $oldAutoCommit;
334 #false laziness with sub replace (and cust_main)
335 my $queue = new FS::queue {
336 'svcnum' => $self->svcnum,
337 'job' => 'FS::svc_acct::append_fuzzyfiles'
339 $error = $queue->insert($self->username);
341 $dbh->rollback if $oldAutoCommit;
342 return "queueing job (transaction rolled back): $error";
345 my $cust_pkg = $self->cust_svc->cust_pkg;
348 my $cust_main = $cust_pkg->cust_main;
350 if ( $conf->exists('emailinvoiceauto') ) {
351 my @invoicing_list = $cust_main->invoicing_list;
352 push @invoicing_list, $self->email;
353 $cust_main->invoicing_list(\@invoicing_list);
358 if ( $welcome_template && $cust_pkg ) {
359 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
361 my $wqueue = new FS::queue {
362 'svcnum' => $self->svcnum,
363 'job' => 'FS::svc_acct::send_email'
365 warn "attempting to queue email to $to";
366 my $error = $wqueue->insert(
368 'from' => $welcome_from,
369 'subject' => $welcome_subject,
370 'mimetype' => $welcome_mimetype,
371 'body' => $welcome_template->fill_in( HASH => {
372 'username' => $self->username,
373 'password' => $self->_password,
374 'first' => $cust_main->first,
375 'last' => $cust_main->getfield('last'),
376 'pkg' => $cust_pkg->part_pkg->pkg,
380 $dbh->rollback if $oldAutoCommit;
381 return "queuing welcome email: $error";
384 foreach my $jobnum ( @jobnums ) {
385 my $error = $wqueue->depend_insert($jobnum);
387 $dbh->rollback if $oldAutoCommit;
388 return "queuing welcome email job dependancy: $error";
398 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
404 Deletes this account from the database. If there is an error, returns the
405 error, otherwise returns false.
407 The corresponding FS::cust_svc record will be deleted as well.
409 (TODOC: new exports! $noexport_hack)
416 return "Can't delete an account which is a (svc_forward) source!"
417 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
419 return "Can't delete an account which is a (svc_forward) destination!"
420 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
422 return "Can't delete an account with (svc_www) web service!"
423 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
425 # what about records in session ? (they should refer to history table)
427 local $SIG{HUP} = 'IGNORE';
428 local $SIG{INT} = 'IGNORE';
429 local $SIG{QUIT} = 'IGNORE';
430 local $SIG{TERM} = 'IGNORE';
431 local $SIG{TSTP} = 'IGNORE';
432 local $SIG{PIPE} = 'IGNORE';
434 my $oldAutoCommit = $FS::UID::AutoCommit;
435 local $FS::UID::AutoCommit = 0;
438 foreach my $cust_main_invoice (
439 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
441 unless ( defined($cust_main_invoice) ) {
442 warn "WARNING: something's wrong with qsearch";
445 my %hash = $cust_main_invoice->hash;
446 $hash{'dest'} = $self->email;
447 my $new = new FS::cust_main_invoice \%hash;
448 my $error = $new->replace($cust_main_invoice);
450 $dbh->rollback if $oldAutoCommit;
455 foreach my $svc_domain (
456 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
458 my %hash = new FS::svc_domain->hash;
459 $hash{'catchall'} = '';
460 my $new = new FS::svc_domain \%hash;
461 my $error = $new->replace($svc_domain);
463 $dbh->rollback if $oldAutoCommit;
468 foreach my $radius_usergroup (
469 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
471 my $error = $radius_usergroup->delete;
473 $dbh->rollback if $oldAutoCommit;
478 my $error = $self->SUPER::delete;
480 $dbh->rollback if $oldAutoCommit;
484 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
488 =item replace OLD_RECORD
490 Replaces OLD_RECORD with this one in the database. If there is an error,
491 returns the error, otherwise returns false.
493 The additional field I<usergroup> can optionally be defined; if so it should
494 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
495 sqlradius export only)
500 my ( $new, $old ) = ( shift, shift );
502 warn "$me replacing $old with $new\n" if $DEBUG;
504 return "Username in use"
505 if $old->username ne $new->username &&
506 qsearchs( 'svc_acct', { 'username' => $new->username,
507 'domsvc' => $new->domsvc,
510 #no warnings 'numeric'; #alas, a 5.006-ism
512 return "Can't change uid!" if $old->uid != $new->uid;
515 #change homdir when we change username
516 $new->setfield('dir', '') if $old->username ne $new->username;
518 local $SIG{HUP} = 'IGNORE';
519 local $SIG{INT} = 'IGNORE';
520 local $SIG{QUIT} = 'IGNORE';
521 local $SIG{TERM} = 'IGNORE';
522 local $SIG{TSTP} = 'IGNORE';
523 local $SIG{PIPE} = 'IGNORE';
525 my $oldAutoCommit = $FS::UID::AutoCommit;
526 local $FS::UID::AutoCommit = 0;
529 # redundant, but so $new->usergroup gets set
530 $error = $new->check;
531 return $error if $error;
533 $old->usergroup( [ $old->radius_groups ] );
534 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
535 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
536 if ( $new->usergroup ) {
537 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
538 my @newgroups = @{$new->usergroup};
539 foreach my $oldgroup ( @{$old->usergroup} ) {
540 if ( grep { $oldgroup eq $_ } @newgroups ) {
541 @newgroups = grep { $oldgroup ne $_ } @newgroups;
544 my $radius_usergroup = qsearchs('radius_usergroup', {
545 svcnum => $old->svcnum,
546 groupname => $oldgroup,
548 my $error = $radius_usergroup->delete;
550 $dbh->rollback if $oldAutoCommit;
551 return "error deleting radius_usergroup $oldgroup: $error";
555 foreach my $newgroup ( @newgroups ) {
556 my $radius_usergroup = new FS::radius_usergroup ( {
557 svcnum => $new->svcnum,
558 groupname => $newgroup,
560 my $error = $radius_usergroup->insert;
562 $dbh->rollback if $oldAutoCommit;
563 return "error adding radius_usergroup $newgroup: $error";
569 $error = $new->SUPER::replace($old);
571 $dbh->rollback if $oldAutoCommit;
572 return $error if $error;
575 if ( $new->username ne $old->username ) {
576 #false laziness with sub insert (and cust_main)
577 my $queue = new FS::queue {
578 'svcnum' => $new->svcnum,
579 'job' => 'FS::svc_acct::append_fuzzyfiles'
581 $error = $queue->insert($new->username);
583 $dbh->rollback if $oldAutoCommit;
584 return "queueing job (transaction rolled back): $error";
588 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
594 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
595 error, returns the error, otherwise returns false.
597 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
603 my %hash = $self->hash;
604 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
605 || $hash{_password} eq '*'
607 $hash{_password} = '*SUSPENDED* '.$hash{_password};
608 my $new = new FS::svc_acct ( \%hash );
609 my $error = $new->replace($self);
610 return $error if $error;
613 $self->SUPER::suspend;
618 Unsuspends this account by removing *SUSPENDED* from the password. If there is
619 an error, returns the error, otherwise returns false.
621 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
627 my %hash = $self->hash;
628 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
629 $hash{_password} = $1;
630 my $new = new FS::svc_acct ( \%hash );
631 my $error = $new->replace($self);
632 return $error if $error;
635 $self->SUPER::unsuspend;
640 Just returns false (no error) for now.
642 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
646 Checks all fields to make sure this is a valid service. If there is an error,
647 returns the error, otherwise returns false. Called by the insert and replace
650 Sets any fixed values; see L<FS::part_svc>.
657 my($recref) = $self->hashref;
659 my $x = $self->setfixed;
660 return $x unless ref($x);
663 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
665 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
668 my $error = $self->ut_numbern('svcnum')
669 || $self->ut_number('domsvc')
670 || $self->ut_textn('sec_phrase')
672 return $error if $error;
674 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
675 if ( $username_uppercase ) {
676 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
677 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
678 $recref->{username} = $1;
680 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
681 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
682 $recref->{username} = $1;
685 if ( $username_letterfirst ) {
686 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
687 } elsif ( $username_letter ) {
688 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
690 if ( $username_noperiod ) {
691 $recref->{username} =~ /\./ and return gettext('illegal_username');
693 if ( $username_nounderscore ) {
694 $recref->{username} =~ /_/ and return gettext('illegal_username');
696 if ( $username_nodash ) {
697 $recref->{username} =~ /\-/ and return gettext('illegal_username');
699 unless ( $username_ampersand ) {
700 $recref->{username} =~ /\&/ and return gettext('illegal_username');
703 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
704 $recref->{popnum} = $1;
705 return "Unknown popnum" unless
706 ! $recref->{popnum} ||
707 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
709 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
711 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
712 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
714 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
715 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
716 #not all systems use gid=uid
717 #you can set a fixed gid in part_svc
719 return "Only root can have uid 0"
720 if $recref->{uid} == 0
721 && $recref->{username} ne 'root'
722 && $recref->{username} ne 'toor';
725 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
726 or return "Illegal directory: ". $recref->{dir};
728 return "Illegal directory"
729 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
730 return "Illegal directory"
731 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
732 unless ( $recref->{dir} ) {
733 $recref->{dir} = $dir_prefix . '/';
734 if ( $dirhash > 0 ) {
735 for my $h ( 1 .. $dirhash ) {
736 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
738 } elsif ( $dirhash < 0 ) {
739 for my $h ( reverse $dirhash .. -1 ) {
740 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
743 $recref->{dir} .= $recref->{username};
747 unless ( $recref->{username} eq 'sync' ) {
748 if ( grep $_ eq $recref->{shell}, @shells ) {
749 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
751 return "Illegal shell \`". $self->shell. "\'; ".
752 $conf->dir. "/shells contains: @shells";
755 $recref->{shell} = '/bin/sync';
759 $recref->{gid} ne '' ?
760 return "Can't have gid without uid" : ( $recref->{gid}='' );
761 $recref->{dir} ne '' ?
762 return "Can't have directory without uid" : ( $recref->{dir}='' );
763 $recref->{shell} ne '' ?
764 return "Can't have shell without uid" : ( $recref->{shell}='' );
767 # $error = $self->ut_textn('finger');
768 # return $error if $error;
769 $self->getfield('finger') =~
770 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
771 or return "Illegal finger: ". $self->getfield('finger');
772 $self->setfield('finger', $1);
774 $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
775 $recref->{quota} = $1;
777 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
778 unless ( $recref->{slipip} eq '0e0' ) {
779 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
780 or return "Illegal slipip: ". $self->slipip;
781 $recref->{slipip} = $1;
783 $recref->{slipip} = '0e0';
788 #arbitrary RADIUS stuff; allow ut_textn for now
789 foreach ( grep /^radius_/, fields('svc_acct') ) {
793 #generate a password if it is blank
794 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
795 unless ( $recref->{_password} );
797 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
798 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
799 $recref->{_password} = $1.$3;
800 #uncomment this to encrypt password immediately upon entry, or run
801 #bin/crypt_pw in cron to give new users a window during which their
802 #password is available to techs, for faxing, etc. (also be aware of
804 #$recref->{password} = $1.
805 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
807 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,34})$/ ) {
808 $recref->{_password} = $1.$3;
809 } elsif ( $recref->{_password} eq '*' ) {
810 $recref->{_password} = '*';
811 } elsif ( $recref->{_password} eq '!!' ) {
812 $recref->{_password} = '!!';
814 #return "Illegal password";
815 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
816 FS::Msgcat::_gettext('illegal_password_characters').
817 ": ". $recref->{_password};
825 Depriciated, use radius_reply instead.
830 carp "FS::svc_acct::radius depriciated, use radius_reply";
836 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
837 reply attributes of this record.
839 Note that this is now the preferred method for reading RADIUS attributes -
840 accessing the columns directly is discouraged, as the column names are
841 expected to change in the future.
850 my($column, $attrib) = ($1, $2);
851 #$attrib =~ s/_/\-/g;
852 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
853 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
854 if ( $self->slipip && $self->slipip ne '0e0' ) {
855 $reply{'Framed-IP-Address'} = $self->slipip;
862 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
863 check attributes of this record.
865 Note that this is now the preferred method for reading RADIUS attributes -
866 accessing the columns directly is discouraged, as the column names are
867 expected to change in the future.
873 my $password = $self->_password;
874 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
875 ( $pw_attrib => $password,
878 my($column, $attrib) = ($1, $2);
879 #$attrib =~ s/_/\-/g;
880 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
881 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
887 Returns the domain associated with this account.
893 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
894 my $svc_domain = $self->svc_domain
895 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
901 Returns the FS::svc_domain record for this account's domain (see
910 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
915 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
919 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
924 Returns an email address associated with the account.
930 $self->username. '@'. $self->domain;
933 =item seconds_since TIMESTAMP
935 Returns the number of seconds this account has been online since TIMESTAMP,
936 according to the session monitor (see L<FS::Session>).
938 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
939 L<Time::Local> and L<Date::Parse> for conversion functions.
943 #note: POD here, implementation in FS::cust_svc
946 $self->cust_svc->seconds_since(@_);
949 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
951 Returns the numbers of seconds this account has been online between
952 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
953 external SQL radacct table, specified via sqlradius export. Sessions which
954 started in the specified range but are still open are counted from session
955 start to the end of the range (unless they are over 1 day old, in which case
956 they are presumed missing their stop record and not counted). Also, sessions
957 which end in therange but started earlier are counted from the start of the
958 range to session end. Finally, sessions which start before the range but end
959 after are counted for the entire range.
961 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
962 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
967 #note: POD here, implementation in FS::cust_svc
968 sub seconds_since_sqlradacct {
970 $self->cust_svc->seconds_since_sqlradacct(@_);
973 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
975 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
976 in this package for sessions ending between TIMESTAMP_START (inclusive) and
977 TIMESTAMP_END (exclusive).
979 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
980 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
985 #note: POD here, implementation in FS::cust_svc
986 sub attribute_since_sqlradacct {
988 $self->cust_svc->attribute_since_sqlradacct(@_);
993 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
999 if ( $self->usergroup ) {
1000 #when provisioning records, export callback runs in svc_Common.pm before
1001 #radius_usergroup records can be inserted...
1002 @{$self->usergroup};
1004 map { $_->groupname }
1005 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1023 use Mail::Internet 1.44;
1026 $opt{mimetype} ||= 'text/plain';
1027 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1029 $ENV{MAILADDRESS} = $opt{from};
1030 my $header = new Mail::Header ( [
1033 "Sender: $opt{from}",
1034 "Reply-To: $opt{from}",
1035 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1036 "Subject: $opt{subject}",
1037 "Content-Type: $opt{mimetype}",
1039 my $message = new Mail::Internet (
1040 'Header' => $header,
1041 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1044 $message->smtpsend( Host => $smtpmachine )
1045 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1046 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1049 =item check_and_rebuild_fuzzyfiles
1053 sub check_and_rebuild_fuzzyfiles {
1054 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1055 -e "$dir/svc_acct.username"
1056 or &rebuild_fuzzyfiles;
1059 =item rebuild_fuzzyfiles
1063 sub rebuild_fuzzyfiles {
1065 use Fcntl qw(:flock);
1067 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1071 open(USERNAMELOCK,">>$dir/svc_acct.username")
1072 or die "can't open $dir/svc_acct.username: $!";
1073 flock(USERNAMELOCK,LOCK_EX)
1074 or die "can't lock $dir/svc_acct.username: $!";
1076 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1078 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1079 or die "can't open $dir/svc_acct.username.tmp: $!";
1080 print USERNAMECACHE join("\n", @all_username), "\n";
1081 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1083 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1093 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1094 open(USERNAMECACHE,"<$dir/svc_acct.username")
1095 or die "can't open $dir/svc_acct.username: $!";
1096 my @array = map { chomp; $_; } <USERNAMECACHE>;
1097 close USERNAMECACHE;
1101 =item append_fuzzyfiles USERNAME
1105 sub append_fuzzyfiles {
1106 my $username = shift;
1108 &check_and_rebuild_fuzzyfiles;
1110 use Fcntl qw(:flock);
1112 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1114 open(USERNAME,">>$dir/svc_acct.username")
1115 or die "can't open $dir/svc_acct.username: $!";
1116 flock(USERNAME,LOCK_EX)
1117 or die "can't lock $dir/svc_acct.username: $!";
1119 print USERNAME "$username\n";
1121 flock(USERNAME,LOCK_UN)
1122 or die "can't unlock $dir/svc_acct.username: $!";
1130 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1134 sub radius_usergroup_selector {
1135 my $sel_groups = shift;
1136 my %sel_groups = map { $_=>1 } @$sel_groups;
1138 my $selectname = shift || 'radius_usergroup';
1141 my $sth = $dbh->prepare(
1142 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1143 ) or die $dbh->errstr;
1144 $sth->execute() or die $sth->errstr;
1145 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1149 function ${selectname}_doadd(object) {
1150 var myvalue = object.${selectname}_add.value;
1151 var optionName = new Option(myvalue,myvalue,false,true);
1152 var length = object.$selectname.length;
1153 object.$selectname.options[length] = optionName;
1154 object.${selectname}_add.value = "";
1157 <SELECT MULTIPLE NAME="$selectname">
1160 foreach my $group ( @all_groups ) {
1162 if ( $sel_groups{$group} ) {
1163 $html .= ' SELECTED';
1164 $sel_groups{$group} = 0;
1166 $html .= ">$group</OPTION>\n";
1168 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1169 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1171 $html .= '</SELECT>';
1173 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1174 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1183 The $recref stuff in sub check should be cleaned up.
1185 The suspend, unsuspend and cancel methods update the database, but not the
1186 current object. This is probably a bug as it's unexpected and
1189 radius_usergroup_selector? putting web ui components in here? they should
1190 probably live somewhere else...
1194 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1195 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1196 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1197 L<freeside-queued>), L<FS::svc_acct_pop>,
1198 schema.html from the base documentation.