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
11 $welcome_template $welcome_from $welcome_subject $welcome_mimetype
13 $radius_password $radius_ip
18 use FS::UID qw( datasrc );
20 use FS::Record qw( qsearch qsearchs fields dbh );
27 use FS::cust_main_invoice;
31 use FS::radius_usergroup;
34 use FS::Msgcat qw(gettext);
36 @ISA = qw( FS::svc_Common );
39 $me = '[FS::svc_acct]';
41 #ask FS::UID to run this stuff for us later
42 $FS::UID::callback{'FS::svc_acct'} = sub {
44 $dir_prefix = $conf->config('home');
45 @shells = $conf->config('shells');
46 $usernamemin = $conf->config('usernamemin') || 2;
47 $usernamemax = $conf->config('usernamemax');
48 $passwordmin = $conf->config('passwordmin') || 6;
49 $passwordmax = $conf->config('passwordmax') || 8;
50 $username_letter = $conf->exists('username-letter');
51 $username_letterfirst = $conf->exists('username-letterfirst');
52 $username_noperiod = $conf->exists('username-noperiod');
53 $username_nounderscore = $conf->exists('username-nounderscore');
54 $username_nodash = $conf->exists('username-nodash');
55 $username_uppercase = $conf->exists('username-uppercase');
56 $username_ampersand = $conf->exists('username-ampersand');
57 $mydomain = $conf->config('domain');
58 $dirhash = $conf->config('dirhash') || 0;
59 if ( $conf->exists('welcome_email') ) {
60 $welcome_template = new Text::Template (
62 SOURCE => [ map "$_\n", $conf->config('welcome_email') ]
63 ) or warn "can't create welcome email template: $Text::Template::ERROR";
64 $welcome_from = $conf->config('welcome_email-from'); # || 'your-isp-is-dum'
65 $welcome_subject = $conf->config('welcome_email-subject') || 'Welcome';
66 $welcome_mimetype = $conf->config('welcome_email-mimetype') || 'text/plain';
68 $welcome_template = '';
70 $welcome_subject = '';
71 $welcome_mimetype = '';
73 $smtpmachine = $conf->config('smtpmachine');
74 $radius_password = $conf->config('radius-password') || 'Password';
75 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
78 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
79 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
83 my ( $hashref, $cache ) = @_;
84 if ( $hashref->{'svc_acct_svcnum'} ) {
85 $self->{'_domsvc'} = FS::svc_domain->new( {
86 'svcnum' => $hashref->{'domsvc'},
87 'domain' => $hashref->{'svc_acct_domain'},
88 'catchall' => $hashref->{'svc_acct_catchall'},
95 FS::svc_acct - Object methods for svc_acct records
101 $record = new FS::svc_acct \%hash;
102 $record = new FS::svc_acct { 'column' => 'value' };
104 $error = $record->insert;
106 $error = $new_record->replace($old_record);
108 $error = $record->delete;
110 $error = $record->check;
112 $error = $record->suspend;
114 $error = $record->unsuspend;
116 $error = $record->cancel;
118 %hash = $record->radius;
120 %hash = $record->radius_reply;
122 %hash = $record->radius_check;
124 $domain = $record->domain;
126 $svc_domain = $record->svc_domain;
128 $email = $record->email;
130 $seconds_since = $record->seconds_since($timestamp);
134 An FS::svc_acct object represents an account. FS::svc_acct inherits from
135 FS::svc_Common. The following fields are currently supported:
139 =item svcnum - primary key (assigned automatcially for new accounts)
143 =item _password - generated if blank
145 =item sec_phrase - security phrase
147 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
155 =item dir - set automatically if blank (and uid is not)
159 =item quota - (unimplementd)
161 =item slipip - IP address
165 =item domsvc - svcnum from svc_domain
167 =item radius_I<Radius_Attribute> - I<Radius-Attribute>
177 Creates a new account. To add the account to the database, see L<"insert">.
181 sub table { 'svc_acct'; }
185 Adds this account to the database. If there is an error, returns the error,
186 otherwise returns false.
188 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
189 defined. An FS::cust_svc record will be created and inserted.
191 The additional field I<usergroup> can optionally be defined; if so it should
192 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
193 sqlradius export only)
195 (TODOC: L<FS::queue> and L<freeside-queued>)
197 (TODOC: new exports!)
205 local $SIG{HUP} = 'IGNORE';
206 local $SIG{INT} = 'IGNORE';
207 local $SIG{QUIT} = 'IGNORE';
208 local $SIG{TERM} = 'IGNORE';
209 local $SIG{TSTP} = 'IGNORE';
210 local $SIG{PIPE} = 'IGNORE';
212 my $oldAutoCommit = $FS::UID::AutoCommit;
213 local $FS::UID::AutoCommit = 0;
216 $error = $self->check;
217 return $error if $error;
219 #no, duplicate checking just got a whole lot more complicated
220 #(perhaps keep this check with a config option to turn on?)
222 #return gettext('username_in_use'). ": ". $self->username
223 # if qsearchs( 'svc_acct', { 'username' => $self->username,
224 # 'domsvc' => $self->domsvc,
227 if ( $self->svcnum ) {
228 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
229 unless ( $cust_svc ) {
230 $dbh->rollback if $oldAutoCommit;
231 return "no cust_svc record found for svcnum ". $self->svcnum;
233 $self->pkgnum($cust_svc->pkgnum);
234 $self->svcpart($cust_svc->svcpart);
237 #new duplicate username checking
239 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
240 unless ( $part_svc ) {
241 $dbh->rollback if $oldAutoCommit;
242 return 'unknown svcpart '. $self->svcpart;
245 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
246 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
247 'domsvc' => $self->domsvc } );
249 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
250 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
251 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
256 if ( @dup_user || @dup_userdomain || @dup_uid ) {
257 my $exports = FS::part_export::export_info('svc_acct');
258 my %conflict_user_svcpart;
259 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
261 foreach my $part_export ( $part_svc->part_export ) {
263 #this will catch to the same exact export
264 my @svcparts = map { $_->svcpart }
265 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
267 #this will catch to exports w/same exporthost+type ???
268 #my @other_part_export = qsearch('part_export', {
269 # 'machine' => $part_export->machine,
270 # 'exporttype' => $part_export->exporttype,
272 #foreach my $other_part_export ( @other_part_export ) {
273 # push @svcparts, map { $_->svcpart }
274 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
277 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
278 #silly kludge to avoid uninitialized value errors
279 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
280 ? $exports->{$part_export->exporttype}{'nodomain'}
282 if ( $nodomain =~ /^Y/i ) {
283 $conflict_user_svcpart{$_} = $part_export->exportnum
286 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
291 foreach my $dup_user ( @dup_user ) {
292 my $dup_svcpart = $dup_user->cust_svc->svcpart;
293 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
294 $dbh->rollback if $oldAutoCommit;
295 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
296 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
300 foreach my $dup_userdomain ( @dup_userdomain ) {
301 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
302 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
303 $dbh->rollback if $oldAutoCommit;
304 return "duplicate username\@domain: conflicts with svcnum ".
305 $dup_userdomain->svcnum. " via exportnum ".
306 $conflict_userdomain_svcpart{$dup_svcpart};
310 foreach my $dup_uid ( @dup_uid ) {
311 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
312 if ( exists($conflict_user_svcpart{$dup_svcpart})
313 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
314 $dbh->rollback if $oldAutoCommit;
315 return "duplicate uid: conflicts with svcnum". $dup_uid->svcnum.
316 "via exportnum ". $conflict_user_svcpart{$dup_svcpart}
317 || $conflict_userdomain_svcpart{$dup_svcpart};
323 #see? i told you it was more complicated
326 $error = $self->SUPER::insert(\@jobnums);
328 $dbh->rollback if $oldAutoCommit;
332 if ( $self->usergroup ) {
333 foreach my $groupname ( @{$self->usergroup} ) {
334 my $radius_usergroup = new FS::radius_usergroup ( {
335 svcnum => $self->svcnum,
336 groupname => $groupname,
338 my $error = $radius_usergroup->insert;
340 $dbh->rollback if $oldAutoCommit;
346 #false laziness with sub replace (and cust_main)
347 my $queue = new FS::queue {
348 'svcnum' => $self->svcnum,
349 'job' => 'FS::svc_acct::append_fuzzyfiles'
351 $error = $queue->insert($self->username);
353 $dbh->rollback if $oldAutoCommit;
354 return "queueing job (transaction rolled back): $error";
357 my $cust_pkg = $self->cust_svc->cust_pkg;
360 my $cust_main = $cust_pkg->cust_main;
362 if ( $conf->exists('emailinvoiceauto') ) {
363 my @invoicing_list = $cust_main->invoicing_list;
364 push @invoicing_list, $self->email;
365 $cust_main->invoicing_list(\@invoicing_list);
370 if ( $welcome_template && $cust_pkg ) {
371 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
373 my $wqueue = new FS::queue {
374 'svcnum' => $self->svcnum,
375 'job' => 'FS::svc_acct::send_email'
377 my $error = $wqueue->insert(
379 'from' => $welcome_from,
380 'subject' => $welcome_subject,
381 'mimetype' => $welcome_mimetype,
382 'body' => $welcome_template->fill_in( HASH => {
383 'custnum' => $self->custnum,
384 'username' => $self->username,
385 'password' => $self->_password,
386 'first' => $cust_main->first,
387 'last' => $cust_main->getfield('last'),
388 'pkg' => $cust_pkg->part_pkg->pkg,
392 $dbh->rollback if $oldAutoCommit;
393 return "error queuing welcome email: $error";
396 foreach my $jobnum ( @jobnums ) {
397 my $error = $wqueue->depend_insert($jobnum);
399 $dbh->rollback if $oldAutoCommit;
400 return "error queuing welcome email job dependancy: $error";
410 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
416 Deletes this account from the database. If there is an error, returns the
417 error, otherwise returns false.
419 The corresponding FS::cust_svc record will be deleted as well.
421 (TODOC: new exports!)
428 if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
429 return "Can't delete an account which has (svc_acct_sm) mail aliases!"
430 if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
433 return "Can't delete an account which is a (svc_forward) source!"
434 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
436 return "Can't delete an account which is a (svc_forward) destination!"
437 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
439 return "Can't delete an account with (svc_www) web service!"
440 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
442 # what about records in session ? (they should refer to history table)
444 local $SIG{HUP} = 'IGNORE';
445 local $SIG{INT} = 'IGNORE';
446 local $SIG{QUIT} = 'IGNORE';
447 local $SIG{TERM} = 'IGNORE';
448 local $SIG{TSTP} = 'IGNORE';
449 local $SIG{PIPE} = 'IGNORE';
451 my $oldAutoCommit = $FS::UID::AutoCommit;
452 local $FS::UID::AutoCommit = 0;
455 foreach my $cust_main_invoice (
456 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
458 unless ( defined($cust_main_invoice) ) {
459 warn "WARNING: something's wrong with qsearch";
462 my %hash = $cust_main_invoice->hash;
463 $hash{'dest'} = $self->email;
464 my $new = new FS::cust_main_invoice \%hash;
465 my $error = $new->replace($cust_main_invoice);
467 $dbh->rollback if $oldAutoCommit;
472 foreach my $svc_domain (
473 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
475 my %hash = new FS::svc_domain->hash;
476 $hash{'catchall'} = '';
477 my $new = new FS::svc_domain \%hash;
478 my $error = $new->replace($svc_domain);
480 $dbh->rollback if $oldAutoCommit;
485 foreach my $radius_usergroup (
486 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
488 my $error = $radius_usergroup->delete;
490 $dbh->rollback if $oldAutoCommit;
495 my $error = $self->SUPER::delete;
497 $dbh->rollback if $oldAutoCommit;
501 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
505 =item replace OLD_RECORD
507 Replaces OLD_RECORD with this one in the database. If there is an error,
508 returns the error, otherwise returns false.
510 The additional field I<usergroup> can optionally be defined; if so it should
511 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
512 sqlradius export only)
517 my ( $new, $old ) = ( shift, shift );
519 warn "$me replacing $old with $new\n" if $DEBUG;
521 return "Username in use"
522 if $old->username ne $new->username &&
523 qsearchs( 'svc_acct', { 'username' => $new->username,
524 'domsvc' => $new->domsvc,
527 #no warnings 'numeric'; #alas, a 5.006-ism
529 return "Can't change uid!" if $old->uid != $new->uid;
532 #change homdir when we change username
533 $new->setfield('dir', '') if $old->username ne $new->username;
535 local $SIG{HUP} = 'IGNORE';
536 local $SIG{INT} = 'IGNORE';
537 local $SIG{QUIT} = 'IGNORE';
538 local $SIG{TERM} = 'IGNORE';
539 local $SIG{TSTP} = 'IGNORE';
540 local $SIG{PIPE} = 'IGNORE';
542 my $oldAutoCommit = $FS::UID::AutoCommit;
543 local $FS::UID::AutoCommit = 0;
546 # redundant, but so $new->usergroup gets set
547 $error = $new->check;
548 return $error if $error;
550 $old->usergroup( [ $old->radius_groups ] );
551 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
552 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
553 if ( $new->usergroup ) {
554 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
555 my @newgroups = @{$new->usergroup};
556 foreach my $oldgroup ( @{$old->usergroup} ) {
557 if ( grep { $oldgroup eq $_ } @newgroups ) {
558 @newgroups = grep { $oldgroup ne $_ } @newgroups;
561 my $radius_usergroup = qsearchs('radius_usergroup', {
562 svcnum => $old->svcnum,
563 groupname => $oldgroup,
565 my $error = $radius_usergroup->delete;
567 $dbh->rollback if $oldAutoCommit;
568 return "error deleting radius_usergroup $oldgroup: $error";
572 foreach my $newgroup ( @newgroups ) {
573 my $radius_usergroup = new FS::radius_usergroup ( {
574 svcnum => $new->svcnum,
575 groupname => $newgroup,
577 my $error = $radius_usergroup->insert;
579 $dbh->rollback if $oldAutoCommit;
580 return "error adding radius_usergroup $newgroup: $error";
586 $error = $new->SUPER::replace($old);
588 $dbh->rollback if $oldAutoCommit;
589 return $error if $error;
592 if ( $new->username ne $old->username ) {
593 #false laziness with sub insert (and cust_main)
594 my $queue = new FS::queue {
595 'svcnum' => $new->svcnum,
596 'job' => 'FS::svc_acct::append_fuzzyfiles'
598 $error = $queue->insert($new->username);
600 $dbh->rollback if $oldAutoCommit;
601 return "queueing job (transaction rolled back): $error";
605 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
611 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
612 error, returns the error, otherwise returns false.
614 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
616 Calls any export-specific suspend hooks.
622 my %hash = $self->hash;
623 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
624 || $hash{_password} eq '*'
626 $hash{_password} = '*SUSPENDED* '.$hash{_password};
627 my $new = new FS::svc_acct ( \%hash );
628 my $error = $new->replace($self);
629 return $error if $error;
632 $self->SUPER::suspend;
637 Unsuspends this account by removing *SUSPENDED* from the password. If there is
638 an error, returns the error, otherwise returns false.
640 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
642 Calls any export-specific unsuspend hooks.
648 my %hash = $self->hash;
649 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
650 $hash{_password} = $1;
651 my $new = new FS::svc_acct ( \%hash );
652 my $error = $new->replace($self);
653 return $error if $error;
656 $self->SUPER::unsuspend;
661 Just returns false (no error) for now.
663 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
667 Checks all fields to make sure this is a valid service. If there is an error,
668 returns the error, otherwise returns false. Called by the insert and replace
671 Sets any fixed values; see L<FS::part_svc>.
678 my($recref) = $self->hashref;
680 my $x = $self->setfixed;
681 return $x unless ref($x);
684 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
686 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
689 my $error = $self->ut_numbern('svcnum')
690 #|| $self->ut_number('domsvc')
691 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
692 || $self->ut_textn('sec_phrase')
694 return $error if $error;
696 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
697 if ( $username_uppercase ) {
698 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
699 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
700 $recref->{username} = $1;
702 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
703 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
704 $recref->{username} = $1;
707 if ( $username_letterfirst ) {
708 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
709 } elsif ( $username_letter ) {
710 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
712 if ( $username_noperiod ) {
713 $recref->{username} =~ /\./ and return gettext('illegal_username');
715 if ( $username_nounderscore ) {
716 $recref->{username} =~ /_/ and return gettext('illegal_username');
718 if ( $username_nodash ) {
719 $recref->{username} =~ /\-/ and return gettext('illegal_username');
721 unless ( $username_ampersand ) {
722 $recref->{username} =~ /\&/ and return gettext('illegal_username');
725 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
726 $recref->{popnum} = $1;
727 return "Unknown popnum" unless
728 ! $recref->{popnum} ||
729 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
731 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
733 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
734 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
736 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
737 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
738 #not all systems use gid=uid
739 #you can set a fixed gid in part_svc
741 return "Only root can have uid 0"
742 if $recref->{uid} == 0
743 && $recref->{username} ne 'root'
744 && $recref->{username} ne 'toor';
747 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
748 or return "Illegal directory: ". $recref->{dir};
750 return "Illegal directory"
751 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
752 return "Illegal directory"
753 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
754 unless ( $recref->{dir} ) {
755 $recref->{dir} = $dir_prefix . '/';
756 if ( $dirhash > 0 ) {
757 for my $h ( 1 .. $dirhash ) {
758 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
760 } elsif ( $dirhash < 0 ) {
761 for my $h ( reverse $dirhash .. -1 ) {
762 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
765 $recref->{dir} .= $recref->{username};
769 unless ( $recref->{username} eq 'sync' ) {
770 if ( grep $_ eq $recref->{shell}, @shells ) {
771 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
773 return "Illegal shell \`". $self->shell. "\'; ".
774 $conf->dir. "/shells contains: @shells";
777 $recref->{shell} = '/bin/sync';
781 $recref->{gid} ne '' ?
782 return "Can't have gid without uid" : ( $recref->{gid}='' );
783 $recref->{dir} ne '' ?
784 return "Can't have directory without uid" : ( $recref->{dir}='' );
785 $recref->{shell} ne '' ?
786 return "Can't have shell without uid" : ( $recref->{shell}='' );
789 # $error = $self->ut_textn('finger');
790 # return $error if $error;
791 $self->getfield('finger') =~
792 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
793 or return "Illegal finger: ". $self->getfield('finger');
794 $self->setfield('finger', $1);
796 $recref->{quota} =~ /^(\d*)$/ or return "Illegal quota";
797 $recref->{quota} = $1;
799 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
800 unless ( $recref->{slipip} eq '0e0' ) {
801 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
802 or return "Illegal slipip". $self->slipip;
803 $recref->{slipip} = $1;
805 $recref->{slipip} = '0e0';
810 #arbitrary RADIUS stuff; allow ut_textn for now
811 foreach ( grep /^radius_/, fields('svc_acct') ) {
815 #generate a password if it is blank
816 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
817 unless ( $recref->{_password} );
819 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
820 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
821 $recref->{_password} = $1.$3;
822 #uncomment this to encrypt password immediately upon entry, or run
823 #bin/crypt_pw in cron to give new users a window during which their
824 #password is available to techs, for faxing, etc. (also be aware of
826 #$recref->{password} = $1.
827 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
829 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,34})$/ ) {
830 $recref->{_password} = $1.$3;
831 } elsif ( $recref->{_password} eq '*' ) {
832 $recref->{_password} = '*';
833 } elsif ( $recref->{_password} eq '!!' ) {
834 $recref->{_password} = '!!';
836 #return "Illegal password";
837 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
838 FS::Msgcat::_gettext('illegal_password_characters').
839 ": ". $recref->{_password};
847 Depriciated, use radius_reply instead.
852 carp "FS::svc_acct::radius depriciated, use radius_reply";
858 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
859 reply attributes of this record.
861 Note that this is now the preferred method for reading RADIUS attributes -
862 accessing the columns directly is discouraged, as the column names are
863 expected to change in the future.
872 my($column, $attrib) = ($1, $2);
873 #$attrib =~ s/_/\-/g;
874 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
875 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
876 if ( $self->slipip && $self->slipip ne '0e0' ) {
877 $reply{$radius_ip} = $self->slipip;
884 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
885 check attributes of this record.
887 Note that this is now the preferred method for reading RADIUS attributes -
888 accessing the columns directly is discouraged, as the column names are
889 expected to change in the future.
895 my $password = $self->_password;
896 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
897 ( $pw_attrib => $self->_password,
900 my($column, $attrib) = ($1, $2);
901 #$attrib =~ s/_/\-/g;
902 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
903 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
909 Returns the domain associated with this account.
915 if ( $self->domsvc ) {
916 #$self->svc_domain->domain;
917 my $svc_domain = $self->svc_domain
918 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
921 $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
927 Returns the FS::svc_domain record for this account's domain (see
936 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
941 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
947 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
952 Returns an email address associated with the account.
958 $self->username. '@'. $self->domain;
961 =item seconds_since TIMESTAMP
963 Returns the number of seconds this account has been online since TIMESTAMP,
964 according to the session monitor (see L<FS::Session>).
966 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
967 L<Time::Local> and L<Date::Parse> for conversion functions.
971 #note: POD here, implementation in FS::cust_svc
974 $self->cust_svc->seconds_since(@_);
977 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
979 Returns the numbers of seconds this account has been online between
980 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
981 external SQL radacct table, specified via sqlradius export. Sessions which
982 started in the specified range but are still open are counted from session
983 start to the end of the range (unless they are over 1 day old, in which case
984 they are presumed missing their stop record and not counted). Also, sessions
985 which end in the range but started earlier are counted from the start of the
986 range to session end. Finally, sessions which start before the range but end
987 after are counted for the entire range.
989 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
990 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
995 #note: POD here, implementation in FS::cust_svc
996 sub seconds_since_sqlradacct {
998 $self->cust_svc->seconds_since_sqlradacct(@_);
1001 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1003 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1004 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1005 TIMESTAMP_END (exclusive).
1007 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1008 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1013 #note: POD here, implementation in FS::cust_svc
1014 sub attribute_since_sqlradacct {
1016 $self->cust_svc->attribute_since_sqlradacct(@_);
1022 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1028 if ( $self->usergroup ) {
1029 #when provisioning records, export callback runs in svc_Common.pm before
1030 #radius_usergroup records can be inserted...
1031 @{$self->usergroup};
1033 map { $_->groupname }
1034 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1052 use Mail::Internet 1.44;
1055 $opt{mimetype} ||= 'text/plain';
1056 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1058 $ENV{MAILADDRESS} = $opt{from};
1059 my $header = new Mail::Header ( [
1062 "Sender: $opt{from}",
1063 "Reply-To: $opt{from}",
1064 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1065 "Subject: $opt{subject}",
1066 "Content-Type: $opt{mimetype}",
1068 my $message = new Mail::Internet (
1069 'Header' => $header,
1070 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1073 $message->smtpsend( Host => $smtpmachine )
1074 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1075 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1078 =item check_and_rebuild_fuzzyfiles
1082 sub check_and_rebuild_fuzzyfiles {
1083 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1084 -e "$dir/svc_acct.username"
1085 or &rebuild_fuzzyfiles;
1088 =item rebuild_fuzzyfiles
1092 sub rebuild_fuzzyfiles {
1094 use Fcntl qw(:flock);
1096 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1100 open(USERNAMELOCK,">>$dir/svc_acct.username")
1101 or die "can't open $dir/svc_acct.username: $!";
1102 flock(USERNAMELOCK,LOCK_EX)
1103 or die "can't lock $dir/svc_acct.username: $!";
1105 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1107 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1108 or die "can't open $dir/svc_acct.username.tmp: $!";
1109 print USERNAMECACHE join("\n", @all_username), "\n";
1110 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1112 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1122 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1123 open(USERNAMECACHE,"<$dir/svc_acct.username")
1124 or die "can't open $dir/svc_acct.username: $!";
1125 my @array = map { chomp; $_; } <USERNAMECACHE>;
1126 close USERNAMECACHE;
1130 =item append_fuzzyfiles USERNAME
1134 sub append_fuzzyfiles {
1135 my $username = shift;
1137 &check_and_rebuild_fuzzyfiles;
1139 use Fcntl qw(:flock);
1141 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1143 open(USERNAME,">>$dir/svc_acct.username")
1144 or die "can't open $dir/svc_acct.username: $!";
1145 flock(USERNAME,LOCK_EX)
1146 or die "can't lock $dir/svc_acct.username: $!";
1148 print USERNAME "$username\n";
1150 flock(USERNAME,LOCK_UN)
1151 or die "can't unlock $dir/svc_acct.username: $!";
1159 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1163 sub radius_usergroup_selector {
1164 my $sel_groups = shift;
1165 my %sel_groups = map { $_=>1 } @$sel_groups;
1167 my $selectname = shift || 'radius_usergroup';
1170 my $sth = $dbh->prepare(
1171 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1172 ) or die $dbh->errstr;
1173 $sth->execute() or die $sth->errstr;
1174 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1178 function ${selectname}_doadd(object) {
1179 var myvalue = object.${selectname}_add.value;
1180 var optionName = new Option(myvalue,myvalue,false,true);
1181 var length = object.$selectname.length;
1182 object.$selectname.options[length] = optionName;
1183 object.${selectname}_add.value = "";
1186 <SELECT MULTIPLE NAME="$selectname">
1189 foreach my $group ( @all_groups ) {
1191 if ( $sel_groups{$group} ) {
1192 $html .= ' SELECTED';
1193 $sel_groups{$group} = 0;
1195 $html .= ">$group</OPTION>\n";
1197 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1198 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1200 $html .= '</SELECT>';
1202 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1203 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1212 The $recref stuff in sub check should be cleaned up.
1214 The suspend, unsuspend and cancel methods update the database, but not the
1215 current object. This is probably a bug as it's unexpected and
1218 radius_usergroup_selector? putting web ui components in here? they should
1219 probably live somewhere else...
1223 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1224 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1225 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1226 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1227 schema.html from the base documentation.