4 use vars qw( @ISA $noexport_hack $conf
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
10 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
17 use FS::UID qw( datasrc );
19 use FS::Record qw( qsearch qsearchs fields dbh );
24 use FS::cust_main_invoice;
28 use FS::radius_usergroup;
31 use FS::Msgcat qw(gettext);
33 @ISA = qw( FS::svc_Common );
35 #ask FS::UID to run this stuff for us later
36 $FS::UID::callback{'FS::svc_acct'} = sub {
38 $dir_prefix = $conf->config('home');
39 @shells = $conf->config('shells');
40 $usernamemin = $conf->config('usernamemin') || 2;
41 $usernamemax = $conf->config('usernamemax');
42 $passwordmin = $conf->config('passwordmin') || 6;
43 $passwordmax = $conf->config('passwordmax') || 8;
44 $username_letter = $conf->exists('username-letter');
45 $username_letterfirst = $conf->exists('username-letterfirst');
46 $username_noperiod = $conf->exists('username-noperiod');
47 $username_nounderscore = $conf->exists('username-nounderscore');
48 $username_nodash = $conf->exists('username-nodash');
49 $username_uppercase = $conf->exists('username-uppercase');
50 $username_ampersand = $conf->exists('username-ampersand');
51 $dirhash = $conf->config('dirhash') || 0;
52 if ( $conf->exists('welcome_email') ) {
53 $welcome_template = new Text::Template (
55 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
56 ) or warn "can't create welcome email template: $Text::Template::ERROR";
57 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
58 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
59 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
61 $welcome_template = '';
63 $smtpmachine = $conf->config('smtpmachine');
64 $radius_password = $conf->config('radius-password') || 'Password';
67 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
68 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
72 my ( $hashref, $cache ) = @_;
73 if ( $hashref->{'svc_acct_svcnum'} ) {
74 $self->{'_domsvc'} = FS::svc_domain->new( {
75 'svcnum' => $hashref->{'domsvc'},
76 'domain' => $hashref->{'svc_acct_domain'},
77 'catchall' => $hashref->{'svc_acct_catchall'},
84 FS::svc_acct - Object methods for svc_acct records
90 $record = new FS::svc_acct \%hash;
91 $record = new FS::svc_acct { 'column' => 'value' };
93 $error = $record->insert;
95 $error = $new_record->replace($old_record);
97 $error = $record->delete;
99 $error = $record->check;
101 $error = $record->suspend;
103 $error = $record->unsuspend;
105 $error = $record->cancel;
107 %hash = $record->radius;
109 %hash = $record->radius_reply;
111 %hash = $record->radius_check;
113 $domain = $record->domain;
115 $svc_domain = $record->svc_domain;
117 $email = $record->email;
119 $seconds_since = $record->seconds_since($timestamp);
123 An FS::svc_acct object represents an account. FS::svc_acct inherits from
124 FS::svc_Common. The following fields are currently supported:
128 =item svcnum - primary key (assigned automatcially for new accounts)
132 =item _password - generated if blank
134 =item sec_phrase - security phrase
136 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
144 =item dir - set automatically if blank (and uid is not)
148 =item quota - (unimplementd)
150 =item slipip - IP address
154 =item domsvc - svcnum from svc_domain
156 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
166 Creates a new account. To add the account to the database, see L<"insert">.
170 sub table { 'svc_acct'; }
174 Adds this account to the database. If there is an error, returns the error,
175 otherwise returns false.
177 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
178 defined. An FS::cust_svc record will be created and inserted.
180 The additional field I<usergroup> can optionally be defined; if so it should
181 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
182 sqlradius export only)
184 (TODOC: L<FS::queue> and L<freeside-queued>)
186 (TODOC: new exports! $noexport_hack)
194 local $SIG{HUP} = 'IGNORE';
195 local $SIG{INT} = 'IGNORE';
196 local $SIG{QUIT} = 'IGNORE';
197 local $SIG{TERM} = 'IGNORE';
198 local $SIG{TSTP} = 'IGNORE';
199 local $SIG{PIPE} = 'IGNORE';
201 my $oldAutoCommit = $FS::UID::AutoCommit;
202 local $FS::UID::AutoCommit = 0;
205 $error = $self->check;
206 return $error if $error;
208 #no, duplicate checking just got a whole lot more complicated
209 #(perhaps keep this check with a config option to turn on?)
211 #return gettext('username_in_use'). ": ". $self->username
212 # if qsearchs( 'svc_acct', { 'username' => $self->username,
213 # 'domsvc' => $self->domsvc,
216 if ( $self->svcnum ) {
217 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
218 unless ( $cust_svc ) {
219 $dbh->rollback if $oldAutoCommit;
220 return "no cust_svc record found for svcnum ". $self->svcnum;
222 $self->pkgnum($cust_svc->pkgnum);
223 $self->svcpart($cust_svc->svcpart);
226 #new duplicate username checking
228 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
229 unless ( $part_svc ) {
230 $dbh->rollback if $oldAutoCommit;
231 return 'unknown svcpart '. $self->svcpart;
234 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
235 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
236 'domsvc' => $self->domsvc } );
238 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
239 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
240 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
245 if ( @dup_user || @dup_userdomain || @dup_uid ) {
246 my $exports = FS::part_export::export_info('svc_acct');
247 my %conflict_user_svcpart;
248 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
250 foreach my $part_export ( $part_svc->part_export ) {
252 #this will catch to the same exact export
253 my @svcparts = map { $_->svcpart }
254 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
256 #this will catch to exports w/same exporthost+type ???
257 #my @other_part_export = qsearch('part_export', {
258 # 'machine' => $part_export->machine,
259 # 'exporttype' => $part_export->exporttype,
261 #foreach my $other_part_export ( @other_part_export ) {
262 # push @svcparts, map { $_->svcpart }
263 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
266 my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
267 if ( $nodomain =~ /^Y/i ) {
268 $conflict_user_svcpart{$_} = $part_export->exportnum
271 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
276 foreach my $dup_user ( @dup_user ) {
277 my $dup_svcpart = $dup_user->cust_svc->svcpart;
278 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
279 $dbh->rollback if $oldAutoCommit;
280 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
281 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
285 foreach my $dup_userdomain ( @dup_userdomain ) {
286 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
287 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
288 $dbh->rollback if $oldAutoCommit;
289 return "duplicate username\@domain: conflicts with svcnum ".
290 $dup_userdomain->svcnum. " via exportnum ".
291 $conflict_userdomain_svcpart{$dup_svcpart};
295 foreach my $dup_uid ( @dup_uid ) {
296 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
297 if ( exists($conflict_user_svcpart{$dup_svcpart})
298 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
299 $dbh->rollback if $oldAutoCommit;
300 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
301 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
302 || $conflict_userdomain_svcpart{$dup_svcpart};
308 #see? i told you it was more complicated
311 $error = $self->SUPER::insert(\@jobnums);
313 $dbh->rollback if $oldAutoCommit;
317 if ( $self->usergroup ) {
318 foreach my $groupname ( @{$self->usergroup} ) {
319 my $radius_usergroup = new FS::radius_usergroup ( {
320 svcnum => $self->svcnum,
321 groupname => $groupname,
323 my $error = $radius_usergroup->insert;
325 $dbh->rollback if $oldAutoCommit;
331 #false laziness with sub replace (and cust_main)
332 my $queue = new FS::queue {
333 'svcnum' => $self->svcnum,
334 'job' => 'FS::svc_acct::append_fuzzyfiles'
336 $error = $queue->insert($self->username);
338 $dbh->rollback if $oldAutoCommit;
339 return "queueing job (transaction rolled back): $error";
342 my $cust_pkg = $self->cust_svc->cust_pkg;
345 my $cust_main = $cust_pkg->cust_main;
347 if ( $conf->exists('emailinvoiceauto') ) {
348 my @invoicing_list = $cust_main->invoicing_list;
349 push @invoicing_list, $self->email;
350 $cust_main->invoicing_list(\@invoicing_list);
355 if ( $welcome_template && $cust_pkg ) {
356 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
358 my $wqueue = new FS::queue {
359 'svcnum' => $self->svcnum,
360 'job' => 'FS::svc_acct::send_email'
362 warn "attempting to queue email to $to";
363 my $error = $wqueue->insert(
365 'from' => $welcome_from,
366 'subject' => $welcome_subject,
367 'mimetype' => $welcome_mimetype,
368 'body' => $welcome_template->fill_in( HASH => {
369 'username' => $self->username,
370 'password' => $self->_password,
371 'first' => $cust_main->first,
372 'last' => $cust_main->getfield('last'),
373 'pkg' => $cust_pkg->part_pkg->pkg,
377 $dbh->rollback if $oldAutoCommit;
378 return "queuing welcome email: $error";
381 foreach my $jobnum ( @jobnums ) {
382 my $error = $wqueue->depend_insert($jobnum);
384 $dbh->rollback if $oldAutoCommit;
385 return "queuing welcome email job dependancy: $error";
395 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
401 Deletes this account from the database. If there is an error, returns the
402 error, otherwise returns false.
404 The corresponding FS::cust_svc record will be deleted as well.
406 (TODOC: new exports! $noexport_hack)
413 return "Can't delete an account which is a (svc_forward) source!"
414 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
416 return "Can't delete an account which is a (svc_forward) destination!"
417 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
419 return "Can't delete an account with (svc_www) web service!"
420 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
422 # what about records in session ? (they should refer to history table)
424 local $SIG{HUP} = 'IGNORE';
425 local $SIG{INT} = 'IGNORE';
426 local $SIG{QUIT} = 'IGNORE';
427 local $SIG{TERM} = 'IGNORE';
428 local $SIG{TSTP} = 'IGNORE';
429 local $SIG{PIPE} = 'IGNORE';
431 my $oldAutoCommit = $FS::UID::AutoCommit;
432 local $FS::UID::AutoCommit = 0;
435 foreach my $cust_main_invoice (
436 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
438 unless ( defined($cust_main_invoice) ) {
439 warn "WARNING: something's wrong with qsearch";
442 my %hash = $cust_main_invoice->hash;
443 $hash{'dest'} = $self->email;
444 my $new = new FS::cust_main_invoice \%hash;
445 my $error = $new->replace($cust_main_invoice);
447 $dbh->rollback if $oldAutoCommit;
452 foreach my $svc_domain (
453 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
455 my %hash = new FS::svc_domain->hash;
456 $hash{'catchall'} = '';
457 my $new = new FS::svc_domain \%hash;
458 my $error = $new->replace($svc_domain);
460 $dbh->rollback if $oldAutoCommit;
465 foreach my $radius_usergroup (
466 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
468 my $error = $radius_usergroup->delete;
470 $dbh->rollback if $oldAutoCommit;
475 my $error = $self->SUPER::delete;
477 $dbh->rollback if $oldAutoCommit;
481 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
485 =item replace OLD_RECORD
487 Replaces OLD_RECORD with this one in the database. If there is an error,
488 returns the error, otherwise returns false.
490 The additional field I<usergroup> can optionally be defined; if so it should
491 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
492 sqlradius export only)
497 my ( $new, $old ) = ( shift, shift );
500 return "Username in use"
501 if $old->username ne $new->username &&
502 qsearchs( 'svc_acct', { 'username' => $new->username,
503 'domsvc' => $new->domsvc,
506 #no warnings 'numeric'; #alas, a 5.006-ism
508 return "Can't change uid!" if $old->uid != $new->uid;
511 #change homdir when we change username
512 $new->setfield('dir', '') if $old->username ne $new->username;
514 local $SIG{HUP} = 'IGNORE';
515 local $SIG{INT} = 'IGNORE';
516 local $SIG{QUIT} = 'IGNORE';
517 local $SIG{TERM} = 'IGNORE';
518 local $SIG{TSTP} = 'IGNORE';
519 local $SIG{PIPE} = 'IGNORE';
521 my $oldAutoCommit = $FS::UID::AutoCommit;
522 local $FS::UID::AutoCommit = 0;
525 $old->usergroup( [ $old->radius_groups ] );
526 if ( $new->usergroup ) {
527 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
528 my @newgroups = @{$new->usergroup};
529 foreach my $oldgroup ( @{$old->usergroup} ) {
530 if ( grep { $oldgroup eq $_ } @newgroups ) {
531 @newgroups = grep { $oldgroup ne $_ } @newgroups;
534 my $radius_usergroup = qsearchs('radius_usergroup', {
535 svcnum => $old->svcnum,
536 groupname => $oldgroup,
538 my $error = $radius_usergroup->delete;
540 $dbh->rollback if $oldAutoCommit;
541 return "error deleting radius_usergroup $oldgroup: $error";
545 foreach my $newgroup ( @newgroups ) {
546 my $radius_usergroup = new FS::radius_usergroup ( {
547 svcnum => $new->svcnum,
548 groupname => $newgroup,
550 my $error = $radius_usergroup->insert;
552 $dbh->rollback if $oldAutoCommit;
553 return "error adding radius_usergroup $newgroup: $error";
559 $error = $new->SUPER::replace($old);
561 $dbh->rollback if $oldAutoCommit;
562 return $error if $error;
565 #false laziness with sub insert (and cust_main)
566 my $queue = new FS::queue {
567 'svcnum' => $new->svcnum,
568 'job' => 'FS::svc_acct::append_fuzzyfiles'
570 $error = $queue->insert($new->username);
572 $dbh->rollback if $oldAutoCommit;
573 return "queueing job (transaction rolled back): $error";
577 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
583 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
584 error, returns the error, otherwise returns false.
586 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
592 my %hash = $self->hash;
593 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
594 || $hash{_password} eq '*'
596 $hash{_password} = '*SUSPENDED* '.$hash{_password};
597 my $new = new FS::svc_acct ( \%hash );
598 my $error = $new->replace($self);
599 return $error if $error;
602 $self->SUPER::suspend;
607 Unsuspends this account by removing *SUSPENDED* from the password. If there is
608 an error, returns the error, otherwise returns false.
610 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
616 my %hash = $self->hash;
617 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
618 $hash{_password} = $1;
619 my $new = new FS::svc_acct ( \%hash );
620 my $error = $new->replace($self);
621 return $error if $error;
624 $self->SUPER::unsuspend;
629 Just returns false (no error) for now.
631 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
635 Checks all fields to make sure this is a valid service. If there is an error,
636 returns the error, otherwise returns false. Called by the insert and replace
639 Sets any fixed values; see L<FS::part_svc>.
646 my($recref) = $self->hashref;
648 my $x = $self->setfixed;
649 return $x unless ref($x);
652 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
654 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
657 my $error = $self->ut_numbern('svcnum')
658 || $self->ut_number('domsvc')
659 || $self->ut_textn('sec_phrase')
661 return $error if $error;
663 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
664 if ( $username_uppercase ) {
665 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
666 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
667 $recref->{username} = $1;
669 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
670 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
671 $recref->{username} = $1;
674 if ( $username_letterfirst ) {
675 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
676 } elsif ( $username_letter ) {
677 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
679 if ( $username_noperiod ) {
680 $recref->{username} =~ /\./ and return gettext('illegal_username');
682 if ( $username_nounderscore ) {
683 $recref->{username} =~ /_/ and return gettext('illegal_username');
685 if ( $username_nodash ) {
686 $recref->{username} =~ /\-/ and return gettext('illegal_username');
688 unless ( $username_ampersand ) {
689 $recref->{username} =~ /\&/ and return gettext('illegal_username');
692 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
693 $recref->{popnum} = $1;
694 return "Unknown popnum" unless
695 ! $recref->{popnum} ||
696 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
698 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
700 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
701 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
703 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
704 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
705 #not all systems use gid=uid
706 #you can set a fixed gid in part_svc
708 return "Only root can have uid 0"
709 if $recref->{uid} == 0
710 && $recref->{username} ne 'root'
711 && $recref->{username} ne 'toor';
714 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
715 or return "Illegal directory: ". $recref->{dir};
717 return "Illegal directory"
718 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
719 return "Illegal directory"
720 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
721 unless ( $recref->{dir} ) {
722 $recref->{dir} = $dir_prefix . '/';
723 if ( $dirhash > 0 ) {
724 for my $h ( 1 .. $dirhash ) {
725 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
727 } elsif ( $dirhash < 0 ) {
728 for my $h ( reverse $dirhash .. -1 ) {
729 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
732 $recref->{dir} .= $recref->{username};
736 unless ( $recref->{username} eq 'sync' ) {
737 if ( grep $_ eq $recref->{shell}, @shells ) {
738 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
740 return "Illegal shell \`". $self->shell. "\'; ".
741 $conf->dir. "/shells contains: @shells";
744 $recref->{shell} = '/bin/sync';
748 $recref->{gid} ne '' ?
749 return "Can't have gid without uid" : ( $recref->{gid}='' );
750 $recref->{dir} ne '' ?
751 return "Can't have directory without uid" : ( $recref->{dir}='' );
752 $recref->{shell} ne '' ?
753 return "Can't have shell without uid" : ( $recref->{shell}='' );
756 # $error = $self->ut_textn('finger');
757 # return $error if $error;
758 $self->getfield('finger') =~
759 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
760 or return "Illegal finger: ". $self->getfield('finger');
761 $self->setfield('finger', $1);
763 $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
764 $recref->{quota} = $1;
766 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
767 unless ( $recref->{slipip} eq '0e0' ) {
768 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
769 or return "Illegal slipip: ". $self->slipip;
770 $recref->{slipip} = $1;
772 $recref->{slipip} = '0e0';
777 #arbitrary RADIUS stuff; allow ut_textn for now
778 foreach ( grep /^radius_/, fields('svc_acct') ) {
782 #generate a password if it is blank
783 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
784 unless ( $recref->{_password} );
786 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
787 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
788 $recref->{_password} = $1.$3;
789 #uncomment this to encrypt password immediately upon entry, or run
790 #bin/crypt_pw in cron to give new users a window during which their
791 #password is available to techs, for faxing, etc. (also be aware of
793 #$recref->{password} = $1.
794 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
796 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,34})$/ ) {
797 $recref->{_password} = $1.$3;
798 } elsif ( $recref->{_password} eq '*' ) {
799 $recref->{_password} = '*';
800 } elsif ( $recref->{_password} eq '!!' ) {
801 $recref->{_password} = '!!';
803 #return "Illegal password";
804 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
805 FS::Msgcat::_gettext('illegal_password_characters').
806 ": ". $recref->{_password};
814 Depriciated, use radius_reply instead.
819 carp "FS::svc_acct::radius depriciated, use radius_reply";
825 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
826 reply attributes of this record.
828 Note that this is now the preferred method for reading RADIUS attributes -
829 accessing the columns directly is discouraged, as the column names are
830 expected to change in the future.
839 my($column, $attrib) = ($1, $2);
840 #$attrib =~ s/_/\-/g;
841 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
842 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
843 if ( $self->slipip && $self->slipip ne '0e0' ) {
844 $reply{'Framed-IP-Address'} = $self->slipip;
851 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
852 check attributes of this record.
854 Note that this is now the preferred method for reading RADIUS attributes -
855 accessing the columns directly is discouraged, as the column names are
856 expected to change in the future.
862 my $password = $self->_password;
863 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
864 ( $pw_attrib => $password,
867 my($column, $attrib) = ($1, $2);
868 #$attrib =~ s/_/\-/g;
869 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
870 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
876 Returns the domain associated with this account.
882 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
883 my $svc_domain = $self->svc_domain
884 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
890 Returns the FS::svc_domain record for this account's domain (see
899 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
904 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
908 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
913 Returns an email address associated with the account.
919 $self->username. '@'. $self->domain;
922 =item seconds_since TIMESTAMP
924 Returns the number of seconds this account has been online since TIMESTAMP,
925 according to the session monitor (see L<FS::Session>).
927 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
928 L<Time::Local> and L<Date::Parse> for conversion functions.
932 #note: POD here, implementation in FS::cust_svc
935 $self->cust_svc->seconds_since(@_);
938 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END DATASRC DB_USERNAME DB_PASSWORD
940 Returns the numbers of seconds this account has been online between
941 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
942 external SQL radacct table, such as those generated by ICRADIUS or FreeRADIUS.
943 Sessions which started in the specified range but are still open are counted
944 from session start to the end of the range. Also, sessions which end in the
945 range but started earlier are counted from the start of the range to session
946 end. Finally, sessions which start before the range but end after (or are
947 still open) are counted for the entire range.
949 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
950 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
955 #note: POD here, implementation in FS::cust_svc
956 sub seconds_since_sqlradacct {
958 $self->cust_svc->seconds_since_sqlradacct(@_);
963 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
969 if ( $self->usergroup ) {
970 #when provisioning records, export callback runs in svc_Common.pm before
971 #radius_usergroup records can be inserted...
974 map { $_->groupname }
975 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
993 use Mail::Internet 1.44;
996 $opt{mimetype} ||= 'text/plain';
997 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
999 $ENV{MAILADDRESS} = $opt{from};
1000 my $header = new Mail::Header ( [
1003 "Sender: $opt{from}",
1004 "Reply-To: $opt{from}",
1005 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1006 "Subject: $opt{subject}",
1007 "Content-Type: $opt{mimetype}",
1009 my $message = new Mail::Internet (
1010 'Header' => $header,
1011 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1014 $message->smtpsend( Host => $smtpmachine )
1015 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1016 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1019 =item check_and_rebuild_fuzzyfiles
1023 sub check_and_rebuild_fuzzyfiles {
1024 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1025 -e "$dir/svc_acct.username"
1026 or &rebuild_fuzzyfiles;
1029 =item rebuild_fuzzyfiles
1033 sub rebuild_fuzzyfiles {
1035 use Fcntl qw(:flock);
1037 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1041 open(USERNAMELOCK,">>$dir/svc_acct.username")
1042 or die "can't open $dir/svc_acct.username: $!";
1043 flock(USERNAMELOCK,LOCK_EX)
1044 or die "can't lock $dir/svc_acct.username: $!";
1046 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1048 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1049 or die "can't open $dir/svc_acct.username.tmp: $!";
1050 print USERNAMECACHE join("\n", @all_username), "\n";
1051 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1053 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1063 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1064 open(USERNAMECACHE,"<$dir/svc_acct.username")
1065 or die "can't open $dir/svc_acct.username: $!";
1066 my @array = map { chomp; $_; } <USERNAMECACHE>;
1067 close USERNAMECACHE;
1071 =item append_fuzzyfiles USERNAME
1075 sub append_fuzzyfiles {
1076 my $username = shift;
1078 &check_and_rebuild_fuzzyfiles;
1080 use Fcntl qw(:flock);
1082 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1084 open(USERNAME,">>$dir/svc_acct.username")
1085 or die "can't open $dir/svc_acct.username: $!";
1086 flock(USERNAME,LOCK_EX)
1087 or die "can't lock $dir/svc_acct.username: $!";
1089 print USERNAME "$username\n";
1091 flock(USERNAME,LOCK_UN)
1092 or die "can't unlock $dir/svc_acct.username: $!";
1100 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1104 sub radius_usergroup_selector {
1105 my $sel_groups = shift;
1106 my %sel_groups = map { $_=>1 } @$sel_groups;
1108 my $selectname = shift || 'radius_usergroup';
1111 my $sth = $dbh->prepare(
1112 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1113 ) or die $dbh->errstr;
1114 $sth->execute() or die $sth->errstr;
1115 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1119 function ${selectname}_doadd(object) {
1120 var myvalue = object.${selectname}_add.value;
1121 var optionName = new Option(myvalue,myvalue,false,true);
1122 var length = object.$selectname.length;
1123 object.$selectname.options[length] = optionName;
1124 object.${selectname}_add.value = "";
1127 <SELECT MULTIPLE NAME="$selectname">
1130 foreach my $group ( @all_groups ) {
1132 if ( $sel_groups{$group} ) {
1133 $html .= ' SELECTED';
1134 $sel_groups{$group} = 0;
1136 $html .= ">$group</OPTION>\n";
1138 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1139 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1141 $html .= '</SELECT>';
1143 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1144 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1153 The $recref stuff in sub check should be cleaned up.
1155 The suspend, unsuspend and cancel methods update the database, but not the
1156 current object. This is probably a bug as it's unexpected and
1159 radius_usergroup_selector? putting web ui components in here? they should
1160 probably live somewhere else...
1164 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1165 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1166 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1167 L<freeside-queued>), L<FS::svc_acct_pop>,
1168 schema.html from the base documentation.