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 dbdef );
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 && qsearchs('cust_svc',{'svcnum'=>$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 system account" if $self->_check_system;
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 "can't modify system account" if $old->_check_system;
522 return "Username in use"
523 if $old->username ne $new->username &&
524 qsearchs( 'svc_acct', { 'username' => $new->username,
525 'domsvc' => $new->domsvc,
528 #no warnings 'numeric'; #alas, a 5.006-ism
530 return "Can't change uid!" if $old->uid != $new->uid;
533 #change homdir when we change username
534 $new->setfield('dir', '') if $old->username ne $new->username;
536 local $SIG{HUP} = 'IGNORE';
537 local $SIG{INT} = 'IGNORE';
538 local $SIG{QUIT} = 'IGNORE';
539 local $SIG{TERM} = 'IGNORE';
540 local $SIG{TSTP} = 'IGNORE';
541 local $SIG{PIPE} = 'IGNORE';
543 my $oldAutoCommit = $FS::UID::AutoCommit;
544 local $FS::UID::AutoCommit = 0;
547 # redundant, but so $new->usergroup gets set
548 $error = $new->check;
549 return $error if $error;
551 $old->usergroup( [ $old->radius_groups ] );
552 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
553 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
554 if ( $new->usergroup ) {
555 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
556 my @newgroups = @{$new->usergroup};
557 foreach my $oldgroup ( @{$old->usergroup} ) {
558 if ( grep { $oldgroup eq $_ } @newgroups ) {
559 @newgroups = grep { $oldgroup ne $_ } @newgroups;
562 my $radius_usergroup = qsearchs('radius_usergroup', {
563 svcnum => $old->svcnum,
564 groupname => $oldgroup,
566 my $error = $radius_usergroup->delete;
568 $dbh->rollback if $oldAutoCommit;
569 return "error deleting radius_usergroup $oldgroup: $error";
573 foreach my $newgroup ( @newgroups ) {
574 my $radius_usergroup = new FS::radius_usergroup ( {
575 svcnum => $new->svcnum,
576 groupname => $newgroup,
578 my $error = $radius_usergroup->insert;
580 $dbh->rollback if $oldAutoCommit;
581 return "error adding radius_usergroup $newgroup: $error";
587 $error = $new->SUPER::replace($old);
589 $dbh->rollback if $oldAutoCommit;
590 return $error if $error;
593 if ( $new->username ne $old->username ) {
594 #false laziness with sub insert (and cust_main)
595 my $queue = new FS::queue {
596 'svcnum' => $new->svcnum,
597 'job' => 'FS::svc_acct::append_fuzzyfiles'
599 $error = $queue->insert($new->username);
601 $dbh->rollback if $oldAutoCommit;
602 return "queueing job (transaction rolled back): $error";
606 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
612 Suspends this account by calling export-specific suspend hooks. If there is
613 an error, returns the error, otherwise returns false.
615 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
621 return "can't suspend system account" if $self->_check_system;
622 my %hash = $self->hash;
623 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
624 || $hash{_password} eq '*'
626 $hash{_password} = '*SUSPENDED* '.$hash{_password};
627 my $new = new FS::svc_acct ( \%hash );
628 my $error = $new->replace($self);
629 return $error if $error;
632 $self->SUPER::suspend;
637 Unsuspends this account by by calling export-specific suspend hooks. If there
638 is an error, returns the error, otherwise returns false.
640 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
646 my %hash = $self->hash;
647 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
648 $hash{_password} = $1;
649 my $new = new FS::svc_acct ( \%hash );
650 my $error = $new->replace($self);
651 return $error if $error;
654 $self->SUPER::unsuspend;
659 Just returns false (no error) for now.
661 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
665 Checks all fields to make sure this is a valid service. If there is an error,
666 returns the error, otherwise returns false. Called by the insert and replace
669 Sets any fixed values; see L<FS::part_svc>.
676 my($recref) = $self->hashref;
678 my $x = $self->setfixed;
679 return $x unless ref($x);
682 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
684 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
687 my $error = $self->ut_numbern('svcnum')
688 #|| $self->ut_number('domsvc')
689 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
690 || $self->ut_textn('sec_phrase')
692 return $error if $error;
694 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
695 if ( $username_uppercase ) {
696 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
697 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
698 $recref->{username} = $1;
700 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
701 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
702 $recref->{username} = $1;
705 if ( $username_letterfirst ) {
706 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
707 } elsif ( $username_letter ) {
708 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
710 if ( $username_noperiod ) {
711 $recref->{username} =~ /\./ and return gettext('illegal_username');
713 if ( $username_nounderscore ) {
714 $recref->{username} =~ /_/ and return gettext('illegal_username');
716 if ( $username_nodash ) {
717 $recref->{username} =~ /\-/ and return gettext('illegal_username');
719 unless ( $username_ampersand ) {
720 $recref->{username} =~ /\&/ and return gettext('illegal_username');
723 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
724 $recref->{popnum} = $1;
725 return "Unknown popnum" unless
726 ! $recref->{popnum} ||
727 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
729 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
731 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
732 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
734 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
735 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
736 #not all systems use gid=uid
737 #you can set a fixed gid in part_svc
739 return "Only root can have uid 0"
740 if $recref->{uid} == 0
741 && $recref->{username} ne 'root'
742 && $recref->{username} ne 'toor';
745 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
746 or return "Illegal directory: ". $recref->{dir};
748 return "Illegal directory"
749 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
750 return "Illegal directory"
751 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
752 unless ( $recref->{dir} ) {
753 $recref->{dir} = $dir_prefix . '/';
754 if ( $dirhash > 0 ) {
755 for my $h ( 1 .. $dirhash ) {
756 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
758 } elsif ( $dirhash < 0 ) {
759 for my $h ( reverse $dirhash .. -1 ) {
760 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
763 $recref->{dir} .= $recref->{username};
767 unless ( $recref->{username} eq 'sync' ) {
768 if ( grep $_ eq $recref->{shell}, @shells ) {
769 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
771 return "Illegal shell \`". $self->shell. "\'; ".
772 $conf->dir. "/shells contains: @shells";
775 $recref->{shell} = '/bin/sync';
779 $recref->{gid} ne '' ?
780 return "Can't have gid without uid" : ( $recref->{gid}='' );
781 $recref->{dir} ne '' ?
782 return "Can't have directory without uid" : ( $recref->{dir}='' );
783 $recref->{shell} ne '' ?
784 return "Can't have shell without uid" : ( $recref->{shell}='' );
787 # $error = $self->ut_textn('finger');
788 # return $error if $error;
789 $self->getfield('finger') =~
790 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
791 or return "Illegal finger: ". $self->getfield('finger');
792 $self->setfield('finger', $1);
794 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
795 $recref->{quota} = $1;
797 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
798 if ( $recref->{slipip} eq '' ) {
799 $recref->{slipip} = '';
800 } elsif ( $recref->{slipip} eq '0e0' ) {
801 $recref->{slipip} = '0e0';
803 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
804 or return "Illegal slipip: ". $self->slipip;
805 $recref->{slipip} = $1;
810 #arbitrary RADIUS stuff; allow ut_textn for now
811 foreach ( grep /^radius_/, fields('svc_acct') ) {
815 #generate a password if it is blank
816 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
817 unless ( $recref->{_password} );
819 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
820 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
821 $recref->{_password} = $1.$3;
822 #uncomment this to encrypt password immediately upon entry, or run
823 #bin/crypt_pw in cron to give new users a window during which their
824 #password is available to techs, for faxing, etc. (also be aware of
826 #$recref->{password} = $1.
827 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
829 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
830 $recref->{_password} = $1.$3;
831 } elsif ( $recref->{_password} eq '*' ) {
832 $recref->{_password} = '*';
833 } elsif ( $recref->{_password} eq '!' ) {
834 $recref->{_password} = '!';
835 } elsif ( $recref->{_password} eq '!!' ) {
836 $recref->{_password} = '!!';
838 #return "Illegal password";
839 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
840 FS::Msgcat::_gettext('illegal_password_characters').
841 ": ". $recref->{_password};
853 scalar( grep { $self->username eq $_ || $self->email eq $_ }
854 $conf->config('system_usernames')
860 Depriciated, use radius_reply instead.
865 carp "FS::svc_acct::radius depriciated, use radius_reply";
871 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
872 reply attributes of this record.
874 Note that this is now the preferred method for reading RADIUS attributes -
875 accessing the columns directly is discouraged, as the column names are
876 expected to change in the future.
885 my($column, $attrib) = ($1, $2);
886 #$attrib =~ s/_/\-/g;
887 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
888 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
889 if ( $self->slipip && $self->slipip ne '0e0' ) {
890 $reply{$radius_ip} = $self->slipip;
897 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
898 check attributes of this record.
900 Note that this is now the preferred method for reading RADIUS attributes -
901 accessing the columns directly is discouraged, as the column names are
902 expected to change in the future.
908 my $password = $self->_password;
909 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
910 ( $pw_attrib => $password,
913 my($column, $attrib) = ($1, $2);
914 #$attrib =~ s/_/\-/g;
915 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
916 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
922 Returns the domain associated with this account.
928 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
929 my $svc_domain = $self->svc_domain
930 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
936 Returns the FS::svc_domain record for this account's domain (see
945 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
950 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
956 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
961 Returns an email address associated with the account.
967 $self->username. '@'. $self->domain;
972 Returns an array of FS::acct_snarf records associated with the account.
973 If the acct_snarf table does not exist or there are no associated records,
974 an empty list is returned
980 return () unless dbdef->table('acct_snarf');
981 eval "use FS::acct_snarf;";
983 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
986 =item seconds_since TIMESTAMP
988 Returns the number of seconds this account has been online since TIMESTAMP,
989 according to the session monitor (see L<FS::Session>).
991 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
992 L<Time::Local> and L<Date::Parse> for conversion functions.
996 #note: POD here, implementation in FS::cust_svc
999 $self->cust_svc->seconds_since(@_);
1002 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1004 Returns the numbers of seconds this account has been online between
1005 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1006 external SQL radacct table, specified via sqlradius export. Sessions which
1007 started in the specified range but are still open are counted from session
1008 start to the end of the range (unless they are over 1 day old, in which case
1009 they are presumed missing their stop record and not counted). Also, sessions
1010 which end in the range but started earlier are counted from the start of the
1011 range to session end. Finally, sessions which start before the range but end
1012 after are counted for the entire range.
1014 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1015 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1020 #note: POD here, implementation in FS::cust_svc
1021 sub seconds_since_sqlradacct {
1023 $self->cust_svc->seconds_since_sqlradacct(@_);
1026 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1028 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1029 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1030 TIMESTAMP_END (exclusive).
1032 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1033 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1038 #note: POD here, implementation in FS::cust_svc
1039 sub attribute_since_sqlradacct {
1041 $self->cust_svc->attribute_since_sqlradacct(@_);
1044 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1046 Returns an array of hash references of this customers login history for the
1047 given time range. (document this better)
1051 sub get_session_history_sqlradacct {
1053 $self->cust_svc->get_session_history_sqlradacct(@_);
1058 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1064 if ( $self->usergroup ) {
1065 #when provisioning records, export callback runs in svc_Common.pm before
1066 #radius_usergroup records can be inserted...
1067 @{$self->usergroup};
1069 map { $_->groupname }
1070 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1082 This is the FS::svc_acct job-queue-able version. It still uses
1083 FS::Misc::send_email under-the-hood.
1090 eval "use FS::Misc qw(send_email)";
1093 $opt{mimetype} ||= 'text/plain';
1094 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1096 my $error = send_email(
1097 'from' => $opt{from},
1099 'subject' => $opt{subject},
1100 'content-type' => $opt{mimetype},
1101 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1103 die $error if $error;
1106 =item check_and_rebuild_fuzzyfiles
1110 sub check_and_rebuild_fuzzyfiles {
1111 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1112 -e "$dir/svc_acct.username"
1113 or &rebuild_fuzzyfiles;
1116 =item rebuild_fuzzyfiles
1120 sub rebuild_fuzzyfiles {
1122 use Fcntl qw(:flock);
1124 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1128 open(USERNAMELOCK,">>$dir/svc_acct.username")
1129 or die "can't open $dir/svc_acct.username: $!";
1130 flock(USERNAMELOCK,LOCK_EX)
1131 or die "can't lock $dir/svc_acct.username: $!";
1133 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1135 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1136 or die "can't open $dir/svc_acct.username.tmp: $!";
1137 print USERNAMECACHE join("\n", @all_username), "\n";
1138 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1140 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1150 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1151 open(USERNAMECACHE,"<$dir/svc_acct.username")
1152 or die "can't open $dir/svc_acct.username: $!";
1153 my @array = map { chomp; $_; } <USERNAMECACHE>;
1154 close USERNAMECACHE;
1158 =item append_fuzzyfiles USERNAME
1162 sub append_fuzzyfiles {
1163 my $username = shift;
1165 &check_and_rebuild_fuzzyfiles;
1167 use Fcntl qw(:flock);
1169 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1171 open(USERNAME,">>$dir/svc_acct.username")
1172 or die "can't open $dir/svc_acct.username: $!";
1173 flock(USERNAME,LOCK_EX)
1174 or die "can't lock $dir/svc_acct.username: $!";
1176 print USERNAME "$username\n";
1178 flock(USERNAME,LOCK_UN)
1179 or die "can't unlock $dir/svc_acct.username: $!";
1187 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1191 sub radius_usergroup_selector {
1192 my $sel_groups = shift;
1193 my %sel_groups = map { $_=>1 } @$sel_groups;
1195 my $selectname = shift || 'radius_usergroup';
1198 my $sth = $dbh->prepare(
1199 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1200 ) or die $dbh->errstr;
1201 $sth->execute() or die $sth->errstr;
1202 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1206 function ${selectname}_doadd(object) {
1207 var myvalue = object.${selectname}_add.value;
1208 var optionName = new Option(myvalue,myvalue,false,true);
1209 var length = object.$selectname.length;
1210 object.$selectname.options[length] = optionName;
1211 object.${selectname}_add.value = "";
1214 <SELECT MULTIPLE NAME="$selectname">
1217 foreach my $group ( @all_groups ) {
1219 if ( $sel_groups{$group} ) {
1220 $html .= ' SELECTED';
1221 $sel_groups{$group} = 0;
1223 $html .= ">$group</OPTION>\n";
1225 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1226 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1228 $html .= '</SELECT>';
1230 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1231 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1240 The $recref stuff in sub check should be cleaned up.
1242 The suspend, unsuspend and cancel methods update the database, but not the
1243 current object. This is probably a bug as it's unexpected and
1246 radius_usergroup_selector? putting web ui components in here? they should
1247 probably live somewhere else...
1251 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1252 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1253 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1254 L<freeside-queued>), L<FS::svc_acct_pop>,
1255 schema.html from the base documentation.