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 dbdef );
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 The additional field I<child_objects> can optionally be defined; if so it
196 should contain an arrayref of FS::tablename objects. They will have their
197 svcnum fields set and will be inserted after this record, but before any
200 (TODOC: L<FS::queue> and L<freeside-queued>)
202 (TODOC: new exports!)
211 local $SIG{HUP} = 'IGNORE';
212 local $SIG{INT} = 'IGNORE';
213 local $SIG{QUIT} = 'IGNORE';
214 local $SIG{TERM} = 'IGNORE';
215 local $SIG{TSTP} = 'IGNORE';
216 local $SIG{PIPE} = 'IGNORE';
218 my $oldAutoCommit = $FS::UID::AutoCommit;
219 local $FS::UID::AutoCommit = 0;
222 $error = $self->check;
223 return $error if $error;
225 #no, duplicate checking just got a whole lot more complicated
226 #(perhaps keep this check with a config option to turn on?)
228 #return gettext('username_in_use'). ": ". $self->username
229 # if qsearchs( 'svc_acct', { 'username' => $self->username,
230 # 'domsvc' => $self->domsvc,
233 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
234 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
235 unless ( $cust_svc ) {
236 $dbh->rollback if $oldAutoCommit;
237 return "no cust_svc record found for svcnum ". $self->svcnum;
239 $self->pkgnum($cust_svc->pkgnum);
240 $self->svcpart($cust_svc->svcpart);
243 #new duplicate username checking
245 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
246 unless ( $part_svc ) {
247 $dbh->rollback if $oldAutoCommit;
248 return 'unknown svcpart '. $self->svcpart;
251 my @dup_user = qsearch( 'svc_acct', { 'username' => $self->username } );
252 my @dup_userdomain = qsearch( 'svc_acct', { 'username' => $self->username,
253 'domsvc' => $self->domsvc } );
255 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
256 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
257 @dup_uid = qsearch( 'svc_acct', { 'uid' => $self->uid } );
262 if ( @dup_user || @dup_userdomain || @dup_uid ) {
263 my $exports = FS::part_export::export_info('svc_acct');
264 my %conflict_user_svcpart;
265 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
267 foreach my $part_export ( $part_svc->part_export ) {
269 #this will catch to the same exact export
270 my @svcparts = map { $_->svcpart }
271 qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
273 #this will catch to exports w/same exporthost+type ???
274 #my @other_part_export = qsearch('part_export', {
275 # 'machine' => $part_export->machine,
276 # 'exporttype' => $part_export->exporttype,
278 #foreach my $other_part_export ( @other_part_export ) {
279 # push @svcparts, map { $_->svcpart }
280 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
283 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
284 #silly kludge to avoid uninitialized value errors
285 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
286 ? $exports->{$part_export->exporttype}{'nodomain'}
288 if ( $nodomain =~ /^Y/i ) {
289 $conflict_user_svcpart{$_} = $part_export->exportnum
292 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
297 foreach my $dup_user ( @dup_user ) {
298 my $dup_svcpart = $dup_user->cust_svc->svcpart;
299 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
300 $dbh->rollback if $oldAutoCommit;
301 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
302 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
306 foreach my $dup_userdomain ( @dup_userdomain ) {
307 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
308 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
309 $dbh->rollback if $oldAutoCommit;
310 return "duplicate username\@domain: conflicts with svcnum ".
311 $dup_userdomain->svcnum. " via exportnum ".
312 $conflict_userdomain_svcpart{$dup_svcpart};
316 foreach my $dup_uid ( @dup_uid ) {
317 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
318 if ( exists($conflict_user_svcpart{$dup_svcpart})
319 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
320 $dbh->rollback if $oldAutoCommit;
321 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
322 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
323 || $conflict_userdomain_svcpart{$dup_svcpart};
329 #see? i told you it was more complicated
332 $error = $self->SUPER::insert(\@jobnums, $self->child_objects || [] );
334 $dbh->rollback if $oldAutoCommit;
338 if ( $self->usergroup ) {
339 foreach my $groupname ( @{$self->usergroup} ) {
340 my $radius_usergroup = new FS::radius_usergroup ( {
341 svcnum => $self->svcnum,
342 groupname => $groupname,
344 my $error = $radius_usergroup->insert;
346 $dbh->rollback if $oldAutoCommit;
352 #false laziness with sub replace (and cust_main)
353 my $queue = new FS::queue {
354 'svcnum' => $self->svcnum,
355 'job' => 'FS::svc_acct::append_fuzzyfiles'
357 $error = $queue->insert($self->username);
359 $dbh->rollback if $oldAutoCommit;
360 return "queueing job (transaction rolled back): $error";
363 my $cust_pkg = $self->cust_svc->cust_pkg;
366 my $cust_main = $cust_pkg->cust_main;
368 if ( $conf->exists('emailinvoiceauto') ) {
369 my @invoicing_list = $cust_main->invoicing_list;
370 push @invoicing_list, $self->email;
371 $cust_main->invoicing_list(\@invoicing_list);
376 if ( $welcome_template && $cust_pkg ) {
377 my $to = join(', ', grep { $_ ne 'POST' } $cust_main->invoicing_list );
379 my $wqueue = new FS::queue {
380 'svcnum' => $self->svcnum,
381 'job' => 'FS::svc_acct::send_email'
383 my $error = $wqueue->insert(
385 'from' => $welcome_from,
386 'subject' => $welcome_subject,
387 'mimetype' => $welcome_mimetype,
388 'body' => $welcome_template->fill_in( HASH => {
389 'custnum' => $self->custnum,
390 'username' => $self->username,
391 'password' => $self->_password,
392 'first' => $cust_main->first,
393 'last' => $cust_main->getfield('last'),
394 'pkg' => $cust_pkg->part_pkg->pkg,
398 $dbh->rollback if $oldAutoCommit;
399 return "error queuing welcome email: $error";
402 foreach my $jobnum ( @jobnums ) {
403 my $error = $wqueue->depend_insert($jobnum);
405 $dbh->rollback if $oldAutoCommit;
406 return "error queuing welcome email job dependancy: $error";
416 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
422 Deletes this account from the database. If there is an error, returns the
423 error, otherwise returns false.
425 The corresponding FS::cust_svc record will be deleted as well.
427 (TODOC: new exports!)
434 if ( defined( $FS::Record::dbdef->table('svc_acct_sm') ) ) {
435 return "Can't delete an account which has (svc_acct_sm) mail aliases!"
436 if $self->uid && qsearch( 'svc_acct_sm', { 'domuid' => $self->uid } );
439 return "can't delete system account" if $self->_check_system;
441 return "Can't delete an account which is a (svc_forward) source!"
442 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
444 return "Can't delete an account which is a (svc_forward) destination!"
445 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
447 return "Can't delete an account with (svc_www) web service!"
448 if qsearch( 'svc_www', { 'usersvc' => $self->usersvc } );
450 # what about records in session ? (they should refer to history table)
452 local $SIG{HUP} = 'IGNORE';
453 local $SIG{INT} = 'IGNORE';
454 local $SIG{QUIT} = 'IGNORE';
455 local $SIG{TERM} = 'IGNORE';
456 local $SIG{TSTP} = 'IGNORE';
457 local $SIG{PIPE} = 'IGNORE';
459 my $oldAutoCommit = $FS::UID::AutoCommit;
460 local $FS::UID::AutoCommit = 0;
463 foreach my $cust_main_invoice (
464 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
466 unless ( defined($cust_main_invoice) ) {
467 warn "WARNING: something's wrong with qsearch";
470 my %hash = $cust_main_invoice->hash;
471 $hash{'dest'} = $self->email;
472 my $new = new FS::cust_main_invoice \%hash;
473 my $error = $new->replace($cust_main_invoice);
475 $dbh->rollback if $oldAutoCommit;
480 foreach my $svc_domain (
481 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
483 my %hash = new FS::svc_domain->hash;
484 $hash{'catchall'} = '';
485 my $new = new FS::svc_domain \%hash;
486 my $error = $new->replace($svc_domain);
488 $dbh->rollback if $oldAutoCommit;
493 foreach my $radius_usergroup (
494 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
496 my $error = $radius_usergroup->delete;
498 $dbh->rollback if $oldAutoCommit;
503 my $error = $self->SUPER::delete;
505 $dbh->rollback if $oldAutoCommit;
509 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
513 =item replace OLD_RECORD
515 Replaces OLD_RECORD with this one in the database. If there is an error,
516 returns the error, otherwise returns false.
518 The additional field I<usergroup> can optionally be defined; if so it should
519 contain an arrayref of group names. See L<FS::radius_usergroup>. (used in
520 sqlradius export only)
525 my ( $new, $old ) = ( shift, shift );
527 warn "$me replacing $old with $new\n" if $DEBUG;
529 return "can't modify system account" if $old->_check_system;
531 return "Username in use"
532 if $old->username ne $new->username &&
533 qsearchs( 'svc_acct', { 'username' => $new->username,
534 'domsvc' => $new->domsvc,
537 #no warnings 'numeric'; #alas, a 5.006-ism
539 return "Can't change uid!" if $old->uid != $new->uid;
542 #change homdir when we change username
543 $new->setfield('dir', '') if $old->username ne $new->username;
545 local $SIG{HUP} = 'IGNORE';
546 local $SIG{INT} = 'IGNORE';
547 local $SIG{QUIT} = 'IGNORE';
548 local $SIG{TERM} = 'IGNORE';
549 local $SIG{TSTP} = 'IGNORE';
550 local $SIG{PIPE} = 'IGNORE';
552 my $oldAutoCommit = $FS::UID::AutoCommit;
553 local $FS::UID::AutoCommit = 0;
556 # redundant, but so $new->usergroup gets set
557 $error = $new->check;
558 return $error if $error;
560 $old->usergroup( [ $old->radius_groups ] );
561 warn "old groups: ". join(' ',@{$old->usergroup}). "\n" if $DEBUG;
562 warn "new groups: ". join(' ',@{$new->usergroup}). "\n" if $DEBUG;
563 if ( $new->usergroup ) {
564 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
565 my @newgroups = @{$new->usergroup};
566 foreach my $oldgroup ( @{$old->usergroup} ) {
567 if ( grep { $oldgroup eq $_ } @newgroups ) {
568 @newgroups = grep { $oldgroup ne $_ } @newgroups;
571 my $radius_usergroup = qsearchs('radius_usergroup', {
572 svcnum => $old->svcnum,
573 groupname => $oldgroup,
575 my $error = $radius_usergroup->delete;
577 $dbh->rollback if $oldAutoCommit;
578 return "error deleting radius_usergroup $oldgroup: $error";
582 foreach my $newgroup ( @newgroups ) {
583 my $radius_usergroup = new FS::radius_usergroup ( {
584 svcnum => $new->svcnum,
585 groupname => $newgroup,
587 my $error = $radius_usergroup->insert;
589 $dbh->rollback if $oldAutoCommit;
590 return "error adding radius_usergroup $newgroup: $error";
596 $error = $new->SUPER::replace($old);
598 $dbh->rollback if $oldAutoCommit;
599 return $error if $error;
602 if ( $new->username ne $old->username ) {
603 #false laziness with sub insert (and cust_main)
604 my $queue = new FS::queue {
605 'svcnum' => $new->svcnum,
606 'job' => 'FS::svc_acct::append_fuzzyfiles'
608 $error = $queue->insert($new->username);
610 $dbh->rollback if $oldAutoCommit;
611 return "queueing job (transaction rolled back): $error";
615 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
621 Suspends this account by prefixing *SUSPENDED* to the password. If there is an
622 error, returns the error, otherwise returns false.
624 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
626 Calls any export-specific suspend hooks.
632 return "can't suspend system account" if $self->_check_system;
633 my %hash = $self->hash;
634 unless ( $hash{_password} =~ /^\*SUSPENDED\* /
635 || $hash{_password} eq '*'
637 $hash{_password} = '*SUSPENDED* '.$hash{_password};
638 my $new = new FS::svc_acct ( \%hash );
639 my $error = $new->replace($self);
640 return $error if $error;
643 $self->SUPER::suspend;
648 Unsuspends this account by removing *SUSPENDED* from the password. If there is
649 an error, returns the error, otherwise returns false.
651 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
653 Calls any export-specific unsuspend hooks.
659 my %hash = $self->hash;
660 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
661 $hash{_password} = $1;
662 my $new = new FS::svc_acct ( \%hash );
663 my $error = $new->replace($self);
664 return $error if $error;
667 $self->SUPER::unsuspend;
672 Just returns false (no error) for now.
674 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
678 Checks all fields to make sure this is a valid service. If there is an error,
679 returns the error, otherwise returns false. Called by the insert and replace
682 Sets any fixed values; see L<FS::part_svc>.
689 my($recref) = $self->hashref;
691 my $x = $self->setfixed;
692 return $x unless ref($x);
695 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
697 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
700 my $error = $self->ut_numbern('svcnum')
701 #|| $self->ut_number('domsvc')
702 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
703 || $self->ut_textn('sec_phrase')
705 return $error if $error;
707 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
708 if ( $username_uppercase ) {
709 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
710 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
711 $recref->{username} = $1;
713 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
714 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
715 $recref->{username} = $1;
718 if ( $username_letterfirst ) {
719 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
720 } elsif ( $username_letter ) {
721 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
723 if ( $username_noperiod ) {
724 $recref->{username} =~ /\./ and return gettext('illegal_username');
726 if ( $username_nounderscore ) {
727 $recref->{username} =~ /_/ and return gettext('illegal_username');
729 if ( $username_nodash ) {
730 $recref->{username} =~ /\-/ and return gettext('illegal_username');
732 unless ( $username_ampersand ) {
733 $recref->{username} =~ /\&/ and return gettext('illegal_username');
736 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
737 $recref->{popnum} = $1;
738 return "Unknown popnum" unless
739 ! $recref->{popnum} ||
740 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
742 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
744 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
745 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
747 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
748 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
749 #not all systems use gid=uid
750 #you can set a fixed gid in part_svc
752 return "Only root can have uid 0"
753 if $recref->{uid} == 0
754 && $recref->{username} ne 'root'
755 && $recref->{username} ne 'toor';
758 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
759 or return "Illegal directory: ". $recref->{dir};
761 return "Illegal directory"
762 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
763 return "Illegal directory"
764 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
765 unless ( $recref->{dir} ) {
766 $recref->{dir} = $dir_prefix . '/';
767 if ( $dirhash > 0 ) {
768 for my $h ( 1 .. $dirhash ) {
769 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
771 } elsif ( $dirhash < 0 ) {
772 for my $h ( reverse $dirhash .. -1 ) {
773 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
776 $recref->{dir} .= $recref->{username};
780 unless ( $recref->{username} eq 'sync' ) {
781 if ( grep $_ eq $recref->{shell}, @shells ) {
782 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
784 return "Illegal shell \`". $self->shell. "\'; ".
785 $conf->dir. "/shells contains: @shells";
788 $recref->{shell} = '/bin/sync';
792 $recref->{gid} ne '' ?
793 return "Can't have gid without uid" : ( $recref->{gid}='' );
794 $recref->{dir} ne '' ?
795 return "Can't have directory without uid" : ( $recref->{dir}='' );
796 $recref->{shell} ne '' ?
797 return "Can't have shell without uid" : ( $recref->{shell}='' );
800 # $error = $self->ut_textn('finger');
801 # return $error if $error;
802 $self->getfield('finger') =~
803 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
804 or return "Illegal finger: ". $self->getfield('finger');
805 $self->setfield('finger', $1);
807 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
808 $recref->{quota} = $1;
810 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
811 if ( $recref->{slipip} eq '' ) {
812 $recref->{slipip} = '';
813 } elsif ( $recref->{slipip} eq '0e0' ) {
814 $recref->{slipip} = '0e0';
816 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
817 or return "Illegal slipip". $self->slipip;
818 $recref->{slipip} = $1;
823 #arbitrary RADIUS stuff; allow ut_textn for now
824 foreach ( grep /^radius_/, fields('svc_acct') ) {
828 #generate a password if it is blank
829 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
830 unless ( $recref->{_password} );
832 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
833 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
834 $recref->{_password} = $1.$3;
835 #uncomment this to encrypt password immediately upon entry, or run
836 #bin/crypt_pw in cron to give new users a window during which their
837 #password is available to techs, for faxing, etc. (also be aware of
839 #$recref->{password} = $1.
840 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
842 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
843 $recref->{_password} = $1.$3;
844 } elsif ( $recref->{_password} eq '*' ) {
845 $recref->{_password} = '*';
846 } elsif ( $recref->{_password} eq '!' ) {
847 $recref->{_password} = '!';
848 } elsif ( $recref->{_password} eq '!!' ) {
849 $recref->{_password} = '!!';
851 #return "Illegal password";
852 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
853 FS::Msgcat::_gettext('illegal_password_characters').
854 ": ". $recref->{_password};
866 scalar( grep { $self->username eq $_ || $self->email eq $_ }
867 $conf->config('system_usernames')
874 Depriciated, use radius_reply instead.
879 carp "FS::svc_acct::radius depriciated, use radius_reply";
885 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
886 reply attributes of this record.
888 Note that this is now the preferred method for reading RADIUS attributes -
889 accessing the columns directly is discouraged, as the column names are
890 expected to change in the future.
899 my($column, $attrib) = ($1, $2);
900 #$attrib =~ s/_/\-/g;
901 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
902 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
903 if ( $self->slipip && $self->slipip ne '0e0' ) {
904 $reply{$radius_ip} = $self->slipip;
911 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
912 check attributes of this record.
914 Note that this is now the preferred method for reading RADIUS attributes -
915 accessing the columns directly is discouraged, as the column names are
916 expected to change in the future.
922 my $password = $self->_password;
923 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
924 ( $pw_attrib => $self->_password,
927 my($column, $attrib) = ($1, $2);
928 #$attrib =~ s/_/\-/g;
929 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
930 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
936 Returns the domain associated with this account.
942 if ( $self->domsvc ) {
943 #$self->svc_domain->domain;
944 my $svc_domain = $self->svc_domain
945 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
948 $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
954 Returns the FS::svc_domain record for this account's domain (see
963 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
968 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
974 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
979 Returns an email address associated with the account.
985 $self->username. '@'. $self->domain;
990 Returns an array of FS::acct_snarf records associated with the account.
991 If the acct_snarf table does not exist or there are no associated records,
992 an empty list is returned
998 return () unless dbdef->table('acct_snarf');
999 eval "use FS::acct_snarf;";
1001 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1004 =item seconds_since TIMESTAMP
1006 Returns the number of seconds this account has been online since TIMESTAMP,
1007 according to the session monitor (see L<FS::Session>).
1009 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1010 L<Time::Local> and L<Date::Parse> for conversion functions.
1014 #note: POD here, implementation in FS::cust_svc
1017 $self->cust_svc->seconds_since(@_);
1020 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1022 Returns the numbers of seconds this account has been online between
1023 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1024 external SQL radacct table, specified via sqlradius export. Sessions which
1025 started in the specified range but are still open are counted from session
1026 start to the end of the range (unless they are over 1 day old, in which case
1027 they are presumed missing their stop record and not counted). Also, sessions
1028 which end in the range but started earlier are counted from the start of the
1029 range to session end. Finally, sessions which start before the range but end
1030 after are counted for the entire range.
1032 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1033 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1038 #note: POD here, implementation in FS::cust_svc
1039 sub seconds_since_sqlradacct {
1041 $self->cust_svc->seconds_since_sqlradacct(@_);
1044 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1046 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1047 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1048 TIMESTAMP_END (exclusive).
1050 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1051 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1056 #note: POD here, implementation in FS::cust_svc
1057 sub attribute_since_sqlradacct {
1059 $self->cust_svc->attribute_since_sqlradacct(@_);
1063 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1065 Returns an array of hash references of this customers login history for the
1066 given time range. (document this better)
1070 sub get_session_history_sqlradacct {
1072 $self->cust_svc->get_session_history_sqlradacct(@_);
1077 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1083 if ( $self->usergroup ) {
1084 #when provisioning records, export callback runs in svc_Common.pm before
1085 #radius_usergroup records can be inserted...
1086 @{$self->usergroup};
1088 map { $_->groupname }
1089 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1107 use Mail::Internet 1.44;
1110 $opt{mimetype} ||= 'text/plain';
1111 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1113 $ENV{MAILADDRESS} = $opt{from};
1114 my $header = new Mail::Header ( [
1117 "Sender: $opt{from}",
1118 "Reply-To: $opt{from}",
1119 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1120 "Subject: $opt{subject}",
1121 "Content-Type: $opt{mimetype}",
1123 my $message = new Mail::Internet (
1124 'Header' => $header,
1125 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1128 $message->smtpsend( Host => $smtpmachine )
1129 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1130 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1133 =item check_and_rebuild_fuzzyfiles
1137 sub check_and_rebuild_fuzzyfiles {
1138 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1139 -e "$dir/svc_acct.username"
1140 or &rebuild_fuzzyfiles;
1143 =item rebuild_fuzzyfiles
1147 sub rebuild_fuzzyfiles {
1149 use Fcntl qw(:flock);
1151 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1155 open(USERNAMELOCK,">>$dir/svc_acct.username")
1156 or die "can't open $dir/svc_acct.username: $!";
1157 flock(USERNAMELOCK,LOCK_EX)
1158 or die "can't lock $dir/svc_acct.username: $!";
1160 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1162 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1163 or die "can't open $dir/svc_acct.username.tmp: $!";
1164 print USERNAMECACHE join("\n", @all_username), "\n";
1165 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1167 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1177 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1178 open(USERNAMECACHE,"<$dir/svc_acct.username")
1179 or die "can't open $dir/svc_acct.username: $!";
1180 my @array = map { chomp; $_; } <USERNAMECACHE>;
1181 close USERNAMECACHE;
1185 =item append_fuzzyfiles USERNAME
1189 sub append_fuzzyfiles {
1190 my $username = shift;
1192 &check_and_rebuild_fuzzyfiles;
1194 use Fcntl qw(:flock);
1196 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1198 open(USERNAME,">>$dir/svc_acct.username")
1199 or die "can't open $dir/svc_acct.username: $!";
1200 flock(USERNAME,LOCK_EX)
1201 or die "can't lock $dir/svc_acct.username: $!";
1203 print USERNAME "$username\n";
1205 flock(USERNAME,LOCK_UN)
1206 or die "can't unlock $dir/svc_acct.username: $!";
1214 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1218 sub radius_usergroup_selector {
1219 my $sel_groups = shift;
1220 my %sel_groups = map { $_=>1 } @$sel_groups;
1222 my $selectname = shift || 'radius_usergroup';
1225 my $sth = $dbh->prepare(
1226 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1227 ) or die $dbh->errstr;
1228 $sth->execute() or die $sth->errstr;
1229 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1233 function ${selectname}_doadd(object) {
1234 var myvalue = object.${selectname}_add.value;
1235 var optionName = new Option(myvalue,myvalue,false,true);
1236 var length = object.$selectname.length;
1237 object.$selectname.options[length] = optionName;
1238 object.${selectname}_add.value = "";
1241 <SELECT MULTIPLE NAME="$selectname">
1244 foreach my $group ( @all_groups ) {
1246 if ( $sel_groups{$group} ) {
1247 $html .= ' SELECTED';
1248 $sel_groups{$group} = 0;
1250 $html .= ">$group</OPTION>\n";
1252 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1253 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1255 $html .= '</SELECT>';
1257 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1258 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1267 The $recref stuff in sub check should be cleaned up.
1269 The suspend, unsuspend and cancel methods update the database, but not the
1270 current object. This is probably a bug as it's unexpected and
1273 radius_usergroup_selector? putting web ui components in here? they should
1274 probably live somewhere else...
1278 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1279 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1280 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1281 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1282 schema.html from the base documentation.