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
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
18 use FS::UID qw( datasrc );
20 use FS::Record qw( qsearch qsearchs fields dbh );
27 use FS::cust_main_invoice;
31 use FS::radius_usergroup;
34 use FS::Msgcat qw(gettext);
36 @ISA = qw( FS::svc_Common );
39 $me = '[FS::svc_acct]';
41 #ask FS::UID to run this stuff for us later
42 $FS::UID::callback{'FS::svc_acct'} = sub {
44 $dir_prefix = $conf->config('home');
45 @shells = $conf->config('shells');
46 $usernamemin = $conf->config('usernamemin') || 2;
47 $usernamemax = $conf->config('usernamemax');
48 $passwordmin = $conf->config('passwordmin') || 6;
49 $passwordmax = $conf->config('passwordmax') || 8;
50 $username_letter = $conf->exists('username-letter');
51 $username_letterfirst = $conf->exists('username-letterfirst');
52 $username_noperiod = $conf->exists('username-noperiod');
53 $username_nounderscore = $conf->exists('username-nounderscore');
54 $username_nodash = $conf->exists('username-nodash');
55 $username_uppercase = $conf->exists('username-uppercase');
56 $username_ampersand = $conf->exists('username-ampersand');
57 $mydomain = $conf->config('domain');
58 $dirhash = $conf->config('dirhash') || 0;
59 if ( $conf->exists('welcome_email') ) {
60 $welcome_template = new Text::Template (
62 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
63 ) or warn "can't create welcome email template: $Text::Template::ERROR";
64 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
65 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
66 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
68 $welcome_template = '';
70 $welcome_subject = '';
71 $welcome_mimetype = '';
73 $smtpmachine = $conf->config('smtpmachine');
74 $radius_password = $conf->config('radius-password') || 'Password';
77 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
78 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
82 my ( $hashref, $cache ) = @_;
83 if ( $hashref->{'svc_acct_svcnum'} ) {
84 $self->{'_domsvc'} = FS::svc_domain->new( {
85 'svcnum' => $hashref->{'domsvc'},
86 'domain' => $hashref->{'svc_acct_domain'},
87 'catchall' => $hashref->{'svc_acct_catchall'},
94 FS::svc_acct - Object methods for svc_acct records
100 $record = new FS::svc_acct \%hash;
101 $record = new FS::svc_acct { 'column' => 'value' };
103 $error = $record->insert;
105 $error = $new_record->replace($old_record);
107 $error = $record->delete;
109 $error = $record->check;
111 $error = $record->suspend;
113 $error = $record->unsuspend;
115 $error = $record->cancel;
117 %hash = $record->radius;
119 %hash = $record->radius_reply;
121 %hash = $record->radius_check;
123 $domain = $record->domain;
125 $svc_domain = $record->svc_domain;
127 $email = $record->email;
129 $seconds_since = $record->seconds_since($timestamp);
133 An FS::svc_acct object represents an account. FS::svc_acct inherits from
134 FS::svc_Common. The following fields are currently supported:
138 =item svcnum - primary key (assigned automatcially for new accounts)
142 =item _password - generated if blank
144 =item sec_phrase - security phrase
146 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
154 =item dir - set automatically if blank (and uid is not)
158 =item quota - (unimplementd)
160 =item slipip - IP address
164 =item domsvc - svcnum from svc_domain
166 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
176 Creates a new account. To add the account to the database, see L<"insert">.
180 sub table { 'svc_acct'; }
184 Adds this account to the database. If there is an error, returns the error,
185 otherwise returns false.
187 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
188 defined. An FS::cust_svc record will be created and inserted.
190 The additional field I<usergroup> can optionally be defined; if so it should
191 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
192 sqlradius export only)
194 (TODOC: L<FS::queue> and L<freeside-queued>)
196 (TODOC: new exports!)
204 local $SIG{HUP} = 'IGNORE';
205 local $SIG{INT} = 'IGNORE';
206 local $SIG{QUIT} = 'IGNORE';
207 local $SIG{TERM} = 'IGNORE';
208 local $SIG{TSTP} = 'IGNORE';
209 local $SIG{PIPE} = 'IGNORE';
211 my $oldAutoCommit = $FS::UID::AutoCommit;
212 local $FS::UID::AutoCommit = 0;
215 $error = $self->check;
216 return $error if $error;
218 #no, duplicate checking just got a whole lot more complicated
219 #(perhaps keep this check with a config option to turn on?)
221 #return gettext('username_in_use'). ": ". $self->username
222 # if qsearchs( 'svc_acct', { 'username' => $self->username,
223 # 'domsvc' => $self->domsvc,
226 if ( $self->svcnum ) {
227 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
228 unless ( $cust_svc ) {
229 $dbh->rollback if $oldAutoCommit;
230 return "no cust_svc record found for svcnum ". $self->svcnum;
232 $self->pkgnum($cust_svc->pkgnum);
233 $self->svcpart($cust_svc->svcpart);
236 #new duplicate username checking
238 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
239 unless ( $part_svc ) {
240 $dbh->rollback if $oldAutoCommit;
241 return 'unknown svcpart '. $self->svcpart;
244 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
245 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
246 'domsvc' => $self->domsvc } );
248 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
249 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
250 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
255 if ( @dup_user || @dup_userdomain || @dup_uid ) {
256 my $exports = FS::part_export::export_info('svc_acct');
257 my %conflict_user_svcpart;
258 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
260 foreach my $part_export ( $part_svc->part_export ) {
262 #this will catch to the same exact export
263 my @svcparts = map { $_->svcpart }
264 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
266 #this will catch to exports w/same exporthost+type ???
267 #my @other_part_export = qsearch('part_export', {
268 # 'machine' => $part_export->machine,
269 # 'exporttype' => $part_export->exporttype,
271 #foreach my $other_part_export ( @other_part_export ) {
272 # push @svcparts, map { $_->svcpart }
273 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
276 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
277 #silly kludge to avoid uninitialized value errors
278 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
279 ? $exports->{$part_export->exporttype}{'nodomain'}
281 if ( $nodomain =~ /^Y/i ) {
282 $conflict_user_svcpart{$_} = $part_export->exportnum
285 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
290 foreach my $dup_user ( @dup_user ) {
291 my $dup_svcpart = $dup_user->cust_svc->svcpart;
292 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
293 $dbh->rollback if $oldAutoCommit;
294 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
295 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
299 foreach my $dup_userdomain ( @dup_userdomain ) {
300 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
301 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
302 $dbh->rollback if $oldAutoCommit;
303 return "duplicate username\@domain: conflicts with svcnum ".
304 $dup_userdomain->svcnum. " via exportnum ".
305 $conflict_userdomain_svcpart{$dup_svcpart};
309 foreach my $dup_uid ( @dup_uid ) {
310 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
311 if ( exists($conflict_user_svcpart{$dup_svcpart})
312 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
313 $dbh->rollback if $oldAutoCommit;
314 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
315 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
316 || $conflict_userdomain_svcpart{$dup_svcpart};
322 #see? i told you it was more complicated
325 $error = $self->SUPER::insert(\@jobnums);
327 $dbh->rollback if $oldAutoCommit;
331 if ( $self->usergroup ) {
332 foreach my $groupname ( @{$self->usergroup} ) {
333 my $radius_usergroup = new FS::radius_usergroup ( {
334 svcnum => $self->svcnum,
335 groupname => $groupname,
337 my $error = $radius_usergroup->insert;
339 $dbh->rollback if $oldAutoCommit;
345 #false laziness with sub replace (and cust_main)
346 my $queue = new FS::queue {
347 'svcnum' => $self->svcnum,
348 'job' => 'FS::svc_acct::append_fuzzyfiles'
350 $error = $queue->insert($self->username);
352 $dbh->rollback if $oldAutoCommit;
353 return "queueing job (transaction rolled back): $error";
356 my $cust_pkg = $self->cust_svc->cust_pkg;
359 my $cust_main = $cust_pkg->cust_main;
361 if ( $conf->exists('emailinvoiceauto') ) {
362 my @invoicing_list = $cust_main->invoicing_list;
363 push @invoicing_list, $self->email;
364 $cust_main->invoicing_list(\@invoicing_list);
369 if ( $welcome_template && $cust_pkg ) {
370 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
372 my $wqueue = new FS::queue {
373 'svcnum' => $self->svcnum,
374 'job' => 'FS::svc_acct::send_email'
376 my $error = $wqueue->insert(
378 'from' => $welcome_from,
379 'subject' => $welcome_subject,
380 'mimetype' => $welcome_mimetype,
381 'body' => $welcome_template->fill_in( HASH => {
382 'custnum' => $self->custnum,
383 'username' => $self->username,
384 'password' => $self->_password,
385 'first' => $cust_main->first,
386 'last' => $cust_main->getfield('last'),
387 'pkg' => $cust_pkg->part_pkg->pkg,
391 $dbh->rollback if $oldAutoCommit;
392 return "error queuing welcome email: $error";
395 foreach my $jobnum ( @jobnums ) {
396 my $error = $wqueue->depend_insert($jobnum);
398 $dbh->rollback if $oldAutoCommit;
399 return "error queuing welcome email job dependancy: $error";
409 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
415 Deletes this account from the database. If there is an error, returns the
416 error, otherwise returns false.
418 The corresponding FS::cust_svc record will be deleted as well.
420 (TODOC: new exports!)
427 if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
428 return "Can't delete an account which has (svc_acct_sm) mail aliases!"
429 if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
432 return "Can't delete an account which is a (svc_forward) source!"
433 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
435 return "Can't delete an account which is a (svc_forward) destination!"
436 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
438 return "Can't delete an account with (svc_www) web service!"
439 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
441 # what about records in session ? (they should refer to history table)
443 local $SIG{HUP} = 'IGNORE';
444 local $SIG{INT} = 'IGNORE';
445 local $SIG{QUIT} = 'IGNORE';
446 local $SIG{TERM} = 'IGNORE';
447 local $SIG{TSTP} = 'IGNORE';
448 local $SIG{PIPE} = 'IGNORE';
450 my $oldAutoCommit = $FS::UID::AutoCommit;
451 local $FS::UID::AutoCommit = 0;
454 foreach my $cust_main_invoice (
455 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
457 unless ( defined($cust_main_invoice) ) {
458 warn "WARNING: something's wrong with qsearch";
461 my %hash = $cust_main_invoice->hash;
462 $hash{'dest'} = $self->email;
463 my $new = new FS::cust_main_invoice \%hash;
464 my $error = $new->replace($cust_main_invoice);
466 $dbh->rollback if $oldAutoCommit;
471 foreach my $svc_domain (
472 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
474 my %hash = new FS::svc_domain->hash;
475 $hash{'catchall'} = '';
476 my $new = new FS::svc_domain \%hash;
477 my $error = $new->replace($svc_domain);
479 $dbh->rollback if $oldAutoCommit;
484 foreach my $radius_usergroup (
485 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
487 my $error = $radius_usergroup->delete;
489 $dbh->rollback if $oldAutoCommit;
494 my $error = $self->SUPER::delete;
496 $dbh->rollback if $oldAutoCommit;
500 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
504 =item replace OLD_RECORD
506 Replaces OLD_RECORD with this one in the database. If there is an error,
507 returns the error, otherwise returns false.
509 The additional field I<usergroup> can optionally be defined; if so it should
510 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
511 sqlradius export only)
516 my ( $new, $old ) = ( shift, shift );
518 warn "$me replacing $old with $new\n" if $DEBUG;
520 return "Username in use"
521 if $old->username ne $new->username &&
522 qsearchs( 'svc_acct', { 'username' => $new->username,
523 'domsvc' => $new->domsvc,
526 #no warnings 'numeric'; #alas, a 5.006-ism
528 return "Can't change uid!" if $old->uid != $new->uid;
531 #change homdir when we change username
532 $new->setfield('dir', '') if $old->username ne $new->username;
534 local $SIG{HUP} = 'IGNORE';
535 local $SIG{INT} = 'IGNORE';
536 local $SIG{QUIT} = 'IGNORE';
537 local $SIG{TERM} = 'IGNORE';
538 local $SIG{TSTP} = 'IGNORE';
539 local $SIG{PIPE} = 'IGNORE';
541 my $oldAutoCommit = $FS::UID::AutoCommit;
542 local $FS::UID::AutoCommit = 0;
545 # redundant, but so $new->usergroup gets set
546 $error = $new->check;
547 return $error if $error;
549 $old->usergroup( [ $old->radius_groups ] );
550 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
551 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
552 if ( $new->usergroup ) {
553 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
554 my @newgroups = @{$new->usergroup};
555 foreach my $oldgroup ( @{$old->usergroup} ) {
556 if ( grep { $oldgroup eq $_ } @newgroups ) {
557 @newgroups = grep { $oldgroup ne $_ } @newgroups;
560 my $radius_usergroup = qsearchs('radius_usergroup', {
561 svcnum => $old->svcnum,
562 groupname => $oldgroup,
564 my $error = $radius_usergroup->delete;
566 $dbh->rollback if $oldAutoCommit;
567 return "error deleting radius_usergroup $oldgroup: $error";
571 foreach my $newgroup ( @newgroups ) {
572 my $radius_usergroup = new FS::radius_usergroup ( {
573 svcnum => $new->svcnum,
574 groupname => $newgroup,
576 my $error = $radius_usergroup->insert;
578 $dbh->rollback if $oldAutoCommit;
579 return "error adding radius_usergroup $newgroup: $error";
585 $error = $new->SUPER::replace($old);
587 $dbh->rollback if $oldAutoCommit;
588 return $error if $error;
591 if ( $new->username ne $old->username ) {
592 #false laziness with sub insert (and cust_main)
593 my $queue = new FS::queue {
594 'svcnum' => $new->svcnum,
595 'job' => 'FS::svc_acct::append_fuzzyfiles'
597 $error = $queue->insert($new->username);
599 $dbh->rollback if $oldAutoCommit;
600 return "queueing job (transaction rolled back): $error";
604 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
610 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
611 error, returns the error, otherwise returns false.
613 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
619 my %hash = $self->hash;
620 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
621 || $hash{_password} eq '*'
623 $hash{_password} = '*SUSPENDED* '.$hash{_password};
624 my $new = new FS::svc_acct ( \%hash );
625 my $error = $new->replace($self);
626 return $error if $error;
629 $self->SUPER::suspend;
634 Unsuspends this account by removing *SUSPENDED* from the password. If there is
635 an error, returns the error, otherwise returns false.
637 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
643 my %hash = $self->hash;
644 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
645 $hash{_password} = $1;
646 my $new = new FS::svc_acct ( \%hash );
647 my $error = $new->replace($self);
648 return $error if $error;
651 $self->SUPER::unsuspend;
656 Just returns false (no error) for now.
658 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
662 Checks all fields to make sure this is a valid service. If there is an error,
663 returns the error, otherwise returns false. Called by the insert and replace
666 Sets any fixed values; see L<FS::part_svc>.
673 my($recref) = $self->hashref;
675 my $x = $self->setfixed;
676 return $x unless ref($x);
679 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
681 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
684 my $error = $self->ut_numbern('svcnum')
685 #|| $self->ut_number('domsvc')
686 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
687 || $self->ut_textn('sec_phrase')
689 return $error if $error;
691 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
692 if ( $username_uppercase ) {
693 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
694 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
695 $recref->{username} = $1;
697 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
698 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
699 $recref->{username} = $1;
702 if ( $username_letterfirst ) {
703 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
704 } elsif ( $username_letter ) {
705 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
707 if ( $username_noperiod ) {
708 $recref->{username} =~ /\./ and return gettext('illegal_username');
710 if ( $username_nounderscore ) {
711 $recref->{username} =~ /_/ and return gettext('illegal_username');
713 if ( $username_nodash ) {
714 $recref->{username} =~ /\-/ and return gettext('illegal_username');
716 unless ( $username_ampersand ) {
717 $recref->{username} =~ /\&/ and return gettext('illegal_username');
720 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
721 $recref->{popnum} = $1;
722 return "Unknown popnum" unless
723 ! $recref->{popnum} ||
724 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
726 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
728 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
729 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
731 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
732 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
733 #not all systems use gid=uid
734 #you can set a fixed gid in part_svc
736 return "Only root can have uid 0"
737 if $recref->{uid} == 0
738 && $recref->{username} ne 'root'
739 && $recref->{username} ne 'toor';
742 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
743 or return "Illegal directory: ". $recref->{dir};
745 return "Illegal directory"
746 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
747 return "Illegal directory"
748 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
749 unless ( $recref->{dir} ) {
750 $recref->{dir} = $dir_prefix . '/';
751 if ( $dirhash > 0 ) {
752 for my $h ( 1 .. $dirhash ) {
753 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
755 } elsif ( $dirhash < 0 ) {
756 for my $h ( reverse $dirhash .. -1 ) {
757 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
760 $recref->{dir} .= $recref->{username};
764 unless ( $recref->{username} eq 'sync' ) {
765 if ( grep $_ eq $recref->{shell}, @shells ) {
766 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
768 return "Illegal shell \`". $self->shell. "\'; ".
769 $conf->dir. "/shells contains: @shells";
772 $recref->{shell} = '/bin/sync';
776 $recref->{gid} ne '' ?
777 return "Can't have gid without uid" : ( $recref->{gid}='' );
778 $recref->{dir} ne '' ?
779 return "Can't have directory without uid" : ( $recref->{dir}='' );
780 $recref->{shell} ne '' ?
781 return "Can't have shell without uid" : ( $recref->{shell}='' );
784 # $error = $self->ut_textn('finger');
785 # return $error if $error;
786 $self->getfield('finger') =~
787 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
788 or return "Illegal finger: ". $self->getfield('finger');
789 $self->setfield('finger', $1);
791 $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
792 $recref->{quota} = $1;
794 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
795 unless ( $recref->{slipip} eq '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;
800 $recref->{slipip} = '0e0';
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,34})$/ ) {
825 $recref->{_password} = $1.$3;
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{'Framed-IP-Address'} = $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 => $self->_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 if ( $self->domsvc ) {
911 #$self->svc_domain->domain;
912 my $svc_domain = $self->svc_domain
913 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
916 $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
922 Returns the FS::svc_domain record for this account's domain (see
931 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
936 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(@_);
1015 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1021 if ( $self->usergroup ) {
1022 #when provisioning records, export callback runs in svc_Common.pm before
1023 #radius_usergroup records can be inserted...
1024 @{$self->usergroup};
1026 map { $_->groupname }
1027 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1045 use Mail::Internet 1.44;
1048 $opt{mimetype} ||= 'text/plain';
1049 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1051 $ENV{MAILADDRESS} = $opt{from};
1052 my $header = new Mail::Header ( [
1055 "Sender: $opt{from}",
1056 "Reply-To: $opt{from}",
1057 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1058 "Subject: $opt{subject}",
1059 "Content-Type: $opt{mimetype}",
1061 my $message = new Mail::Internet (
1062 'Header' => $header,
1063 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1066 $message->smtpsend( Host => $smtpmachine )
1067 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1068 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1071 =item check_and_rebuild_fuzzyfiles
1075 sub check_and_rebuild_fuzzyfiles {
1076 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1077 -e "$dir/svc_acct.username"
1078 or &rebuild_fuzzyfiles;
1081 =item rebuild_fuzzyfiles
1085 sub rebuild_fuzzyfiles {
1087 use Fcntl qw(:flock);
1089 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1093 open(USERNAMELOCK,">>$dir/svc_acct.username")
1094 or die "can't open $dir/svc_acct.username: $!";
1095 flock(USERNAMELOCK,LOCK_EX)
1096 or die "can't lock $dir/svc_acct.username: $!";
1098 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1100 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1101 or die "can't open $dir/svc_acct.username.tmp: $!";
1102 print USERNAMECACHE join("\n", @all_username), "\n";
1103 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1105 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1115 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1116 open(USERNAMECACHE,"<$dir/svc_acct.username")
1117 or die "can't open $dir/svc_acct.username: $!";
1118 my @array = map { chomp; $_; } <USERNAMECACHE>;
1119 close USERNAMECACHE;
1123 =item append_fuzzyfiles USERNAME
1127 sub append_fuzzyfiles {
1128 my $username = shift;
1130 &check_and_rebuild_fuzzyfiles;
1132 use Fcntl qw(:flock);
1134 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1136 open(USERNAME,">>$dir/svc_acct.username")
1137 or die "can't open $dir/svc_acct.username: $!";
1138 flock(USERNAME,LOCK_EX)
1139 or die "can't lock $dir/svc_acct.username: $!";
1141 print USERNAME "$username\n";
1143 flock(USERNAME,LOCK_UN)
1144 or die "can't unlock $dir/svc_acct.username: $!";
1152 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1156 sub radius_usergroup_selector {
1157 my $sel_groups = shift;
1158 my %sel_groups = map { $_=>1 } @$sel_groups;
1160 my $selectname = shift || 'radius_usergroup';
1163 my $sth = $dbh->prepare(
1164 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1165 ) or die $dbh->errstr;
1166 $sth->execute() or die $sth->errstr;
1167 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1171 function ${selectname}_doadd(object) {
1172 var myvalue = object.${selectname}_add.value;
1173 var optionName = new Option(myvalue,myvalue,false,true);
1174 var length = object.$selectname.length;
1175 object.$selectname.options[length] = optionName;
1176 object.${selectname}_add.value = "";
1179 <SELECT MULTIPLE NAME="$selectname">
1182 foreach my $group ( @all_groups ) {
1184 if ( $sel_groups{$group} ) {
1185 $html .= ' SELECTED';
1186 $sel_groups{$group} = 0;
1188 $html .= ">$group</OPTION>\n";
1190 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1191 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1193 $html .= '</SELECT>';
1195 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1196 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1205 The $recref stuff in sub check should be cleaned up.
1207 The suspend, unsuspend and cancel methods update the database, but not the
1208 current object. This is probably a bug as it's unexpected and
1211 radius_usergroup_selector? putting web ui components in here? they should
1212 probably live somewhere else...
1216 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1217 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1218 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1219 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1220 schema.html from the base documentation.