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 if ( $new->username ne $old->username ) {
566 #false laziness with sub insert (and cust_main)
567 my $queue = new FS::queue {
568 'svcnum' => $new->svcnum,
569 'job' => 'FS::svc_acct::append_fuzzyfiles'
571 $error = $queue->insert($new->username);
573 $dbh->rollback if $oldAutoCommit;
574 return "queueing job (transaction rolled back): $error";
578 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
584 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
585 error, returns the error, otherwise returns false.
587 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
593 my %hash = $self->hash;
594 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
595 || $hash{_password} eq '*'
597 $hash{_password} = '*SUSPENDED* '.$hash{_password};
598 my $new = new FS::svc_acct ( \%hash );
599 my $error = $new->replace($self);
600 return $error if $error;
603 $self->SUPER::suspend;
608 Unsuspends this account by removing *SUSPENDED* from the password. If there is
609 an error, returns the error, otherwise returns false.
611 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
617 my %hash = $self->hash;
618 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
619 $hash{_password} = $1;
620 my $new = new FS::svc_acct ( \%hash );
621 my $error = $new->replace($self);
622 return $error if $error;
625 $self->SUPER::unsuspend;
630 Just returns false (no error) for now.
632 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
636 Checks all fields to make sure this is a valid service. If there is an error,
637 returns the error, otherwise returns false. Called by the insert and replace
640 Sets any fixed values; see L<FS::part_svc>.
647 my($recref) = $self->hashref;
649 my $x = $self->setfixed;
650 return $x unless ref($x);
653 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
655 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
658 my $error = $self->ut_numbern('svcnum')
659 || $self->ut_number('domsvc')
660 || $self->ut_textn('sec_phrase')
662 return $error if $error;
664 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
665 if ( $username_uppercase ) {
666 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
667 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
668 $recref->{username} = $1;
670 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
671 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
672 $recref->{username} = $1;
675 if ( $username_letterfirst ) {
676 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
677 } elsif ( $username_letter ) {
678 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
680 if ( $username_noperiod ) {
681 $recref->{username} =~ /\./ and return gettext('illegal_username');
683 if ( $username_nounderscore ) {
684 $recref->{username} =~ /_/ and return gettext('illegal_username');
686 if ( $username_nodash ) {
687 $recref->{username} =~ /\-/ and return gettext('illegal_username');
689 unless ( $username_ampersand ) {
690 $recref->{username} =~ /\&/ and return gettext('illegal_username');
693 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
694 $recref->{popnum} = $1;
695 return "Unknown popnum" unless
696 ! $recref->{popnum} ||
697 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
699 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
701 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
702 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
704 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
705 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
706 #not all systems use gid=uid
707 #you can set a fixed gid in part_svc
709 return "Only root can have uid 0"
710 if $recref->{uid} == 0
711 && $recref->{username} ne 'root'
712 && $recref->{username} ne 'toor';
715 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
716 or return "Illegal directory: ". $recref->{dir};
718 return "Illegal directory"
719 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
720 return "Illegal directory"
721 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
722 unless ( $recref->{dir} ) {
723 $recref->{dir} = $dir_prefix . '/';
724 if ( $dirhash > 0 ) {
725 for my $h ( 1 .. $dirhash ) {
726 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
728 } elsif ( $dirhash < 0 ) {
729 for my $h ( reverse $dirhash .. -1 ) {
730 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
733 $recref->{dir} .= $recref->{username};
737 unless ( $recref->{username} eq 'sync' ) {
738 if ( grep $_ eq $recref->{shell}, @shells ) {
739 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
741 return "Illegal shell \`". $self->shell. "\'; ".
742 $conf->dir. "/shells contains: @shells";
745 $recref->{shell} = '/bin/sync';
749 $recref->{gid} ne '' ?
750 return "Can't have gid without uid" : ( $recref->{gid}='' );
751 $recref->{dir} ne '' ?
752 return "Can't have directory without uid" : ( $recref->{dir}='' );
753 $recref->{shell} ne '' ?
754 return "Can't have shell without uid" : ( $recref->{shell}='' );
757 # $error = $self->ut_textn('finger');
758 # return $error if $error;
759 $self->getfield('finger') =~
760 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
761 or return "Illegal finger: ". $self->getfield('finger');
762 $self->setfield('finger', $1);
764 $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
765 $recref->{quota} = $1;
767 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
768 unless ( $recref->{slipip} eq '0e0' ) {
769 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
770 or return "Illegal slipip: ". $self->slipip;
771 $recref->{slipip} = $1;
773 $recref->{slipip} = '0e0';
778 #arbitrary RADIUS stuff; allow ut_textn for now
779 foreach ( grep /^radius_/, fields('svc_acct') ) {
783 #generate a password if it is blank
784 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
785 unless ( $recref->{_password} );
787 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
788 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
789 $recref->{_password} = $1.$3;
790 #uncomment this to encrypt password immediately upon entry, or run
791 #bin/crypt_pw in cron to give new users a window during which their
792 #password is available to techs, for faxing, etc. (also be aware of
794 #$recref->{password} = $1.
795 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
797 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,34})$/ ) {
798 $recref->{_password} = $1.$3;
799 } elsif ( $recref->{_password} eq '*' ) {
800 $recref->{_password} = '*';
801 } elsif ( $recref->{_password} eq '!!' ) {
802 $recref->{_password} = '!!';
804 #return "Illegal password";
805 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
806 FS::Msgcat::_gettext('illegal_password_characters').
807 ": ". $recref->{_password};
815 Depriciated, use radius_reply instead.
820 carp "FS::svc_acct::radius depriciated, use radius_reply";
826 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
827 reply attributes of this record.
829 Note that this is now the preferred method for reading RADIUS attributes -
830 accessing the columns directly is discouraged, as the column names are
831 expected to change in the future.
840 my($column, $attrib) = ($1, $2);
841 #$attrib =~ s/_/\-/g;
842 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
843 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
844 if ( $self->slipip && $self->slipip ne '0e0' ) {
845 $reply{'Framed-IP-Address'} = $self->slipip;
852 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
853 check attributes of this record.
855 Note that this is now the preferred method for reading RADIUS attributes -
856 accessing the columns directly is discouraged, as the column names are
857 expected to change in the future.
863 my $password = $self->_password;
864 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
865 ( $pw_attrib => $password,
868 my($column, $attrib) = ($1, $2);
869 #$attrib =~ s/_/\-/g;
870 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
871 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
877 Returns the domain associated with this account.
883 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
884 my $svc_domain = $self->svc_domain
885 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
891 Returns the FS::svc_domain record for this account's domain (see
900 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
905 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
909 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
914 Returns an email address associated with the account.
920 $self->username. '@'. $self->domain;
923 =item seconds_since TIMESTAMP
925 Returns the number of seconds this account has been online since TIMESTAMP,
926 according to the session monitor (see L<FS::Session>).
928 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
929 L<Time::Local> and L<Date::Parse> for conversion functions.
933 #note: POD here, implementation in FS::cust_svc
936 $self->cust_svc->seconds_since(@_);
939 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
941 Returns the numbers of seconds this account has been online between
942 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
943 external SQL radacct table, specified via sqlradius export. Sessions which
944 started in the specified range but are still open are counted from session
945 start to the end of the range (unless they are over 1 day old, in which case
946 they are presumed missing their stop record and not counted). Also, sessions
947 which end in therange but started earlier are counted from the start of the
948 range to session end. Finally, sessions which start before the range but end
949 after are counted for the entire range.
951 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
952 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
957 #note: POD here, implementation in FS::cust_svc
958 sub seconds_since_sqlradacct {
960 $self->cust_svc->seconds_since_sqlradacct(@_);
963 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
965 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
966 in this package for sessions ending between TIMESTAMP_START (inclusive) and
967 TIMESTAMP_END (exclusive).
969 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
970 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
975 #note: POD here, implementation in FS::cust_svc
976 sub attribute_since_sqlradacct {
978 $self->cust_svc->attribute_since_sqlradacct(@_);
983 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
989 if ( $self->usergroup ) {
990 #when provisioning records, export callback runs in svc_Common.pm before
991 #radius_usergroup records can be inserted...
994 map { $_->groupname }
995 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1013 use Mail::Internet 1.44;
1016 $opt{mimetype} ||= 'text/plain';
1017 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1019 $ENV{MAILADDRESS} = $opt{from};
1020 my $header = new Mail::Header ( [
1023 "Sender: $opt{from}",
1024 "Reply-To: $opt{from}",
1025 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1026 "Subject: $opt{subject}",
1027 "Content-Type: $opt{mimetype}",
1029 my $message = new Mail::Internet (
1030 'Header' => $header,
1031 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1034 $message->smtpsend( Host => $smtpmachine )
1035 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1036 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1039 =item check_and_rebuild_fuzzyfiles
1043 sub check_and_rebuild_fuzzyfiles {
1044 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1045 -e "$dir/svc_acct.username"
1046 or &rebuild_fuzzyfiles;
1049 =item rebuild_fuzzyfiles
1053 sub rebuild_fuzzyfiles {
1055 use Fcntl qw(:flock);
1057 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1061 open(USERNAMELOCK,">>$dir/svc_acct.username")
1062 or die "can't open $dir/svc_acct.username: $!";
1063 flock(USERNAMELOCK,LOCK_EX)
1064 or die "can't lock $dir/svc_acct.username: $!";
1066 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1068 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1069 or die "can't open $dir/svc_acct.username.tmp: $!";
1070 print USERNAMECACHE join("\n", @all_username), "\n";
1071 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1073 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1083 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1084 open(USERNAMECACHE,"<$dir/svc_acct.username")
1085 or die "can't open $dir/svc_acct.username: $!";
1086 my @array = map { chomp; $_; } <USERNAMECACHE>;
1087 close USERNAMECACHE;
1091 =item append_fuzzyfiles USERNAME
1095 sub append_fuzzyfiles {
1096 my $username = shift;
1098 &check_and_rebuild_fuzzyfiles;
1100 use Fcntl qw(:flock);
1102 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1104 open(USERNAME,">>$dir/svc_acct.username")
1105 or die "can't open $dir/svc_acct.username: $!";
1106 flock(USERNAME,LOCK_EX)
1107 or die "can't lock $dir/svc_acct.username: $!";
1109 print USERNAME "$username\n";
1111 flock(USERNAME,LOCK_UN)
1112 or die "can't unlock $dir/svc_acct.username: $!";
1120 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1124 sub radius_usergroup_selector {
1125 my $sel_groups = shift;
1126 my %sel_groups = map { $_=>1 } @$sel_groups;
1128 my $selectname = shift || 'radius_usergroup';
1131 my $sth = $dbh->prepare(
1132 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1133 ) or die $dbh->errstr;
1134 $sth->execute() or die $sth->errstr;
1135 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1139 function ${selectname}_doadd(object) {
1140 var myvalue = object.${selectname}_add.value;
1141 var optionName = new Option(myvalue,myvalue,false,true);
1142 var length = object.$selectname.length;
1143 object.$selectname.options[length] = optionName;
1144 object.${selectname}_add.value = "";
1147 <SELECT MULTIPLE NAME="$selectname">
1150 foreach my $group ( @all_groups ) {
1152 if ( $sel_groups{$group} ) {
1153 $html .= ' SELECTED';
1154 $sel_groups{$group} = 0;
1156 $html .= ">$group</OPTION>\n";
1158 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1159 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1161 $html .= '</SELECT>';
1163 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1164 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1173 The $recref stuff in sub check should be cleaned up.
1175 The suspend, unsuspend and cancel methods update the database, but not the
1176 current object. This is probably a bug as it's unexpected and
1179 radius_usergroup_selector? putting web ui components in here? they should
1180 probably live somewhere else...
1184 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1185 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1186 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1187 L<freeside-queued>), L<FS::svc_acct_pop>,
1188 schema.html from the base documentation.