4 use vars qw( @ISA $DEBUG $me $conf
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
10 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
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 );
36 $me = '[FS::svc_acct]';
38 #ask FS::UID to run this stuff for us later
39 $FS::UID::callback{'FS::svc_acct'} = sub {
41 $dir_prefix = $conf->config('home');
42 @shells = $conf->config('shells');
43 $usernamemin = $conf->config('usernamemin') || 2;
44 $usernamemax = $conf->config('usernamemax');
45 $passwordmin = $conf->config('passwordmin') || 6;
46 $passwordmax = $conf->config('passwordmax') || 8;
47 $username_letter = $conf->exists('username-letter');
48 $username_letterfirst = $conf->exists('username-letterfirst');
49 $username_noperiod = $conf->exists('username-noperiod');
50 $username_nounderscore = $conf->exists('username-nounderscore');
51 $username_nodash = $conf->exists('username-nodash');
52 $username_uppercase = $conf->exists('username-uppercase');
53 $username_ampersand = $conf->exists('username-ampersand');
54 $dirhash = $conf->config('dirhash') || 0;
55 if ( $conf->exists('welcome_email') ) {
56 $welcome_template = new Text::Template (
58 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
59 ) or warn "can't create welcome email template: $Text::Template::ERROR";
60 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
61 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
62 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
64 $welcome_template = '';
66 $welcome_subject = '';
67 $welcome_mimetype = '';
69 $smtpmachine = $conf->config('smtpmachine');
70 $radius_password = $conf->config('radius-password') || 'Password';
73 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
74 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
78 my ( $hashref, $cache ) = @_;
79 if ( $hashref->{'svc_acct_svcnum'} ) {
80 $self->{'_domsvc'} = FS::svc_domain->new( {
81 'svcnum' => $hashref->{'domsvc'},
82 'domain' => $hashref->{'svc_acct_domain'},
83 'catchall' => $hashref->{'svc_acct_catchall'},
90 FS::svc_acct - Object methods for svc_acct records
96 $record = new FS::svc_acct \%hash;
97 $record = new FS::svc_acct { 'column' => 'value' };
99 $error = $record->insert;
101 $error = $new_record->replace($old_record);
103 $error = $record->delete;
105 $error = $record->check;
107 $error = $record->suspend;
109 $error = $record->unsuspend;
111 $error = $record->cancel;
113 %hash = $record->radius;
115 %hash = $record->radius_reply;
117 %hash = $record->radius_check;
119 $domain = $record->domain;
121 $svc_domain = $record->svc_domain;
123 $email = $record->email;
125 $seconds_since = $record->seconds_since($timestamp);
129 An FS::svc_acct object represents an account. FS::svc_acct inherits from
130 FS::svc_Common. The following fields are currently supported:
134 =item svcnum - primary key (assigned automatcially for new accounts)
138 =item _password - generated if blank
140 =item sec_phrase - security phrase
142 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
150 =item dir - set automatically if blank (and uid is not)
154 =item quota - (unimplementd)
156 =item slipip - IP address
160 =item domsvc - svcnum from svc_domain
162 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
172 Creates a new account. To add the account to the database, see L<"insert">.
176 sub table { 'svc_acct'; }
180 Adds this account to the database. If there is an error, returns the error,
181 otherwise returns false.
183 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
184 defined. An FS::cust_svc record will be created and inserted.
186 The additional field I<usergroup> can optionally be defined; if so it should
187 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
188 sqlradius export only)
190 (TODOC: L<FS::queue> and L<freeside-queued>)
192 (TODOC: new exports!)
200 local $SIG{HUP} = 'IGNORE';
201 local $SIG{INT} = 'IGNORE';
202 local $SIG{QUIT} = 'IGNORE';
203 local $SIG{TERM} = 'IGNORE';
204 local $SIG{TSTP} = 'IGNORE';
205 local $SIG{PIPE} = 'IGNORE';
207 my $oldAutoCommit = $FS::UID::AutoCommit;
208 local $FS::UID::AutoCommit = 0;
211 $error = $self->check;
212 return $error if $error;
214 #no, duplicate checking just got a whole lot more complicated
215 #(perhaps keep this check with a config option to turn on?)
217 #return gettext('username_in_use'). ": ". $self->username
218 # if qsearchs( 'svc_acct', { 'username' => $self->username,
219 # 'domsvc' => $self->domsvc,
222 if ( $self->svcnum ) {
223 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
224 unless ( $cust_svc ) {
225 $dbh->rollback if $oldAutoCommit;
226 return "no cust_svc record found for svcnum ". $self->svcnum;
228 $self->pkgnum($cust_svc->pkgnum);
229 $self->svcpart($cust_svc->svcpart);
232 #new duplicate username checking
234 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
235 unless ( $part_svc ) {
236 $dbh->rollback if $oldAutoCommit;
237 return 'unknown svcpart '. $self->svcpart;
240 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
241 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
242 'domsvc' => $self->domsvc } );
244 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
245 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
246 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
251 if ( @dup_user || @dup_userdomain || @dup_uid ) {
252 my $exports = FS::part_export::export_info('svc_acct');
253 my %conflict_user_svcpart;
254 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
256 foreach my $part_export ( $part_svc->part_export ) {
258 #this will catch to the same exact export
259 my @svcparts = map { $_->svcpart }
260 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
262 #this will catch to exports w/same exporthost+type ???
263 #my @other_part_export = qsearch('part_export', {
264 # 'machine' => $part_export->machine,
265 # 'exporttype' => $part_export->exporttype,
267 #foreach my $other_part_export ( @other_part_export ) {
268 # push @svcparts, map { $_->svcpart }
269 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
272 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
273 #silly kludge to avoid uninitialized value errors
274 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
275 ? $exports->{$part_export->exporttype}{'nodomain'}
277 if ( $nodomain =~ /^Y/i ) {
278 $conflict_user_svcpart{$_} = $part_export->exportnum
281 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
286 foreach my $dup_user ( @dup_user ) {
287 my $dup_svcpart = $dup_user->cust_svc->svcpart;
288 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
289 $dbh->rollback if $oldAutoCommit;
290 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
291 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
295 foreach my $dup_userdomain ( @dup_userdomain ) {
296 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
297 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
298 $dbh->rollback if $oldAutoCommit;
299 return "duplicate username\@domain: conflicts with svcnum ".
300 $dup_userdomain->svcnum. " via exportnum ".
301 $conflict_userdomain_svcpart{$dup_svcpart};
305 foreach my $dup_uid ( @dup_uid ) {
306 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
307 if ( exists($conflict_user_svcpart{$dup_svcpart})
308 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
309 $dbh->rollback if $oldAutoCommit;
310 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
311 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
312 || $conflict_userdomain_svcpart{$dup_svcpart};
318 #see? i told you it was more complicated
321 $error = $self->SUPER::insert(\@jobnums);
323 $dbh->rollback if $oldAutoCommit;
327 if ( $self->usergroup ) {
328 foreach my $groupname ( @{$self->usergroup} ) {
329 my $radius_usergroup = new FS::radius_usergroup ( {
330 svcnum => $self->svcnum,
331 groupname => $groupname,
333 my $error = $radius_usergroup->insert;
335 $dbh->rollback if $oldAutoCommit;
341 #false laziness with sub replace (and cust_main)
342 my $queue = new FS::queue {
343 'svcnum' => $self->svcnum,
344 'job' => 'FS::svc_acct::append_fuzzyfiles'
346 $error = $queue->insert($self->username);
348 $dbh->rollback if $oldAutoCommit;
349 return "queueing job (transaction rolled back): $error";
352 my $cust_pkg = $self->cust_svc->cust_pkg;
355 my $cust_main = $cust_pkg->cust_main;
357 if ( $conf->exists('emailinvoiceauto') ) {
358 my @invoicing_list = $cust_main->invoicing_list;
359 push @invoicing_list, $self->email;
360 $cust_main->invoicing_list(\@invoicing_list);
365 if ( $welcome_template && $cust_pkg ) {
366 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
368 my $wqueue = new FS::queue {
369 'svcnum' => $self->svcnum,
370 'job' => 'FS::svc_acct::send_email'
372 my $error = $wqueue->insert(
374 'from' => $welcome_from,
375 'subject' => $welcome_subject,
376 'mimetype' => $welcome_mimetype,
377 'body' => $welcome_template->fill_in( HASH => {
378 'custnum' => $self->custnum,
379 'username' => $self->username,
380 'password' => $self->_password,
381 'first' => $cust_main->first,
382 'last' => $cust_main->getfield('last'),
383 'pkg' => $cust_pkg->part_pkg->pkg,
387 $dbh->rollback if $oldAutoCommit;
388 return "error queuing welcome email: $error";
391 foreach my $jobnum ( @jobnums ) {
392 my $error = $wqueue->depend_insert($jobnum);
394 $dbh->rollback if $oldAutoCommit;
395 return "error queuing welcome email job dependancy: $error";
405 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
411 Deletes this account from the database. If there is an error, returns the
412 error, otherwise returns false.
414 The corresponding FS::cust_svc record will be deleted as well.
416 (TODOC: new exports!)
423 return "Can't delete an account which is a (svc_forward) source!"
424 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
426 return "Can't delete an account which is a (svc_forward) destination!"
427 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
429 return "Can't delete an account with (svc_www) web service!"
430 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
432 # what about records in session ? (they should refer to history table)
434 local $SIG{HUP} = 'IGNORE';
435 local $SIG{INT} = 'IGNORE';
436 local $SIG{QUIT} = 'IGNORE';
437 local $SIG{TERM} = 'IGNORE';
438 local $SIG{TSTP} = 'IGNORE';
439 local $SIG{PIPE} = 'IGNORE';
441 my $oldAutoCommit = $FS::UID::AutoCommit;
442 local $FS::UID::AutoCommit = 0;
445 foreach my $cust_main_invoice (
446 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
448 unless ( defined($cust_main_invoice) ) {
449 warn "WARNING: something's wrong with qsearch";
452 my %hash = $cust_main_invoice->hash;
453 $hash{'dest'} = $self->email;
454 my $new = new FS::cust_main_invoice \%hash;
455 my $error = $new->replace($cust_main_invoice);
457 $dbh->rollback if $oldAutoCommit;
462 foreach my $svc_domain (
463 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
465 my %hash = new FS::svc_domain->hash;
466 $hash{'catchall'} = '';
467 my $new = new FS::svc_domain \%hash;
468 my $error = $new->replace($svc_domain);
470 $dbh->rollback if $oldAutoCommit;
475 foreach my $radius_usergroup (
476 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
478 my $error = $radius_usergroup->delete;
480 $dbh->rollback if $oldAutoCommit;
485 my $error = $self->SUPER::delete;
487 $dbh->rollback if $oldAutoCommit;
491 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
495 =item replace OLD_RECORD
497 Replaces OLD_RECORD with this one in the database. If there is an error,
498 returns the error, otherwise returns false.
500 The additional field I<usergroup> can optionally be defined; if so it should
501 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
502 sqlradius export only)
507 my ( $new, $old ) = ( shift, shift );
509 warn "$me replacing $old with $new\n" if $DEBUG;
511 return "Username in use"
512 if $old->username ne $new->username &&
513 qsearchs( 'svc_acct', { 'username' => $new->username,
514 'domsvc' => $new->domsvc,
517 #no warnings 'numeric'; #alas, a 5.006-ism
519 return "Can't change uid!" if $old->uid != $new->uid;
522 #change homdir when we change username
523 $new->setfield('dir', '') if $old->username ne $new->username;
525 local $SIG{HUP} = 'IGNORE';
526 local $SIG{INT} = 'IGNORE';
527 local $SIG{QUIT} = 'IGNORE';
528 local $SIG{TERM} = 'IGNORE';
529 local $SIG{TSTP} = 'IGNORE';
530 local $SIG{PIPE} = 'IGNORE';
532 my $oldAutoCommit = $FS::UID::AutoCommit;
533 local $FS::UID::AutoCommit = 0;
536 # redundant, but so $new->usergroup gets set
537 $error = $new->check;
538 return $error if $error;
540 $old->usergroup( [ $old->radius_groups ] );
541 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
542 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
543 if ( $new->usergroup ) {
544 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
545 my @newgroups = @{$new->usergroup};
546 foreach my $oldgroup ( @{$old->usergroup} ) {
547 if ( grep { $oldgroup eq $_ } @newgroups ) {
548 @newgroups = grep { $oldgroup ne $_ } @newgroups;
551 my $radius_usergroup = qsearchs('radius_usergroup', {
552 svcnum => $old->svcnum,
553 groupname => $oldgroup,
555 my $error = $radius_usergroup->delete;
557 $dbh->rollback if $oldAutoCommit;
558 return "error deleting radius_usergroup $oldgroup: $error";
562 foreach my $newgroup ( @newgroups ) {
563 my $radius_usergroup = new FS::radius_usergroup ( {
564 svcnum => $new->svcnum,
565 groupname => $newgroup,
567 my $error = $radius_usergroup->insert;
569 $dbh->rollback if $oldAutoCommit;
570 return "error adding radius_usergroup $newgroup: $error";
576 $error = $new->SUPER::replace($old);
578 $dbh->rollback if $oldAutoCommit;
579 return $error if $error;
582 if ( $new->username ne $old->username ) {
583 #false laziness with sub insert (and cust_main)
584 my $queue = new FS::queue {
585 'svcnum' => $new->svcnum,
586 'job' => 'FS::svc_acct::append_fuzzyfiles'
588 $error = $queue->insert($new->username);
590 $dbh->rollback if $oldAutoCommit;
591 return "queueing job (transaction rolled back): $error";
595 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
601 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
602 error, returns the error, otherwise returns false.
604 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
610 my %hash = $self->hash;
611 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
612 || $hash{_password} eq '*'
614 $hash{_password} = '*SUSPENDED* '.$hash{_password};
615 my $new = new FS::svc_acct ( \%hash );
616 my $error = $new->replace($self);
617 return $error if $error;
620 $self->SUPER::suspend;
625 Unsuspends this account by removing *SUSPENDED* from the password. If there is
626 an error, returns the error, otherwise returns false.
628 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
634 my %hash = $self->hash;
635 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
636 $hash{_password} = $1;
637 my $new = new FS::svc_acct ( \%hash );
638 my $error = $new->replace($self);
639 return $error if $error;
642 $self->SUPER::unsuspend;
647 Just returns false (no error) for now.
649 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
653 Checks all fields to make sure this is a valid service. If there is an error,
654 returns the error, otherwise returns false. Called by the insert and replace
657 Sets any fixed values; see L<FS::part_svc>.
664 my($recref) = $self->hashref;
666 my $x = $self->setfixed;
667 return $x unless ref($x);
670 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
672 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
675 my $error = $self->ut_numbern('svcnum')
676 #|| $self->ut_number('domsvc')
677 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
678 || $self->ut_textn('sec_phrase')
680 return $error if $error;
682 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
683 if ( $username_uppercase ) {
684 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
685 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
686 $recref->{username} = $1;
688 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
689 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
690 $recref->{username} = $1;
693 if ( $username_letterfirst ) {
694 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
695 } elsif ( $username_letter ) {
696 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
698 if ( $username_noperiod ) {
699 $recref->{username} =~ /\./ and return gettext('illegal_username');
701 if ( $username_nounderscore ) {
702 $recref->{username} =~ /_/ and return gettext('illegal_username');
704 if ( $username_nodash ) {
705 $recref->{username} =~ /\-/ and return gettext('illegal_username');
707 unless ( $username_ampersand ) {
708 $recref->{username} =~ /\&/ and return gettext('illegal_username');
711 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
712 $recref->{popnum} = $1;
713 return "Unknown popnum" unless
714 ! $recref->{popnum} ||
715 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
717 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
719 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
720 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
722 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
723 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
724 #not all systems use gid=uid
725 #you can set a fixed gid in part_svc
727 return "Only root can have uid 0"
728 if $recref->{uid} == 0
729 && $recref->{username} ne 'root'
730 && $recref->{username} ne 'toor';
733 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
734 or return "Illegal directory: ". $recref->{dir};
736 return "Illegal directory"
737 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
738 return "Illegal directory"
739 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
740 unless ( $recref->{dir} ) {
741 $recref->{dir} = $dir_prefix . '/';
742 if ( $dirhash > 0 ) {
743 for my $h ( 1 .. $dirhash ) {
744 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
746 } elsif ( $dirhash < 0 ) {
747 for my $h ( reverse $dirhash .. -1 ) {
748 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
751 $recref->{dir} .= $recref->{username};
755 unless ( $recref->{username} eq 'sync' ) {
756 if ( grep $_ eq $recref->{shell}, @shells ) {
757 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
759 return "Illegal shell \`". $self->shell. "\'; ".
760 $conf->dir. "/shells contains: @shells";
763 $recref->{shell} = '/bin/sync';
767 $recref->{gid} ne '' ?
768 return "Can't have gid without uid" : ( $recref->{gid}='' );
769 $recref->{dir} ne '' ?
770 return "Can't have directory without uid" : ( $recref->{dir}='' );
771 $recref->{shell} ne '' ?
772 return "Can't have shell without uid" : ( $recref->{shell}='' );
775 # $error = $self->ut_textn('finger');
776 # return $error if $error;
777 $self->getfield('finger') =~
778 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
779 or return "Illegal finger: ". $self->getfield('finger');
780 $self->setfield('finger', $1);
782 $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
783 $recref->{quota} = $1;
785 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
786 unless ( $recref->{slipip} eq '0e0' ) {
787 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
788 or return "Illegal slipip: ". $self->slipip;
789 $recref->{slipip} = $1;
791 $recref->{slipip} = '0e0';
796 #arbitrary RADIUS stuff; allow ut_textn for now
797 foreach ( grep /^radius_/, fields('svc_acct') ) {
801 #generate a password if it is blank
802 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
803 unless ( $recref->{_password} );
805 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
806 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
807 $recref->{_password} = $1.$3;
808 #uncomment this to encrypt password immediately upon entry, or run
809 #bin/crypt_pw in cron to give new users a window during which their
810 #password is available to techs, for faxing, etc. (also be aware of
812 #$recref->{password} = $1.
813 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
815 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,34})$/ ) {
816 $recref->{_password} = $1.$3;
817 } elsif ( $recref->{_password} eq '*' ) {
818 $recref->{_password} = '*';
819 } elsif ( $recref->{_password} eq '!!' ) {
820 $recref->{_password} = '!!';
822 #return "Illegal password";
823 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
824 FS::Msgcat::_gettext('illegal_password_characters').
825 ": ". $recref->{_password};
833 Depriciated, use radius_reply instead.
838 carp "FS::svc_acct::radius depriciated, use radius_reply";
844 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
845 reply attributes of this record.
847 Note that this is now the preferred method for reading RADIUS attributes -
848 accessing the columns directly is discouraged, as the column names are
849 expected to change in the future.
858 my($column, $attrib) = ($1, $2);
859 #$attrib =~ s/_/\-/g;
860 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
861 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
862 if ( $self->slipip && $self->slipip ne '0e0' ) {
863 $reply{'Framed-IP-Address'} = $self->slipip;
870 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
871 check attributes of this record.
873 Note that this is now the preferred method for reading RADIUS attributes -
874 accessing the columns directly is discouraged, as the column names are
875 expected to change in the future.
881 my $password = $self->_password;
882 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
883 ( $pw_attrib => $password,
886 my($column, $attrib) = ($1, $2);
887 #$attrib =~ s/_/\-/g;
888 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
889 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
895 Returns the domain associated with this account.
901 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
902 my $svc_domain = $self->svc_domain
903 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
909 Returns the FS::svc_domain record for this account's domain (see
918 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
923 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
927 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
932 Returns an email address associated with the account.
938 $self->username. '@'. $self->domain;
941 =item seconds_since TIMESTAMP
943 Returns the number of seconds this account has been online since TIMESTAMP,
944 according to the session monitor (see L<FS::Session>).
946 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
947 L<Time::Local> and L<Date::Parse> for conversion functions.
951 #note: POD here, implementation in FS::cust_svc
954 $self->cust_svc->seconds_since(@_);
957 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
959 Returns the numbers of seconds this account has been online between
960 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
961 external SQL radacct table, specified via sqlradius export. Sessions which
962 started in the specified range but are still open are counted from session
963 start to the end of the range (unless they are over 1 day old, in which case
964 they are presumed missing their stop record and not counted). Also, sessions
965 which end in therange but started earlier are counted from the start of the
966 range to session end. Finally, sessions which start before the range but end
967 after are counted for the entire range.
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 seconds_since_sqlradacct {
978 $self->cust_svc->seconds_since_sqlradacct(@_);
981 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
983 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
984 in this package for sessions ending between TIMESTAMP_START (inclusive) and
985 TIMESTAMP_END (exclusive).
987 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
988 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
993 #note: POD here, implementation in FS::cust_svc
994 sub attribute_since_sqlradacct {
996 $self->cust_svc->attribute_since_sqlradacct(@_);
1001 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1007 if ( $self->usergroup ) {
1008 #when provisioning records, export callback runs in svc_Common.pm before
1009 #radius_usergroup records can be inserted...
1010 @{$self->usergroup};
1012 map { $_->groupname }
1013 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1031 use Mail::Internet 1.44;
1034 $opt{mimetype} ||= 'text/plain';
1035 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1037 $ENV{MAILADDRESS} = $opt{from};
1038 my $header = new Mail::Header ( [
1041 "Sender: $opt{from}",
1042 "Reply-To: $opt{from}",
1043 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1044 "Subject: $opt{subject}",
1045 "Content-Type: $opt{mimetype}",
1047 my $message = new Mail::Internet (
1048 'Header' => $header,
1049 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1052 $message->smtpsend( Host => $smtpmachine )
1053 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1054 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1057 =item check_and_rebuild_fuzzyfiles
1061 sub check_and_rebuild_fuzzyfiles {
1062 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1063 -e "$dir/svc_acct.username"
1064 or &rebuild_fuzzyfiles;
1067 =item rebuild_fuzzyfiles
1071 sub rebuild_fuzzyfiles {
1073 use Fcntl qw(:flock);
1075 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1079 open(USERNAMELOCK,">>$dir/svc_acct.username")
1080 or die "can't open $dir/svc_acct.username: $!";
1081 flock(USERNAMELOCK,LOCK_EX)
1082 or die "can't lock $dir/svc_acct.username: $!";
1084 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1086 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1087 or die "can't open $dir/svc_acct.username.tmp: $!";
1088 print USERNAMECACHE join("\n", @all_username), "\n";
1089 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1091 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1101 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1102 open(USERNAMECACHE,"<$dir/svc_acct.username")
1103 or die "can't open $dir/svc_acct.username: $!";
1104 my @array = map { chomp; $_; } <USERNAMECACHE>;
1105 close USERNAMECACHE;
1109 =item append_fuzzyfiles USERNAME
1113 sub append_fuzzyfiles {
1114 my $username = shift;
1116 &check_and_rebuild_fuzzyfiles;
1118 use Fcntl qw(:flock);
1120 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1122 open(USERNAME,">>$dir/svc_acct.username")
1123 or die "can't open $dir/svc_acct.username: $!";
1124 flock(USERNAME,LOCK_EX)
1125 or die "can't lock $dir/svc_acct.username: $!";
1127 print USERNAME "$username\n";
1129 flock(USERNAME,LOCK_UN)
1130 or die "can't unlock $dir/svc_acct.username: $!";
1138 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1142 sub radius_usergroup_selector {
1143 my $sel_groups = shift;
1144 my %sel_groups = map { $_=>1 } @$sel_groups;
1146 my $selectname = shift || 'radius_usergroup';
1149 my $sth = $dbh->prepare(
1150 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1151 ) or die $dbh->errstr;
1152 $sth->execute() or die $sth->errstr;
1153 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1157 function ${selectname}_doadd(object) {
1158 var myvalue = object.${selectname}_add.value;
1159 var optionName = new Option(myvalue,myvalue,false,true);
1160 var length = object.$selectname.length;
1161 object.$selectname.options[length] = optionName;
1162 object.${selectname}_add.value = "";
1165 <SELECT MULTIPLE NAME="$selectname">
1168 foreach my $group ( @all_groups ) {
1170 if ( $sel_groups{$group} ) {
1171 $html .= ' SELECTED';
1172 $sel_groups{$group} = 0;
1174 $html .= ">$group</OPTION>\n";
1176 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1177 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1179 $html .= '</SELECT>';
1181 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1182 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1191 The $recref stuff in sub check should be cleaned up.
1193 The suspend, unsuspend and cancel methods update the database, but not the
1194 current object. This is probably a bug as it's unexpected and
1197 radius_usergroup_selector? putting web ui components in here? they should
1198 probably live somewhere else...
1202 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1203 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1204 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1205 L<freeside-queued>), L<FS::svc_acct_pop>,
1206 schema.html from the base documentation.