4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
9 $username_uppercase $username_percent
10 $password_noampersand $password_noexclamation
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
13 $radius_password $radius_ip
19 use Crypt::PasswdMD5 1.2;
21 use FS::UID qw( datasrc );
23 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
24 use FS::Msgcat qw(gettext);
29 use FS::cust_main_invoice;
33 use FS::radius_usergroup;
40 @ISA = qw( FS::svc_Common );
43 $me = '[FS::svc_acct]';
45 #ask FS::UID to run this stuff for us later
46 $FS::UID::callback{'FS::svc_acct'} = sub {
48 $dir_prefix = $conf->config('home');
49 @shells = $conf->config('shells');
50 $usernamemin = $conf->config('usernamemin') || 2;
51 $usernamemax = $conf->config('usernamemax');
52 $passwordmin = $conf->config('passwordmin') || 6;
53 $passwordmax = $conf->config('passwordmax') || 8;
54 $username_letter = $conf->exists('username-letter');
55 $username_letterfirst = $conf->exists('username-letterfirst');
56 $username_noperiod = $conf->exists('username-noperiod');
57 $username_nounderscore = $conf->exists('username-nounderscore');
58 $username_nodash = $conf->exists('username-nodash');
59 $username_uppercase = $conf->exists('username-uppercase');
60 $username_ampersand = $conf->exists('username-ampersand');
61 $username_percent = $conf->exists('username-percent');
62 $password_noampersand = $conf->exists('password-noexclamation');
63 $password_noexclamation = $conf->exists('password-noexclamation');
64 $dirhash = $conf->config('dirhash') || 0;
65 if ( $conf->exists('welcome_email') ) {
66 $welcome_template = new Text::Template (
68 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
69 ) or warn "can't create welcome email template: $Text::Template::ERROR";
70 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
71 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
72 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
74 $welcome_template = '';
76 $welcome_subject = '';
77 $welcome_mimetype = '';
79 $smtpmachine = $conf->config('smtpmachine');
80 $radius_password = $conf->config('radius-password') || 'Password';
81 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
84 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
85 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
89 my ( $hashref, $cache ) = @_;
90 if ( $hashref->{'svc_acct_svcnum'} ) {
91 $self->{'_domsvc'} = FS::svc_domain->new( {
92 'svcnum' => $hashref->{'domsvc'},
93 'domain' => $hashref->{'svc_acct_domain'},
94 'catchall' => $hashref->{'svc_acct_catchall'},
101 FS::svc_acct - Object methods for svc_acct records
107 $record = new FS::svc_acct \%hash;
108 $record = new FS::svc_acct { 'column' => 'value' };
110 $error = $record->insert;
112 $error = $new_record->replace($old_record);
114 $error = $record->delete;
116 $error = $record->check;
118 $error = $record->suspend;
120 $error = $record->unsuspend;
122 $error = $record->cancel;
124 %hash = $record->radius;
126 %hash = $record->radius_reply;
128 %hash = $record->radius_check;
130 $domain = $record->domain;
132 $svc_domain = $record->svc_domain;
134 $email = $record->email;
136 $seconds_since = $record->seconds_since($timestamp);
140 An FS::svc_acct object represents an account. FS::svc_acct inherits from
141 FS::svc_Common. The following fields are currently supported:
145 =item svcnum - primary key (assigned automatcially for new accounts)
149 =item _password - generated if blank
151 =item sec_phrase - security phrase
153 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
161 =item dir - set automatically if blank (and uid is not)
165 =item quota - (unimplementd)
167 =item slipip - IP address
171 =item domsvc - svcnum from svc_domain
173 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
175 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
185 Creates a new account. To add the account to the database, see L<"insert">.
189 sub table { 'svc_acct'; }
193 #false laziness with edit/svc_acct.cgi
195 my( $self, $groups ) = @_;
196 if ( ref($groups) eq 'ARRAY' ) {
198 } elsif ( length($groups) ) {
199 [ split(/\s*,\s*/, $groups) ];
207 =item insert [ , OPTION => VALUE ... ]
209 Adds this account to the database. If there is an error, returns the error,
210 otherwise returns false.
212 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
213 defined. An FS::cust_svc record will be created and inserted.
215 The additional field I<usergroup> can optionally be defined; if so it should
216 contain an arrayref of group names. See L<FS::radius_usergroup>.
218 The additional field I<child_objects> can optionally be defined; if so it
219 should contain an arrayref of FS::tablename objects. They will have their
220 svcnum fields set and will be inserted after this record, but before any
221 exports are run. Each element of the array can also optionally be a
222 two-element array reference containing the child object and the name of an
223 alternate field to be filled in with the newly-inserted svcnum, for example
224 C<[ $svc_forward, 'srcsvc' ]>
226 Currently available options are: I<depend_jobnum>
228 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
229 jobnums), all provisioning jobs will have a dependancy on the supplied
230 jobnum(s) (they will not run until the specific job(s) complete(s)).
232 (TODOC: L<FS::queue> and L<freeside-queued>)
234 (TODOC: new exports!)
243 warn "[$me] insert called on $self: ". Dumper($self).
244 "\nwith options: ". Dumper(%options);
247 local $SIG{HUP} = 'IGNORE';
248 local $SIG{INT} = 'IGNORE';
249 local $SIG{QUIT} = 'IGNORE';
250 local $SIG{TERM} = 'IGNORE';
251 local $SIG{TSTP} = 'IGNORE';
252 local $SIG{PIPE} = 'IGNORE';
254 my $oldAutoCommit = $FS::UID::AutoCommit;
255 local $FS::UID::AutoCommit = 0;
258 my $error = $self->check;
259 return $error if $error;
261 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
262 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
263 unless ( $cust_svc ) {
264 $dbh->rollback if $oldAutoCommit;
265 return "no cust_svc record found for svcnum ". $self->svcnum;
267 $self->pkgnum($cust_svc->pkgnum);
268 $self->svcpart($cust_svc->svcpart);
271 $error = $self->_check_duplicate;
273 $dbh->rollback if $oldAutoCommit;
278 $error = $self->SUPER::insert(
279 'jobnums' => \@jobnums,
280 'child_objects' => $self->child_objects,
284 $dbh->rollback if $oldAutoCommit;
288 if ( $self->usergroup ) {
289 foreach my $groupname ( @{$self->usergroup} ) {
290 my $radius_usergroup = new FS::radius_usergroup ( {
291 svcnum => $self->svcnum,
292 groupname => $groupname,
294 my $error = $radius_usergroup->insert;
296 $dbh->rollback if $oldAutoCommit;
302 unless ( $skip_fuzzyfiles ) {
303 $error = $self->queue_fuzzyfiles_update;
305 $dbh->rollback if $oldAutoCommit;
306 return "updating fuzzy search cache: $error";
310 my $cust_pkg = $self->cust_svc->cust_pkg;
313 my $cust_main = $cust_pkg->cust_main;
315 if ( $conf->exists('emailinvoiceauto') ) {
316 my @invoicing_list = $cust_main->invoicing_list;
317 push @invoicing_list, $self->email;
318 $cust_main->invoicing_list(\@invoicing_list);
323 if ( $welcome_template && $cust_pkg ) {
324 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
326 my $wqueue = new FS::queue {
327 'svcnum' => $self->svcnum,
328 'job' => 'FS::svc_acct::send_email'
330 my $error = $wqueue->insert(
332 'from' => $welcome_from,
333 'subject' => $welcome_subject,
334 'mimetype' => $welcome_mimetype,
335 'body' => $welcome_template->fill_in( HASH => {
336 'custnum' => $self->custnum,
337 'username' => $self->username,
338 'password' => $self->_password,
339 'first' => $cust_main->first,
340 'last' => $cust_main->getfield('last'),
341 'pkg' => $cust_pkg->part_pkg->pkg,
345 $dbh->rollback if $oldAutoCommit;
346 return "error queuing welcome email: $error";
349 if ( $options{'depend_jobnum'} ) {
350 warn "$me depend_jobnum found; adding to welcome email dependancies"
352 if ( ref($options{'depend_jobnum'}) ) {
353 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
354 "to welcome email dependancies"
356 push @jobnums, @{ $options{'depend_jobnum'} };
358 warn "$me adding job $options{'depend_jobnum'} ".
359 "to welcome email dependancies"
361 push @jobnums, $options{'depend_jobnum'};
365 foreach my $jobnum ( @jobnums ) {
366 my $error = $wqueue->depend_insert($jobnum);
368 $dbh->rollback if $oldAutoCommit;
369 return "error queuing welcome email job dependancy: $error";
379 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
385 Deletes this account from the database. If there is an error, returns the
386 error, otherwise returns false.
388 The corresponding FS::cust_svc record will be deleted as well.
390 (TODOC: new exports!)
397 return "can't delete system account" if $self->_check_system;
399 return "Can't delete an account which is a (svc_forward) source!"
400 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
402 return "Can't delete an account which is a (svc_forward) destination!"
403 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
405 return "Can't delete an account with (svc_www) web service!"
406 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
408 # what about records in session ? (they should refer to history table)
410 local $SIG{HUP} = 'IGNORE';
411 local $SIG{INT} = 'IGNORE';
412 local $SIG{QUIT} = 'IGNORE';
413 local $SIG{TERM} = 'IGNORE';
414 local $SIG{TSTP} = 'IGNORE';
415 local $SIG{PIPE} = 'IGNORE';
417 my $oldAutoCommit = $FS::UID::AutoCommit;
418 local $FS::UID::AutoCommit = 0;
421 foreach my $cust_main_invoice (
422 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
424 unless ( defined($cust_main_invoice) ) {
425 warn "WARNING: something's wrong with qsearch";
428 my %hash = $cust_main_invoice->hash;
429 $hash{'dest'} = $self->email;
430 my $new = new FS::cust_main_invoice \%hash;
431 my $error = $new->replace($cust_main_invoice);
433 $dbh->rollback if $oldAutoCommit;
438 foreach my $svc_domain (
439 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
441 my %hash = new FS::svc_domain->hash;
442 $hash{'catchall'} = '';
443 my $new = new FS::svc_domain \%hash;
444 my $error = $new->replace($svc_domain);
446 $dbh->rollback if $oldAutoCommit;
451 foreach my $radius_usergroup (
452 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
454 my $error = $radius_usergroup->delete;
456 $dbh->rollback if $oldAutoCommit;
461 my $error = $self->SUPER::delete;
463 $dbh->rollback if $oldAutoCommit;
467 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
471 =item replace OLD_RECORD
473 Replaces OLD_RECORD with this one in the database. If there is an error,
474 returns the error, otherwise returns false.
476 The additional field I<usergroup> can optionally be defined; if so it should
477 contain an arrayref of group names. See L<FS::radius_usergroup>.
483 my ( $new, $old ) = ( shift, shift );
485 warn "$me replacing $old with $new\n" if $DEBUG;
487 # We absolutely have to have an old vs. new record to make this work.
488 if (!defined($old)) {
489 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
492 return "can't modify system account" if $old->_check_system;
495 #no warnings 'numeric'; #alas, a 5.006-ism
498 foreach my $xid (qw( uid gid )) {
500 return "Can't change $xid!"
501 if ! $conf->exists("svc_acct-edit_$xid")
502 && $old->$xid() != $new->$xid()
503 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
508 #change homdir when we change username
509 $new->setfield('dir', '') if $old->username ne $new->username;
511 local $SIG{HUP} = 'IGNORE';
512 local $SIG{INT} = 'IGNORE';
513 local $SIG{QUIT} = 'IGNORE';
514 local $SIG{TERM} = 'IGNORE';
515 local $SIG{TSTP} = 'IGNORE';
516 local $SIG{PIPE} = 'IGNORE';
518 my $oldAutoCommit = $FS::UID::AutoCommit;
519 local $FS::UID::AutoCommit = 0;
522 # redundant, but so $new->usergroup gets set
523 $error = $new->check;
524 return $error if $error;
526 $old->usergroup( [ $old->radius_groups ] );
528 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
529 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
531 if ( $new->usergroup ) {
532 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
533 my @newgroups = @{$new->usergroup};
534 foreach my $oldgroup ( @{$old->usergroup} ) {
535 if ( grep { $oldgroup eq $_ } @newgroups ) {
536 @newgroups = grep { $oldgroup ne $_ } @newgroups;
539 my $radius_usergroup = qsearchs('radius_usergroup', {
540 svcnum => $old->svcnum,
541 groupname => $oldgroup,
543 my $error = $radius_usergroup->delete;
545 $dbh->rollback if $oldAutoCommit;
546 return "error deleting radius_usergroup $oldgroup: $error";
550 foreach my $newgroup ( @newgroups ) {
551 my $radius_usergroup = new FS::radius_usergroup ( {
552 svcnum => $new->svcnum,
553 groupname => $newgroup,
555 my $error = $radius_usergroup->insert;
557 $dbh->rollback if $oldAutoCommit;
558 return "error adding radius_usergroup $newgroup: $error";
564 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
565 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
566 $error = $new->_check_duplicate;
568 $dbh->rollback if $oldAutoCommit;
573 $error = $new->SUPER::replace($old);
575 $dbh->rollback if $oldAutoCommit;
576 return $error if $error;
579 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
580 $error = $new->queue_fuzzyfiles_update;
582 $dbh->rollback if $oldAutoCommit;
583 return "updating fuzzy search cache: $error";
587 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
591 =item queue_fuzzyfiles_update
593 Used by insert & replace to update the fuzzy search cache
597 sub queue_fuzzyfiles_update {
600 local $SIG{HUP} = 'IGNORE';
601 local $SIG{INT} = 'IGNORE';
602 local $SIG{QUIT} = 'IGNORE';
603 local $SIG{TERM} = 'IGNORE';
604 local $SIG{TSTP} = 'IGNORE';
605 local $SIG{PIPE} = 'IGNORE';
607 my $oldAutoCommit = $FS::UID::AutoCommit;
608 local $FS::UID::AutoCommit = 0;
611 my $queue = new FS::queue {
612 'svcnum' => $self->svcnum,
613 'job' => 'FS::svc_acct::append_fuzzyfiles'
615 my $error = $queue->insert($self->username);
617 $dbh->rollback if $oldAutoCommit;
618 return "queueing job (transaction rolled back): $error";
621 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
629 Suspends this account by calling export-specific suspend hooks. If there is
630 an error, returns the error, otherwise returns false.
632 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
638 return "can't suspend system account" if $self->_check_system;
639 $self->SUPER::suspend;
644 Unsuspends this account by by calling export-specific suspend hooks. If there
645 is an error, returns the error, otherwise returns false.
647 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
653 my %hash = $self->hash;
654 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
655 $hash{_password} = $1;
656 my $new = new FS::svc_acct ( \%hash );
657 my $error = $new->replace($self);
658 return $error if $error;
661 $self->SUPER::unsuspend;
666 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
668 If the B<auto_unset_catchall> configuration option is set, this method will
669 automatically remove any references to the canceled service in the catchall
670 field of svc_domain. This allows packages that contain both a svc_domain and
671 its catchall svc_acct to be canceled in one step.
676 # Only one thing to do at this level
678 foreach my $svc_domain (
679 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
680 if($conf->exists('auto_unset_catchall')) {
681 my %hash = $svc_domain->hash;
682 $hash{catchall} = '';
683 my $new = new FS::svc_domain ( \%hash );
684 my $error = $new->replace($svc_domain);
685 return $error if $error;
687 return "cannot unprovision svc_acct #".$self->svcnum.
688 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
692 $self->SUPER::cancel;
698 Checks all fields to make sure this is a valid service. If there is an error,
699 returns the error, otherwise returns false. Called by the insert and replace
702 Sets any fixed values; see L<FS::part_svc>.
709 my($recref) = $self->hashref;
711 my $x = $self->setfixed( $self->_fieldhandlers );
712 return $x unless ref($x);
715 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
717 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
720 my $error = $self->ut_numbern('svcnum')
721 #|| $self->ut_number('domsvc')
722 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
723 || $self->ut_textn('sec_phrase')
725 return $error if $error;
727 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
728 if ( $username_uppercase ) {
729 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
730 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
731 $recref->{username} = $1;
733 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
734 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
735 $recref->{username} = $1;
738 if ( $username_letterfirst ) {
739 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
740 } elsif ( $username_letter ) {
741 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
743 if ( $username_noperiod ) {
744 $recref->{username} =~ /\./ and return gettext('illegal_username');
746 if ( $username_nounderscore ) {
747 $recref->{username} =~ /_/ and return gettext('illegal_username');
749 if ( $username_nodash ) {
750 $recref->{username} =~ /\-/ and return gettext('illegal_username');
752 unless ( $username_ampersand ) {
753 $recref->{username} =~ /\&/ and return gettext('illegal_username');
755 if ( $password_noampersand ) {
756 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
758 if ( $password_noexclamation ) {
759 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
761 unless ( $username_percent ) {
762 $recref->{username} =~ /\%/ and return gettext('illegal_username');
765 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
766 $recref->{popnum} = $1;
767 return "Unknown popnum" unless
768 ! $recref->{popnum} ||
769 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
771 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
773 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
774 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
776 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
777 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
778 #not all systems use gid=uid
779 #you can set a fixed gid in part_svc
781 return "Only root can have uid 0"
782 if $recref->{uid} == 0
783 && $recref->{username} !~ /^(root|toor|smtp)$/;
785 unless ( $recref->{username} eq 'sync' ) {
786 if ( grep $_ eq $recref->{shell}, @shells ) {
787 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
789 return "Illegal shell \`". $self->shell. "\'; ".
790 $conf->dir. "/shells contains: @shells";
793 $recref->{shell} = '/bin/sync';
797 $recref->{gid} ne '' ?
798 return "Can't have gid without uid" : ( $recref->{gid}='' );
799 #$recref->{dir} ne '' ?
800 # return "Can't have directory without uid" : ( $recref->{dir}='' );
801 $recref->{shell} ne '' ?
802 return "Can't have shell without uid" : ( $recref->{shell}='' );
805 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
807 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
808 or return "Illegal directory: ". $recref->{dir};
810 return "Illegal directory"
811 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
812 return "Illegal directory"
813 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
814 unless ( $recref->{dir} ) {
815 $recref->{dir} = $dir_prefix . '/';
816 if ( $dirhash > 0 ) {
817 for my $h ( 1 .. $dirhash ) {
818 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
820 } elsif ( $dirhash < 0 ) {
821 for my $h ( reverse $dirhash .. -1 ) {
822 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
825 $recref->{dir} .= $recref->{username};
831 # $error = $self->ut_textn('finger');
832 # return $error if $error;
833 if ( $self->getfield('finger') eq '' ) {
834 my $cust_pkg = $self->svcnum
835 ? $self->cust_svc->cust_pkg
836 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
838 my $cust_main = $cust_pkg->cust_main;
839 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
842 $self->getfield('finger') =~
843 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
844 or return "Illegal finger: ". $self->getfield('finger');
845 $self->setfield('finger', $1);
847 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
848 $recref->{quota} = $1;
850 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
851 if ( $recref->{slipip} eq '' ) {
852 $recref->{slipip} = '';
853 } elsif ( $recref->{slipip} eq '0e0' ) {
854 $recref->{slipip} = '0e0';
856 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
857 or return "Illegal slipip: ". $self->slipip;
858 $recref->{slipip} = $1;
863 #arbitrary RADIUS stuff; allow ut_textn for now
864 foreach ( grep /^radius_/, fields('svc_acct') ) {
868 #generate a password if it is blank
869 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
870 unless ( $recref->{_password} );
872 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
873 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
874 $recref->{_password} = $1.$3;
875 #uncomment this to encrypt password immediately upon entry, or run
876 #bin/crypt_pw in cron to give new users a window during which their
877 #password is available to techs, for faxing, etc. (also be aware of
879 #$recref->{password} = $1.
880 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
882 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
883 $recref->{_password} = $1.$3;
884 } elsif ( $recref->{_password} eq '*' ) {
885 $recref->{_password} = '*';
886 } elsif ( $recref->{_password} eq '!' ) {
887 $recref->{_password} = '!';
888 } elsif ( $recref->{_password} eq '!!' ) {
889 $recref->{_password} = '!!';
891 #return "Illegal password";
892 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
893 FS::Msgcat::_gettext('illegal_password_characters').
894 ": ". $recref->{_password};
902 Internal function to check the username against the list of system usernames
903 from the I<system_usernames> configuration value. Returns true if the username
904 is listed on the system username list.
910 scalar( grep { $self->username eq $_ || $self->email eq $_ }
911 $conf->config('system_usernames')
915 =item _check_duplicate
917 Internal function to check for duplicates usernames, username@domain pairs and
920 If the I<global_unique-username> configuration value is set to B<username> or
921 B<username@domain>, enforces global username or username@domain uniqueness.
923 In all cases, check for duplicate uids and usernames or username@domain pairs
924 per export and with identical I<svcpart> values.
928 sub _check_duplicate {
931 my $global_unique = $conf->config('global_unique-username') || 'none';
932 return '' if $global_unique eq 'disabled';
934 #this is Pg-specific. what to do for mysql etc?
935 # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
936 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
937 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
939 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
941 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
942 unless ( $part_svc ) {
943 return 'unknown svcpart '. $self->svcpart;
946 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
947 qsearch( 'svc_acct', { 'username' => $self->username } );
948 return gettext('username_in_use')
949 if $global_unique eq 'username' && @dup_user;
951 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
952 qsearch( 'svc_acct', { 'username' => $self->username,
953 'domsvc' => $self->domsvc } );
954 return gettext('username_in_use')
955 if $global_unique eq 'username@domain' && @dup_userdomain;
958 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
959 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
960 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
961 qsearch( 'svc_acct', { 'uid' => $self->uid } );
966 if ( @dup_user || @dup_userdomain || @dup_uid ) {
967 my $exports = FS::part_export::export_info('svc_acct');
968 my %conflict_user_svcpart;
969 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
971 foreach my $part_export ( $part_svc->part_export ) {
973 #this will catch to the same exact export
974 my @svcparts = map { $_->svcpart } $part_export->export_svc;
976 #this will catch to exports w/same exporthost+type ???
977 #my @other_part_export = qsearch('part_export', {
978 # 'machine' => $part_export->machine,
979 # 'exporttype' => $part_export->exporttype,
981 #foreach my $other_part_export ( @other_part_export ) {
982 # push @svcparts, map { $_->svcpart }
983 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
986 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
987 #silly kludge to avoid uninitialized value errors
988 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
989 ? $exports->{$part_export->exporttype}{'nodomain'}
991 if ( $nodomain =~ /^Y/i ) {
992 $conflict_user_svcpart{$_} = $part_export->exportnum
995 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1000 foreach my $dup_user ( @dup_user ) {
1001 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1002 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1003 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1004 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1008 foreach my $dup_userdomain ( @dup_userdomain ) {
1009 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1010 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1011 return "duplicate username\@domain: conflicts with svcnum ".
1012 $dup_userdomain->svcnum. " via exportnum ".
1013 $conflict_userdomain_svcpart{$dup_svcpart};
1017 foreach my $dup_uid ( @dup_uid ) {
1018 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1019 if ( exists($conflict_user_svcpart{$dup_svcpart})
1020 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1021 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1022 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1023 || $conflict_userdomain_svcpart{$dup_svcpart};
1035 Depriciated, use radius_reply instead.
1040 carp "FS::svc_acct::radius depriciated, use radius_reply";
1041 $_[0]->radius_reply;
1046 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1047 reply attributes of this record.
1049 Note that this is now the preferred method for reading RADIUS attributes -
1050 accessing the columns directly is discouraged, as the column names are
1051 expected to change in the future.
1058 return %{ $self->{'radius_reply'} }
1059 if exists $self->{'radius_reply'};
1064 my($column, $attrib) = ($1, $2);
1065 #$attrib =~ s/_/\-/g;
1066 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1067 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1069 if ( $self->slipip && $self->slipip ne '0e0' ) {
1070 $reply{$radius_ip} = $self->slipip;
1073 if ( $self->seconds !~ /^$/ ) {
1074 $reply{'Session-Timeout'} = $self->seconds;
1082 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1083 check attributes of this record.
1085 Note that this is now the preferred method for reading RADIUS attributes -
1086 accessing the columns directly is discouraged, as the column names are
1087 expected to change in the future.
1094 return %{ $self->{'radius_check'} }
1095 if exists $self->{'radius_check'};
1100 my($column, $attrib) = ($1, $2);
1101 #$attrib =~ s/_/\-/g;
1102 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1103 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1105 my $password = $self->_password;
1106 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1108 my $cust_svc = $self->cust_svc;
1109 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1111 my $cust_pkg = $cust_svc->cust_pkg;
1112 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1113 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1122 This method instructs the object to "snapshot" or freeze RADIUS check and
1123 reply attributes to the current values.
1127 #bah, my english is too broken this morning
1128 #Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill. (This is used by
1129 #the FS::cust_pkg's replace method to trigger the correct export updates when
1130 #package dates change)
1135 $self->{$_} = { $self->$_() }
1136 foreach qw( radius_reply radius_check );
1140 =item forget_snapshot
1142 This methos instructs the object to forget any previously snapshotted
1143 RADIUS check and reply attributes.
1147 sub forget_snapshot {
1151 foreach qw( radius_reply radius_check );
1157 Returns the domain associated with this account.
1163 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1164 my $svc_domain = $self->svc_domain(@_)
1165 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1166 $svc_domain->domain;
1171 Returns the FS::svc_domain record for this account's domain (see
1179 ? $self->{'_domsvc'}
1180 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1185 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1189 #inherited from svc_Common
1193 Returns an email address associated with the account.
1199 $self->username. '@'. $self->domain(@_);
1204 Returns an array of FS::acct_snarf records associated with the account.
1205 If the acct_snarf table does not exist or there are no associated records,
1206 an empty list is returned
1212 return () unless dbdef->table('acct_snarf');
1213 eval "use FS::acct_snarf;";
1215 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1218 =item decrement_seconds SECONDS
1220 Decrements the I<seconds> field of this record by the given amount. If there
1221 is an error, returns the error, otherwise returns false.
1225 sub decrement_seconds {
1226 shift->_op_seconds('-', @_);
1229 =item increment_seconds SECONDS
1231 Increments the I<seconds> field of this record by the given amount. If there
1232 is an error, returns the error, otherwise returns false.
1236 sub increment_seconds {
1237 shift->_op_seconds('+', @_);
1245 my %op2condition = (
1246 '-' => sub { my($self, $seconds) = @_;
1247 $self->seconds - $seconds <= 0;
1249 '+' => sub { my($self, $seconds) = @_;
1250 $self->seconds + $seconds > 0;
1255 my( $self, $op, $seconds ) = @_;
1256 warn "$me _op_seconds called for svcnum ". $self->svcnum.
1257 ' ('. $self->email. "): $op $seconds\n"
1260 local $SIG{HUP} = 'IGNORE';
1261 local $SIG{INT} = 'IGNORE';
1262 local $SIG{QUIT} = 'IGNORE';
1263 local $SIG{TERM} = 'IGNORE';
1264 local $SIG{TSTP} = 'IGNORE';
1265 local $SIG{PIPE} = 'IGNORE';
1267 my $oldAutoCommit = $FS::UID::AutoCommit;
1268 local $FS::UID::AutoCommit = 0;
1271 my $sql = "UPDATE svc_acct SET seconds = ".
1272 " CASE WHEN seconds IS NULL THEN 0 ELSE seconds END ". #$seconds||0
1273 " $op ? WHERE svcnum = ?";
1277 my $sth = $dbh->prepare( $sql )
1278 or die "Error preparing $sql: ". $dbh->errstr;
1279 my $rv = $sth->execute($seconds, $self->svcnum);
1280 die "Error executing $sql: ". $sth->errstr
1281 unless defined($rv);
1282 die "Can't update seconds for svcnum". $self->svcnum
1285 my $action = $op2action{$op};
1287 if ( $conf->exists("svc_acct-usage_$action")
1288 && &{$op2condition{$op}}($self, $seconds) ) {
1289 #my $error = $self->$action();
1290 my $error = $self->cust_svc->cust_pkg->$action();
1292 $dbh->rollback if $oldAutoCommit;
1293 return "Error ${action}ing: $error";
1297 warn "$me update successful; committing\n"
1299 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1305 =item seconds_since TIMESTAMP
1307 Returns the number of seconds this account has been online since TIMESTAMP,
1308 according to the session monitor (see L<FS::Session>).
1310 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1311 L<Time::Local> and L<Date::Parse> for conversion functions.
1315 #note: POD here, implementation in FS::cust_svc
1318 $self->cust_svc->seconds_since(@_);
1321 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1323 Returns the numbers of seconds this account has been online between
1324 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1325 external SQL radacct table, specified via sqlradius export. Sessions which
1326 started in the specified range but are still open are counted from session
1327 start to the end of the range (unless they are over 1 day old, in which case
1328 they are presumed missing their stop record and not counted). Also, sessions
1329 which end in the range but started earlier are counted from the start of the
1330 range to session end. Finally, sessions which start before the range but end
1331 after are counted for the entire range.
1333 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1334 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1339 #note: POD here, implementation in FS::cust_svc
1340 sub seconds_since_sqlradacct {
1342 $self->cust_svc->seconds_since_sqlradacct(@_);
1345 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1347 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1348 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1349 TIMESTAMP_END (exclusive).
1351 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1352 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1357 #note: POD here, implementation in FS::cust_svc
1358 sub attribute_since_sqlradacct {
1360 $self->cust_svc->attribute_since_sqlradacct(@_);
1363 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1365 Returns an array of hash references of this customers login history for the
1366 given time range. (document this better)
1370 sub get_session_history {
1372 $self->cust_svc->get_session_history(@_);
1375 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1380 my($self, $start, $end, %opt ) = @_;
1382 my $did = $self->username; #yup
1384 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1386 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1388 #SELECT $for_update * FROM cdr
1389 # WHERE calldate >= $start #need a conversion
1390 # AND calldate < $end #ditto
1391 # AND ( charged_party = "$did"
1392 # OR charged_party = "$prefix$did" #if length($prefix);
1393 # OR ( ( charged_party IS NULL OR charged_party = '' )
1395 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1398 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1401 if ( length($prefix) ) {
1403 " AND ( charged_party = '$did'
1404 OR charged_party = '$prefix$did'
1405 OR ( ( charged_party IS NULL OR charged_party = '' )
1407 ( src = '$did' OR src = '$prefix$did' )
1413 " AND ( charged_party = '$did'
1414 OR ( ( charged_party IS NULL OR charged_party = '' )
1424 'select' => "$for_update *",
1427 #( freesidestatus IS NULL OR freesidestatus = '' )
1428 'freesidestatus' => '',
1430 'extra_sql' => $charged_or_src,
1438 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1444 if ( $self->usergroup ) {
1445 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1446 unless ref($self->usergroup) eq 'ARRAY';
1447 #when provisioning records, export callback runs in svc_Common.pm before
1448 #radius_usergroup records can be inserted...
1449 @{$self->usergroup};
1451 map { $_->groupname }
1452 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1456 =item clone_suspended
1458 Constructor used by FS::part_export::_export_suspend fallback. Document
1463 sub clone_suspended {
1465 my %hash = $self->hash;
1466 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1467 new FS::svc_acct \%hash;
1470 =item clone_kludge_unsuspend
1472 Constructor used by FS::part_export::_export_unsuspend fallback. Document
1477 sub clone_kludge_unsuspend {
1479 my %hash = $self->hash;
1480 $hash{_password} = '';
1481 new FS::svc_acct \%hash;
1484 =item check_password
1486 Checks the supplied password against the (possibly encrypted) password in the
1487 database. Returns true for a successful authentication, false for no match.
1489 Currently supported encryptions are: classic DES crypt() and MD5
1493 sub check_password {
1494 my($self, $check_password) = @_;
1496 #remove old-style SUSPENDED kludge, they should be allowed to login to
1497 #self-service and pay up
1498 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
1500 #eventually should check a "password-encoding" field
1501 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
1503 } elsif ( length($password) < 13 ) { #plaintext
1504 $check_password eq $password;
1505 } elsif ( length($password) == 13 ) { #traditional DES crypt
1506 crypt($check_password, $password) eq $password;
1507 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
1508 unix_md5_crypt($check_password, $password) eq $password;
1509 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
1510 warn "Can't check password: Blowfish encryption not yet supported, svcnum".
1511 $self->svcnum. "\n";
1514 warn "Can't check password: Unrecognized encryption for svcnum ".
1515 $self->svcnum. "\n";
1521 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
1523 Returns an encrypted password, either by passing through an encrypted password
1524 in the database or by encrypting a plaintext password from the database.
1526 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
1527 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
1528 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
1529 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
1530 encryption type is only used if the password is not already encrypted in the
1535 sub crypt_password {
1537 #eventually should check a "password-encoding" field
1538 if ( length($self->_password) == 13
1539 || $self->_password =~ /^\$(1|2a?)\$/
1540 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
1545 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1546 if ( $encryption eq 'crypt' ) {
1549 $saltset[int(rand(64))].$saltset[int(rand(64))]
1551 } elsif ( $encryption eq 'md5' ) {
1552 unix_md5_crypt( $self->_password );
1553 } elsif ( $encryption eq 'blowfish' ) {
1554 croak "unknown encryption method $encryption";
1556 croak "unknown encryption method $encryption";
1561 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
1563 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
1564 describing the format, for example, "{CRYPT}94pAVyK/4oIBk" or
1565 "{PLAIN-MD5}5426824942db4253f87a1009fd5d2d4f".
1567 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
1568 to work the same as the B</crypt_password> method.
1574 #eventually should check a "password-encoding" field
1575 if ( length($self->_password) == 13 ) { #crypt
1576 return '{CRYPT}'. $self->_password;
1577 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
1579 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
1580 die "Blowfish encryption not supported in this context, svcnum ".
1581 $self->svcnum. "\n";
1582 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
1583 return '{SSHA}'. $1;
1584 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
1585 return '{NS-MTA-MD5}'. $1;
1587 return '{PLAIN}'. $self->_password;
1588 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
1589 #if ( $encryption eq 'crypt' ) {
1590 # return '{CRYPT}'. crypt(
1592 # $saltset[int(rand(64))].$saltset[int(rand(64))]
1594 #} elsif ( $encryption eq 'md5' ) {
1595 # unix_md5_crypt( $self->_password );
1596 #} elsif ( $encryption eq 'blowfish' ) {
1597 # croak "unknown encryption method $encryption";
1599 # croak "unknown encryption method $encryption";
1604 =item domain_slash_username
1606 Returns $domain/$username/
1610 sub domain_slash_username {
1612 $self->domain. '/'. $self->username. '/';
1615 =item virtual_maildir
1617 Returns $domain/maildirs/$username/
1621 sub virtual_maildir {
1623 $self->domain. '/maildirs/'. $self->username. '/';
1634 This is the FS::svc_acct job-queue-able version. It still uses
1635 FS::Misc::send_email under-the-hood.
1642 eval "use FS::Misc qw(send_email)";
1645 $opt{mimetype} ||= 'text/plain';
1646 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1648 my $error = send_email(
1649 'from' => $opt{from},
1651 'subject' => $opt{subject},
1652 'content-type' => $opt{mimetype},
1653 'body' => [ map "$_\n", split("\n", $opt{body}) ],
1655 die $error if $error;
1658 =item check_and_rebuild_fuzzyfiles
1662 sub check_and_rebuild_fuzzyfiles {
1663 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1664 -e "$dir/svc_acct.username"
1665 or &rebuild_fuzzyfiles;
1668 =item rebuild_fuzzyfiles
1672 sub rebuild_fuzzyfiles {
1674 use Fcntl qw(:flock);
1676 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1680 open(USERNAMELOCK,">>$dir/svc_acct.username")
1681 or die "can't open $dir/svc_acct.username: $!";
1682 flock(USERNAMELOCK,LOCK_EX)
1683 or die "can't lock $dir/svc_acct.username: $!";
1685 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1687 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1688 or die "can't open $dir/svc_acct.username.tmp: $!";
1689 print USERNAMECACHE join("\n", @all_username), "\n";
1690 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1692 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1702 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1703 open(USERNAMECACHE,"<$dir/svc_acct.username")
1704 or die "can't open $dir/svc_acct.username: $!";
1705 my @array = map { chomp; $_; } <USERNAMECACHE>;
1706 close USERNAMECACHE;
1710 =item append_fuzzyfiles USERNAME
1714 sub append_fuzzyfiles {
1715 my $username = shift;
1717 &check_and_rebuild_fuzzyfiles;
1719 use Fcntl qw(:flock);
1721 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1723 open(USERNAME,">>$dir/svc_acct.username")
1724 or die "can't open $dir/svc_acct.username: $!";
1725 flock(USERNAME,LOCK_EX)
1726 or die "can't lock $dir/svc_acct.username: $!";
1728 print USERNAME "$username\n";
1730 flock(USERNAME,LOCK_UN)
1731 or die "can't unlock $dir/svc_acct.username: $!";
1739 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1743 sub radius_usergroup_selector {
1744 my $sel_groups = shift;
1745 my %sel_groups = map { $_=>1 } @$sel_groups;
1747 my $selectname = shift || 'radius_usergroup';
1750 my $sth = $dbh->prepare(
1751 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1752 ) or die $dbh->errstr;
1753 $sth->execute() or die $sth->errstr;
1754 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1758 function ${selectname}_doadd(object) {
1759 var myvalue = object.${selectname}_add.value;
1760 var optionName = new Option(myvalue,myvalue,false,true);
1761 var length = object.$selectname.length;
1762 object.$selectname.options[length] = optionName;
1763 object.${selectname}_add.value = "";
1766 <SELECT MULTIPLE NAME="$selectname">
1769 foreach my $group ( @all_groups ) {
1770 $html .= qq(<OPTION VALUE="$group");
1771 if ( $sel_groups{$group} ) {
1772 $html .= ' SELECTED';
1773 $sel_groups{$group} = 0;
1775 $html .= ">$group</OPTION>\n";
1777 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1778 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
1780 $html .= '</SELECT>';
1782 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1783 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1792 The $recref stuff in sub check should be cleaned up.
1794 The suspend, unsuspend and cancel methods update the database, but not the
1795 current object. This is probably a bug as it's unexpected and
1798 radius_usergroup_selector? putting web ui components in here? they should
1799 probably live somewhere else...
1801 insertion of RADIUS group stuff in insert could be done with child_objects now
1802 (would probably clean up export of them too)
1806 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1807 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1808 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1809 L<freeside-queued>), L<FS::svc_acct_pop>,
1810 schema.html from the base documentation.