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 );
37 $me = '[FS::svc_acct]';
39 #ask FS::UID to run this stuff for us later
40 $FS::UID::callback{'FS::svc_acct'} = sub {
42 $dir_prefix = $conf->config('home');
43 @shells = $conf->config('shells');
44 $usernamemin = $conf->config('usernamemin') || 2;
45 $usernamemax = $conf->config('usernamemax');
46 $passwordmin = $conf->config('passwordmin') || 6;
47 $passwordmax = $conf->config('passwordmax') || 8;
48 $username_letter = $conf->exists('username-letter');
49 $username_letterfirst = $conf->exists('username-letterfirst');
50 $username_noperiod = $conf->exists('username-noperiod');
51 $username_nounderscore = $conf->exists('username-nounderscore');
52 $username_nodash = $conf->exists('username-nodash');
53 $username_uppercase = $conf->exists('username-uppercase');
54 $username_ampersand = $conf->exists('username-ampersand');
55 $dirhash = $conf->config('dirhash') || 0;
56 if ( $conf->exists('welcome_email') ) {
57 $welcome_template = new Text::Template (
59 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
60 ) or warn "can't create welcome email template: $Text::Template::ERROR";
61 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
62 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
63 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
65 $welcome_template = '';
67 $welcome_subject = '';
68 $welcome_mimetype = '';
70 $smtpmachine = $conf->config('smtpmachine');
71 $radius_password = $conf->config('radius-password') || 'Password';
72 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
75 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
76 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
80 my ( $hashref, $cache ) = @_;
81 if ( $hashref->{'svc_acct_svcnum'} ) {
82 $self->{'_domsvc'} = FS::svc_domain->new( {
83 'svcnum' => $hashref->{'domsvc'},
84 'domain' => $hashref->{'svc_acct_domain'},
85 'catchall' => $hashref->{'svc_acct_catchall'},
92 FS::svc_acct - Object methods for svc_acct records
98 $record = new FS::svc_acct \%hash;
99 $record = new FS::svc_acct { 'column' => 'value' };
101 $error = $record->insert;
103 $error = $new_record->replace($old_record);
105 $error = $record->delete;
107 $error = $record->check;
109 $error = $record->suspend;
111 $error = $record->unsuspend;
113 $error = $record->cancel;
115 %hash = $record->radius;
117 %hash = $record->radius_reply;
119 %hash = $record->radius_check;
121 $domain = $record->domain;
123 $svc_domain = $record->svc_domain;
125 $email = $record->email;
127 $seconds_since = $record->seconds_since($timestamp);
131 An FS::svc_acct object represents an account. FS::svc_acct inherits from
132 FS::svc_Common. The following fields are currently supported:
136 =item svcnum - primary key (assigned automatcially for new accounts)
140 =item _password - generated if blank
142 =item sec_phrase - security phrase
144 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
152 =item dir - set automatically if blank (and uid is not)
156 =item quota - (unimplementd)
158 =item slipip - IP address
162 =item domsvc - svcnum from svc_domain
164 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
174 Creates a new account. To add the account to the database, see L<"insert">.
178 sub table { 'svc_acct'; }
180 =item insert [ , OPTION => VALUE ... ]
182 Adds this account to the database. If there is an error, returns the error,
183 otherwise returns false.
185 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
186 defined. An FS::cust_svc record will be created and inserted.
188 The additional field I<usergroup> can optionally be defined; if so it should
189 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
190 sqlradius export only)
192 The additional field I<child_objects> can optionally be defined; if so it
193 should contain an arrayref of FS::tablename objects. They will have their
194 svcnum fields set and will be inserted after this record, but before any
197 Currently available options are: I<depend_jobnum>
199 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
200 jobnums), all provisioning jobs will have a dependancy on the supplied
201 jobnum(s) (they will not run until the specific job(s) complete(s)).
203 (TODOC: L<FS::queue> and L<freeside-queued>)
205 (TODOC: new exports!)
214 local $SIG{HUP} = 'IGNORE';
215 local $SIG{INT} = 'IGNORE';
216 local $SIG{QUIT} = 'IGNORE';
217 local $SIG{TERM} = 'IGNORE';
218 local $SIG{TSTP} = 'IGNORE';
219 local $SIG{PIPE} = 'IGNORE';
221 my $oldAutoCommit = $FS::UID::AutoCommit;
222 local $FS::UID::AutoCommit = 0;
225 $error = $self->check;
226 return $error if $error;
228 #no, duplicate checking just got a whole lot more complicated
229 #(perhaps keep this check with a config option to turn on?)
231 #return gettext('username_in_use'). ": ". $self->username
232 # if qsearchs( 'svc_acct', { 'username' => $self->username,
233 # 'domsvc' => $self->domsvc,
236 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
237 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
238 unless ( $cust_svc ) {
239 $dbh->rollback if $oldAutoCommit;
240 return "no cust_svc record found for svcnum ". $self->svcnum;
242 $self->pkgnum($cust_svc->pkgnum);
243 $self->svcpart($cust_svc->svcpart);
246 #new duplicate username checking
248 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
249 unless ( $part_svc ) {
250 $dbh->rollback if $oldAutoCommit;
251 return 'unknown svcpart '. $self->svcpart;
254 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
255 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
256 'domsvc' => $self->domsvc } );
258 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
259 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
260 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
265 if ( @dup_user || @dup_userdomain || @dup_uid ) {
266 my $exports = FS::part_export::export_info('svc_acct');
267 my %conflict_user_svcpart;
268 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
270 foreach my $part_export ( $part_svc->part_export ) {
272 #this will catch to the same exact export
273 my @svcparts = map { $_->svcpart }
274 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
276 #this will catch to exports w/same exporthost+type ???
277 #my @other_part_export = qsearch('part_export', {
278 # 'machine' => $part_export->machine,
279 # 'exporttype' => $part_export->exporttype,
281 #foreach my $other_part_export ( @other_part_export ) {
282 # push @svcparts, map { $_->svcpart }
283 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
286 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
287 #silly kludge to avoid uninitialized value errors
288 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
289 ? $exports->{$part_export->exporttype}{'nodomain'}
291 if ( $nodomain =~ /^Y/i ) {
292 $conflict_user_svcpart{$_} = $part_export->exportnum
295 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
300 foreach my $dup_user ( @dup_user ) {
301 my $dup_svcpart = $dup_user->cust_svc->svcpart;
302 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
303 $dbh->rollback if $oldAutoCommit;
304 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
305 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
309 foreach my $dup_userdomain ( @dup_userdomain ) {
310 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
311 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
312 $dbh->rollback if $oldAutoCommit;
313 return "duplicate username\@domain: conflicts with svcnum ".
314 $dup_userdomain->svcnum. " via exportnum ".
315 $conflict_userdomain_svcpart{$dup_svcpart};
319 foreach my $dup_uid ( @dup_uid ) {
320 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
321 if ( exists($conflict_user_svcpart{$dup_svcpart})
322 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
323 $dbh->rollback if $oldAutoCommit;
324 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
325 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
326 || $conflict_userdomain_svcpart{$dup_svcpart};
332 #see? i told you it was more complicated
335 $error = $self->SUPER::insert(
336 'jobnums' => \@jobnums,
337 'child_objects' => $self->child_objects,
341 $dbh->rollback if $oldAutoCommit;
345 if ( $self->usergroup ) {
346 foreach my $groupname ( @{$self->usergroup} ) {
347 my $radius_usergroup = new FS::radius_usergroup ( {
348 svcnum => $self->svcnum,
349 groupname => $groupname,
351 my $error = $radius_usergroup->insert;
353 $dbh->rollback if $oldAutoCommit;
359 #false laziness with sub replace (and cust_main)
360 my $queue = new FS::queue {
361 'svcnum' => $self->svcnum,
362 'job' => 'FS::svc_acct::append_fuzzyfiles'
364 $error = $queue->insert($self->username);
366 $dbh->rollback if $oldAutoCommit;
367 return "queueing job (transaction rolled back): $error";
370 my $cust_pkg = $self->cust_svc->cust_pkg;
373 my $cust_main = $cust_pkg->cust_main;
375 if ( $conf->exists('emailinvoiceauto') ) {
376 my @invoicing_list = $cust_main->invoicing_list;
377 push @invoicing_list, $self->email;
378 $cust_main->invoicing_list(\@invoicing_list);
383 if ( $welcome_template && $cust_pkg ) {
384 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
386 my $wqueue = new FS::queue {
387 'svcnum' => $self->svcnum,
388 'job' => 'FS::svc_acct::send_email'
390 my $error = $wqueue->insert(
392 'from' => $welcome_from,
393 'subject' => $welcome_subject,
394 'mimetype' => $welcome_mimetype,
395 'body' => $welcome_template->fill_in( HASH => {
396 'custnum' => $self->custnum,
397 'username' => $self->username,
398 'password' => $self->_password,
399 'first' => $cust_main->first,
400 'last' => $cust_main->getfield('last'),
401 'pkg' => $cust_pkg->part_pkg->pkg,
405 $dbh->rollback if $oldAutoCommit;
406 return "error queuing welcome email: $error";
409 if ( $options{'depend_jobnum'} ) {
410 warn "$me depend_jobnum found; adding to welcome email dependancies"
412 if ( ref($options{'depend_jobnum'}) ) {
413 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
414 "to welcome email dependancies"
416 push @jobnums, @{ $options{'depend_jobnum'} };
418 warn "$me adding job $options{'depend_jobnum'} ".
419 "to welcome email dependancies"
421 push @jobnums, $options{'depend_jobnum'};
425 foreach my $jobnum ( @jobnums ) {
426 my $error = $wqueue->depend_insert($jobnum);
428 $dbh->rollback if $oldAutoCommit;
429 return "error queuing welcome email job dependancy: $error";
439 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
445 Deletes this account from the database. If there is an error, returns the
446 error, otherwise returns false.
448 The corresponding FS::cust_svc record will be deleted as well.
450 (TODOC: new exports!)
457 return "can't delete system account" if $self->_check_system;
459 return "Can't delete an account which is a (svc_forward) source!"
460 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
462 return "Can't delete an account which is a (svc_forward) destination!"
463 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
465 return "Can't delete an account with (svc_www) web service!"
466 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
468 # what about records in session ? (they should refer to history table)
470 local $SIG{HUP} = 'IGNORE';
471 local $SIG{INT} = 'IGNORE';
472 local $SIG{QUIT} = 'IGNORE';
473 local $SIG{TERM} = 'IGNORE';
474 local $SIG{TSTP} = 'IGNORE';
475 local $SIG{PIPE} = 'IGNORE';
477 my $oldAutoCommit = $FS::UID::AutoCommit;
478 local $FS::UID::AutoCommit = 0;
481 foreach my $cust_main_invoice (
482 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
484 unless ( defined($cust_main_invoice) ) {
485 warn "WARNING: something's wrong with qsearch";
488 my %hash = $cust_main_invoice->hash;
489 $hash{'dest'} = $self->email;
490 my $new = new FS::cust_main_invoice \%hash;
491 my $error = $new->replace($cust_main_invoice);
493 $dbh->rollback if $oldAutoCommit;
498 foreach my $svc_domain (
499 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
501 my %hash = new FS::svc_domain->hash;
502 $hash{'catchall'} = '';
503 my $new = new FS::svc_domain \%hash;
504 my $error = $new->replace($svc_domain);
506 $dbh->rollback if $oldAutoCommit;
511 foreach my $radius_usergroup (
512 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
514 my $error = $radius_usergroup->delete;
516 $dbh->rollback if $oldAutoCommit;
521 my $error = $self->SUPER::delete;
523 $dbh->rollback if $oldAutoCommit;
527 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
531 =item replace OLD_RECORD
533 Replaces OLD_RECORD with this one in the database. If there is an error,
534 returns the error, otherwise returns false.
536 The additional field I<usergroup> can optionally be defined; if so it should
537 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
538 sqlradius export only)
543 my ( $new, $old ) = ( shift, shift );
545 warn "$me replacing $old with $new\n" if $DEBUG;
547 return "can't modify system account" if $old->_check_system;
549 return "Username in use"
550 if $old->username ne $new->username &&
551 qsearchs( 'svc_acct', { 'username' => $new->username,
552 'domsvc' => $new->domsvc,
555 #no warnings 'numeric'; #alas, a 5.006-ism
557 return "Can't change uid!" if $old->uid != $new->uid;
560 #change homdir when we change username
561 $new->setfield('dir', '') if $old->username ne $new->username;
563 local $SIG{HUP} = 'IGNORE';
564 local $SIG{INT} = 'IGNORE';
565 local $SIG{QUIT} = 'IGNORE';
566 local $SIG{TERM} = 'IGNORE';
567 local $SIG{TSTP} = 'IGNORE';
568 local $SIG{PIPE} = 'IGNORE';
570 my $oldAutoCommit = $FS::UID::AutoCommit;
571 local $FS::UID::AutoCommit = 0;
574 # redundant, but so $new->usergroup gets set
575 $error = $new->check;
576 return $error if $error;
578 $old->usergroup( [ $old->radius_groups ] );
579 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
580 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
581 if ( $new->usergroup ) {
582 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
583 my @newgroups = @{$new->usergroup};
584 foreach my $oldgroup ( @{$old->usergroup} ) {
585 if ( grep { $oldgroup eq $_ } @newgroups ) {
586 @newgroups = grep { $oldgroup ne $_ } @newgroups;
589 my $radius_usergroup = qsearchs('radius_usergroup', {
590 svcnum => $old->svcnum,
591 groupname => $oldgroup,
593 my $error = $radius_usergroup->delete;
595 $dbh->rollback if $oldAutoCommit;
596 return "error deleting radius_usergroup $oldgroup: $error";
600 foreach my $newgroup ( @newgroups ) {
601 my $radius_usergroup = new FS::radius_usergroup ( {
602 svcnum => $new->svcnum,
603 groupname => $newgroup,
605 my $error = $radius_usergroup->insert;
607 $dbh->rollback if $oldAutoCommit;
608 return "error adding radius_usergroup $newgroup: $error";
614 $error = $new->SUPER::replace($old);
616 $dbh->rollback if $oldAutoCommit;
617 return $error if $error;
620 if ( $new->username ne $old->username ) {
621 #false laziness with sub insert (and cust_main)
622 my $queue = new FS::queue {
623 'svcnum' => $new->svcnum,
624 'job' => 'FS::svc_acct::append_fuzzyfiles'
626 $error = $queue->insert($new->username);
628 $dbh->rollback if $oldAutoCommit;
629 return "queueing job (transaction rolled back): $error";
633 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
639 Suspends this account by calling export-specific suspend hooks. If there is
640 an error, returns the error, otherwise returns false.
642 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
648 return "can't suspend system account" if $self->_check_system;
649 $self->SUPER::suspend;
654 Unsuspends this account by by calling export-specific suspend hooks. If there
655 is an error, returns the error, otherwise returns false.
657 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
663 my %hash = $self->hash;
664 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
665 $hash{_password} = $1;
666 my $new = new FS::svc_acct ( \%hash );
667 my $error = $new->replace($self);
668 return $error if $error;
671 $self->SUPER::unsuspend;
676 Just returns false (no error) for now.
678 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
682 Checks all fields to make sure this is a valid service. If there is an error,
683 returns the error, otherwise returns false. Called by the insert and replace
686 Sets any fixed values; see L<FS::part_svc>.
693 my($recref) = $self->hashref;
695 my $x = $self->setfixed;
696 return $x unless ref($x);
699 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
701 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
704 my $error = $self->ut_numbern('svcnum')
705 #|| $self->ut_number('domsvc')
706 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
707 || $self->ut_textn('sec_phrase')
709 return $error if $error;
711 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
712 if ( $username_uppercase ) {
713 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
714 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
715 $recref->{username} = $1;
717 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
718 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
719 $recref->{username} = $1;
722 if ( $username_letterfirst ) {
723 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
724 } elsif ( $username_letter ) {
725 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
727 if ( $username_noperiod ) {
728 $recref->{username} =~ /\./ and return gettext('illegal_username');
730 if ( $username_nounderscore ) {
731 $recref->{username} =~ /_/ and return gettext('illegal_username');
733 if ( $username_nodash ) {
734 $recref->{username} =~ /\-/ and return gettext('illegal_username');
736 unless ( $username_ampersand ) {
737 $recref->{username} =~ /\&/ and return gettext('illegal_username');
740 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
741 $recref->{popnum} = $1;
742 return "Unknown popnum" unless
743 ! $recref->{popnum} ||
744 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
746 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
748 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
749 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
751 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
752 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
753 #not all systems use gid=uid
754 #you can set a fixed gid in part_svc
756 return "Only root can have uid 0"
757 if $recref->{uid} == 0
758 && $recref->{username} ne 'root'
759 && $recref->{username} ne 'toor';
762 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
763 or return "Illegal directory: ". $recref->{dir};
765 return "Illegal directory"
766 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
767 return "Illegal directory"
768 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
769 unless ( $recref->{dir} ) {
770 $recref->{dir} = $dir_prefix . '/';
771 if ( $dirhash > 0 ) {
772 for my $h ( 1 .. $dirhash ) {
773 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
775 } elsif ( $dirhash < 0 ) {
776 for my $h ( reverse $dirhash .. -1 ) {
777 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
780 $recref->{dir} .= $recref->{username};
784 unless ( $recref->{username} eq 'sync' ) {
785 if ( grep $_ eq $recref->{shell}, @shells ) {
786 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
788 return "Illegal shell \`". $self->shell. "\'; ".
789 $conf->dir. "/shells contains: @shells";
792 $recref->{shell} = '/bin/sync';
796 $recref->{gid} ne '' ?
797 return "Can't have gid without uid" : ( $recref->{gid}='' );
798 $recref->{dir} ne '' ?
799 return "Can't have directory without uid" : ( $recref->{dir}='' );
800 $recref->{shell} ne '' ?
801 return "Can't have shell without uid" : ( $recref->{shell}='' );
804 # $error = $self->ut_textn('finger');
805 # return $error if $error;
806 $self->getfield('finger') =~
807 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
808 or return "Illegal finger: ". $self->getfield('finger');
809 $self->setfield('finger', $1);
811 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
812 $recref->{quota} = $1;
814 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
815 if ( $recref->{slipip} eq '' ) {
816 $recref->{slipip} = '';
817 } elsif ( $recref->{slipip} eq '0e0' ) {
818 $recref->{slipip} = '0e0';
820 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
821 or return "Illegal slipip: ". $self->slipip;
822 $recref->{slipip} = $1;
827 #arbitrary RADIUS stuff; allow ut_textn for now
828 foreach ( grep /^radius_/, fields('svc_acct') ) {
832 #generate a password if it is blank
833 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
834 unless ( $recref->{_password} );
836 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
837 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
838 $recref->{_password} = $1.$3;
839 #uncomment this to encrypt password immediately upon entry, or run
840 #bin/crypt_pw in cron to give new users a window during which their
841 #password is available to techs, for faxing, etc. (also be aware of
843 #$recref->{password} = $1.
844 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
846 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
847 $recref->{_password} = $1.$3;
848 } elsif ( $recref->{_password} eq '*' ) {
849 $recref->{_password} = '*';
850 } elsif ( $recref->{_password} eq '!' ) {
851 $recref->{_password} = '!';
852 } elsif ( $recref->{_password} eq '!!' ) {
853 $recref->{_password} = '!!';
855 #return "Illegal password";
856 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
857 FS::Msgcat::_gettext('illegal_password_characters').
858 ": ". $recref->{_password};
870 scalar( grep { $self->username eq $_ || $self->email eq $_ }
871 $conf->config('system_usernames')
877 Depriciated, use radius_reply instead.
882 carp "FS::svc_acct::radius depriciated, use radius_reply";
888 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
889 reply attributes of this record.
891 Note that this is now the preferred method for reading RADIUS attributes -
892 accessing the columns directly is discouraged, as the column names are
893 expected to change in the future.
902 my($column, $attrib) = ($1, $2);
903 #$attrib =~ s/_/\-/g;
904 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
905 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
906 if ( $self->slipip && $self->slipip ne '0e0' ) {
907 $reply{$radius_ip} = $self->slipip;
914 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
915 check attributes of this record.
917 Note that this is now the preferred method for reading RADIUS attributes -
918 accessing the columns directly is discouraged, as the column names are
919 expected to change in the future.
925 my $password = $self->_password;
926 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
927 ( $pw_attrib => $password,
930 my($column, $attrib) = ($1, $2);
931 #$attrib =~ s/_/\-/g;
932 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
933 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
939 Returns the domain associated with this account.
945 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
946 my $svc_domain = $self->svc_domain
947 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
953 Returns the FS::svc_domain record for this account's domain (see
962 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
967 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
973 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
978 Returns an email address associated with the account.
984 $self->username. '@'. $self->domain;
989 Returns an array of FS::acct_snarf records associated with the account.
990 If the acct_snarf table does not exist or there are no associated records,
991 an empty list is returned
997 return () unless dbdef->table('acct_snarf');
998 eval "use FS::acct_snarf;";
1000 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1003 =item seconds_since TIMESTAMP
1005 Returns the number of seconds this account has been online since TIMESTAMP,
1006 according to the session monitor (see L<FS::Session>).
1008 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1009 L<Time::Local> and L<Date::Parse> for conversion functions.
1013 #note: POD here, implementation in FS::cust_svc
1016 $self->cust_svc->seconds_since(@_);
1019 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1021 Returns the numbers of seconds this account has been online between
1022 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1023 external SQL radacct table, specified via sqlradius export. Sessions which
1024 started in the specified range but are still open are counted from session
1025 start to the end of the range (unless they are over 1 day old, in which case
1026 they are presumed missing their stop record and not counted). Also, sessions
1027 which end in the range but started earlier are counted from the start of the
1028 range to session end. Finally, sessions which start before the range but end
1029 after are counted for the entire range.
1031 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1032 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1037 #note: POD here, implementation in FS::cust_svc
1038 sub seconds_since_sqlradacct {
1040 $self->cust_svc->seconds_since_sqlradacct(@_);
1043 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1045 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1046 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1047 TIMESTAMP_END (exclusive).
1049 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1050 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1055 #note: POD here, implementation in FS::cust_svc
1056 sub attribute_since_sqlradacct {
1058 $self->cust_svc->attribute_since_sqlradacct(@_);
1061 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1063 Returns an array of hash references of this customers login history for the
1064 given time range. (document this better)
1068 sub get_session_history_sqlradacct {
1070 $self->cust_svc->get_session_history_sqlradacct(@_);
1075 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1081 if ( $self->usergroup ) {
1082 #when provisioning records, export callback runs in svc_Common.pm before
1083 #radius_usergroup records can be inserted...
1084 @{$self->usergroup};
1086 map { $_->groupname }
1087 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1091 =item clone_suspended
1093 Constructor used by FS::part_export::_export_suspend fallback. Document
1098 sub clone_suspended {
1100 my %hash = $self->hash;
1101 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1102 new FS::svc_acct \%hash;
1105 =item clone_kludge_unsuspend
1107 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1112 sub clone_kludge_unsuspend {
1114 my %hash = $self->hash;
1115 $hash{_password} = '';
1116 new FS::svc_acct \%hash;
1127 This is the FS::svc_acct job-queue-able version. It still uses
1128 FS::Misc::send_email under-the-hood.
1135 eval "use FS::Misc qw(send_email)";
1138 $opt{mimetype} ||= 'text/plain';
1139 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1141 my $error = send_email(
1142 'from' => $opt{from},
1144 'subject' => $opt{subject},
1145 'content-type' => $opt{mimetype},
1146 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1148 die $error if $error;
1151 =item check_and_rebuild_fuzzyfiles
1155 sub check_and_rebuild_fuzzyfiles {
1156 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1157 -e "$dir/svc_acct.username"
1158 or &rebuild_fuzzyfiles;
1161 =item rebuild_fuzzyfiles
1165 sub rebuild_fuzzyfiles {
1167 use Fcntl qw(:flock);
1169 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1173 open(USERNAMELOCK,">>$dir/svc_acct.username")
1174 or die "can't open $dir/svc_acct.username: $!";
1175 flock(USERNAMELOCK,LOCK_EX)
1176 or die "can't lock $dir/svc_acct.username: $!";
1178 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1180 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1181 or die "can't open $dir/svc_acct.username.tmp: $!";
1182 print USERNAMECACHE join("\n", @all_username), "\n";
1183 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1185 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1195 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1196 open(USERNAMECACHE,"<$dir/svc_acct.username")
1197 or die "can't open $dir/svc_acct.username: $!";
1198 my @array = map { chomp; $_; } <USERNAMECACHE>;
1199 close USERNAMECACHE;
1203 =item append_fuzzyfiles USERNAME
1207 sub append_fuzzyfiles {
1208 my $username = shift;
1210 &check_and_rebuild_fuzzyfiles;
1212 use Fcntl qw(:flock);
1214 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1216 open(USERNAME,">>$dir/svc_acct.username")
1217 or die "can't open $dir/svc_acct.username: $!";
1218 flock(USERNAME,LOCK_EX)
1219 or die "can't lock $dir/svc_acct.username: $!";
1221 print USERNAME "$username\n";
1223 flock(USERNAME,LOCK_UN)
1224 or die "can't unlock $dir/svc_acct.username: $!";
1232 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1236 sub radius_usergroup_selector {
1237 my $sel_groups = shift;
1238 my %sel_groups = map { $_=>1 } @$sel_groups;
1240 my $selectname = shift || 'radius_usergroup';
1243 my $sth = $dbh->prepare(
1244 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1245 ) or die $dbh->errstr;
1246 $sth->execute() or die $sth->errstr;
1247 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1251 function ${selectname}_doadd(object) {
1252 var myvalue = object.${selectname}_add.value;
1253 var optionName = new Option(myvalue,myvalue,false,true);
1254 var length = object.$selectname.length;
1255 object.$selectname.options[length] = optionName;
1256 object.${selectname}_add.value = "";
1259 <SELECT MULTIPLE NAME="$selectname">
1262 foreach my $group ( @all_groups ) {
1264 if ( $sel_groups{$group} ) {
1265 $html .= ' SELECTED';
1266 $sel_groups{$group} = 0;
1268 $html .= ">$group</OPTION>\n";
1270 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1271 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1273 $html .= '</SELECT>';
1275 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1276 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1285 The $recref stuff in sub check should be cleaned up.
1287 The suspend, unsuspend and cancel methods update the database, but not the
1288 current object. This is probably a bug as it's unexpected and
1291 radius_usergroup_selector? putting web ui components in here? they should
1292 probably live somewhere else...
1294 insertion of RADIUS group stuff in insert could be done with child_objects now
1295 (would probably clean up export of them too)
1299 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1300 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1301 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1302 L<freeside-queued>), L<FS::svc_acct_pop>,
1303 schema.html from the base documentation.