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 $self->SUPER::suspend;
638 Unsuspends this account by removing *SUSPENDED* from the password. If there is
639 an error, returns the error, otherwise returns false.
641 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
643 Calls any export-specific unsuspend hooks.
649 my %hash = $self->hash;
650 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
651 $hash{_password} = $1;
652 my $new = new FS::svc_acct ( \%hash );
653 my $error = $new->replace($self);
654 return $error if $error;
657 $self->SUPER::unsuspend;
662 Just returns false (no error) for now.
664 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
668 Checks all fields to make sure this is a valid service. If there is an error,
669 returns the error, otherwise returns false. Called by the insert and replace
672 Sets any fixed values; see L<FS::part_svc>.
679 my($recref) = $self->hashref;
681 my $x = $self->setfixed;
682 return $x unless ref($x);
685 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
687 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
690 my $error = $self->ut_numbern('svcnum')
691 #|| $self->ut_number('domsvc')
692 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
693 || $self->ut_textn('sec_phrase')
695 return $error if $error;
697 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
698 if ( $username_uppercase ) {
699 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/i
700 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
701 $recref->{username} = $1;
703 $recref->{username} =~ /^([a-z0-9_\-\.\&]{$usernamemin,$ulen})$/
704 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
705 $recref->{username} = $1;
708 if ( $username_letterfirst ) {
709 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
710 } elsif ( $username_letter ) {
711 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
713 if ( $username_noperiod ) {
714 $recref->{username} =~ /\./ and return gettext('illegal_username');
716 if ( $username_nounderscore ) {
717 $recref->{username} =~ /_/ and return gettext('illegal_username');
719 if ( $username_nodash ) {
720 $recref->{username} =~ /\-/ and return gettext('illegal_username');
722 unless ( $username_ampersand ) {
723 $recref->{username} =~ /\&/ and return gettext('illegal_username');
726 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
727 $recref->{popnum} = $1;
728 return "Unknown popnum" unless
729 ! $recref->{popnum} ||
730 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
732 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
734 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
735 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
737 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
738 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
739 #not all systems use gid=uid
740 #you can set a fixed gid in part_svc
742 return "Only root can have uid 0"
743 if $recref->{uid} == 0
744 && $recref->{username} ne 'root'
745 && $recref->{username} ne 'toor';
748 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
749 or return "Illegal directory: ". $recref->{dir};
751 return "Illegal directory"
752 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
753 return "Illegal directory"
754 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
755 unless ( $recref->{dir} ) {
756 $recref->{dir} = $dir_prefix . '/';
757 if ( $dirhash > 0 ) {
758 for my $h ( 1 .. $dirhash ) {
759 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
761 } elsif ( $dirhash < 0 ) {
762 for my $h ( reverse $dirhash .. -1 ) {
763 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
766 $recref->{dir} .= $recref->{username};
770 unless ( $recref->{username} eq 'sync' ) {
771 if ( grep $_ eq $recref->{shell}, @shells ) {
772 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
774 return "Illegal shell \`". $self->shell. "\'; ".
775 $conf->dir. "/shells contains: @shells";
778 $recref->{shell} = '/bin/sync';
782 $recref->{gid} ne '' ?
783 return "Can't have gid without uid" : ( $recref->{gid}='' );
784 $recref->{dir} ne '' ?
785 return "Can't have directory without uid" : ( $recref->{dir}='' );
786 $recref->{shell} ne '' ?
787 return "Can't have shell without uid" : ( $recref->{shell}='' );
790 # $error = $self->ut_textn('finger');
791 # return $error if $error;
792 $self->getfield('finger') =~
793 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
794 or return "Illegal finger: ". $self->getfield('finger');
795 $self->setfield('finger', $1);
797 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
798 $recref->{quota} = $1;
800 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
801 if ( $recref->{slipip} eq '' ) {
802 $recref->{slipip} = '';
803 } elsif ( $recref->{slipip} eq '0e0' ) {
804 $recref->{slipip} = '0e0';
806 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
807 or return "Illegal slipip". $self->slipip;
808 $recref->{slipip} = $1;
813 #arbitrary RADIUS stuff; allow ut_textn for now
814 foreach ( grep /^radius_/, fields('svc_acct') ) {
818 #generate a password if it is blank
819 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
820 unless ( $recref->{_password} );
822 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
823 if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
824 $recref->{_password} = $1.$3;
825 #uncomment this to encrypt password immediately upon entry, or run
826 #bin/crypt_pw in cron to give new users a window during which their
827 #password is available to techs, for faxing, etc. (also be aware of
829 #$recref->{password} = $1.
830 # crypt($3,$saltset[int(rand(64))].$saltset[int(rand(64))]
832 } elsif ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([\w\.\/\$\;\+]{13,60})$/ ) {
833 $recref->{_password} = $1.$3;
834 } elsif ( $recref->{_password} eq '*' ) {
835 $recref->{_password} = '*';
836 } elsif ( $recref->{_password} eq '!' ) {
837 $recref->{_password} = '!';
838 } elsif ( $recref->{_password} eq '!!' ) {
839 $recref->{_password} = '!!';
841 #return "Illegal password";
842 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
843 FS::Msgcat::_gettext('illegal_password_characters').
844 ": ". $recref->{_password};
856 scalar( grep { $self->username eq $_ || $self->email eq $_ }
857 $conf->config('system_usernames')
864 Depriciated, use radius_reply instead.
869 carp "FS::svc_acct::radius depriciated, use radius_reply";
875 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
876 reply attributes of this record.
878 Note that this is now the preferred method for reading RADIUS attributes -
879 accessing the columns directly is discouraged, as the column names are
880 expected to change in the future.
889 my($column, $attrib) = ($1, $2);
890 #$attrib =~ s/_/\-/g;
891 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
892 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
893 if ( $self->slipip && $self->slipip ne '0e0' ) {
894 $reply{$radius_ip} = $self->slipip;
901 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
902 check attributes of this record.
904 Note that this is now the preferred method for reading RADIUS attributes -
905 accessing the columns directly is discouraged, as the column names are
906 expected to change in the future.
912 my $password = $self->_password;
913 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
914 ( $pw_attrib => $self->_password,
917 my($column, $attrib) = ($1, $2);
918 #$attrib =~ s/_/\-/g;
919 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
920 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table )
926 Returns the domain associated with this account.
932 if ( $self->domsvc ) {
933 #$self->svc_domain->domain;
934 my $svc_domain = $self->svc_domain
935 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
938 $mydomain or die "svc_acct.domsvc is null and no legacy domain config file";
944 Returns the FS::svc_domain record for this account's domain (see
953 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
958 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
964 qsearchs( 'cust_svc', { 'svcnum' => $self->svcnum } );
969 Returns an email address associated with the account.
975 $self->username. '@'. $self->domain;
980 Returns an array of FS::acct_snarf records associated with the account.
981 If the acct_snarf table does not exist or there are no associated records,
982 an empty list is returned
988 return () unless dbdef->table('acct_snarf');
989 eval "use FS::acct_snarf;";
991 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
994 =item seconds_since TIMESTAMP
996 Returns the number of seconds this account has been online since TIMESTAMP,
997 according to the session monitor (see L<FS::Session>).
999 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1000 L<Time::Local> and L<Date::Parse> for conversion functions.
1004 #note: POD here, implementation in FS::cust_svc
1007 $self->cust_svc->seconds_since(@_);
1010 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1012 Returns the numbers of seconds this account has been online between
1013 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1014 external SQL radacct table, specified via sqlradius export. Sessions which
1015 started in the specified range but are still open are counted from session
1016 start to the end of the range (unless they are over 1 day old, in which case
1017 they are presumed missing their stop record and not counted). Also, sessions
1018 which end in the range but started earlier are counted from the start of the
1019 range to session end. Finally, sessions which start before the range but end
1020 after are counted for the entire range.
1022 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1023 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1028 #note: POD here, implementation in FS::cust_svc
1029 sub seconds_since_sqlradacct {
1031 $self->cust_svc->seconds_since_sqlradacct(@_);
1034 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1036 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1037 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1038 TIMESTAMP_END (exclusive).
1040 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1041 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1046 #note: POD here, implementation in FS::cust_svc
1047 sub attribute_since_sqlradacct {
1049 $self->cust_svc->attribute_since_sqlradacct(@_);
1053 =item get_session_history_sqlradacct TIMESTAMP_START TIMESTAMP_END
1055 Returns an array of hash references of this customers login history for the
1056 given time range. (document this better)
1060 sub get_session_history_sqlradacct {
1062 $self->cust_svc->get_session_history_sqlradacct(@_);
1067 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1073 if ( $self->usergroup ) {
1074 #when provisioning records, export callback runs in svc_Common.pm before
1075 #radius_usergroup records can be inserted...
1076 @{$self->usergroup};
1078 map { $_->groupname }
1079 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1097 use Mail::Internet 1.44;
1100 $opt{mimetype} ||= 'text/plain';
1101 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
1103 $ENV{MAILADDRESS} = $opt{from};
1104 my $header = new Mail::Header ( [
1107 "Sender: $opt{from}",
1108 "Reply-To: $opt{from}",
1109 "Date: ". time2str("%a, %d %b %Y %X %z", time),
1110 "Subject: $opt{subject}",
1111 "Content-Type: $opt{mimetype}",
1113 my $message = new Mail::Internet (
1114 'Header' => $header,
1115 'Body' => [ map "$_\n", split("\n", $opt{body}) ],
1118 $message->smtpsend( Host => $smtpmachine )
1119 or $message->smtpsend( Host => $smtpmachine, Debug => 1 )
1120 or die "can't send email to $opt{to} via $smtpmachine with SMTP: $!";
1123 =item check_and_rebuild_fuzzyfiles
1127 sub check_and_rebuild_fuzzyfiles {
1128 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1129 -e "$dir/svc_acct.username"
1130 or &rebuild_fuzzyfiles;
1133 =item rebuild_fuzzyfiles
1137 sub rebuild_fuzzyfiles {
1139 use Fcntl qw(:flock);
1141 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1145 open(USERNAMELOCK,">>$dir/svc_acct.username")
1146 or die "can't open $dir/svc_acct.username: $!";
1147 flock(USERNAMELOCK,LOCK_EX)
1148 or die "can't lock $dir/svc_acct.username: $!";
1150 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
1152 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
1153 or die "can't open $dir/svc_acct.username.tmp: $!";
1154 print USERNAMECACHE join("\n", @all_username), "\n";
1155 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
1157 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
1167 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1168 open(USERNAMECACHE,"<$dir/svc_acct.username")
1169 or die "can't open $dir/svc_acct.username: $!";
1170 my @array = map { chomp; $_; } <USERNAMECACHE>;
1171 close USERNAMECACHE;
1175 =item append_fuzzyfiles USERNAME
1179 sub append_fuzzyfiles {
1180 my $username = shift;
1182 &check_and_rebuild_fuzzyfiles;
1184 use Fcntl qw(:flock);
1186 my $dir = $FS::UID::conf_dir. "cache.". $FS::UID::datasrc;
1188 open(USERNAME,">>$dir/svc_acct.username")
1189 or die "can't open $dir/svc_acct.username: $!";
1190 flock(USERNAME,LOCK_EX)
1191 or die "can't lock $dir/svc_acct.username: $!";
1193 print USERNAME "$username\n";
1195 flock(USERNAME,LOCK_UN)
1196 or die "can't unlock $dir/svc_acct.username: $!";
1204 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
1208 sub radius_usergroup_selector {
1209 my $sel_groups = shift;
1210 my %sel_groups = map { $_=>1 } @$sel_groups;
1212 my $selectname = shift || 'radius_usergroup';
1215 my $sth = $dbh->prepare(
1216 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
1217 ) or die $dbh->errstr;
1218 $sth->execute() or die $sth->errstr;
1219 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
1223 function ${selectname}_doadd(object) {
1224 var myvalue = object.${selectname}_add.value;
1225 var optionName = new Option(myvalue,myvalue,false,true);
1226 var length = object.$selectname.length;
1227 object.$selectname.options[length] = optionName;
1228 object.${selectname}_add.value = "";
1231 <SELECT MULTIPLE NAME="$selectname">
1234 foreach my $group ( @all_groups ) {
1236 if ( $sel_groups{$group} ) {
1237 $html .= ' SELECTED';
1238 $sel_groups{$group} = 0;
1240 $html .= ">$group</OPTION>\n";
1242 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
1243 $html .= "<OPTION SELECTED>$group</OPTION>\n";
1245 $html .= '</SELECT>';
1247 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
1248 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
1257 The $recref stuff in sub check should be cleaned up.
1259 The suspend, unsuspend and cancel methods update the database, but not the
1260 current object. This is probably a bug as it's unexpected and
1263 radius_usergroup_selector? putting web ui components in here? they should
1264 probably live somewhere else...
1268 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
1269 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
1270 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
1271 L<freeside-queued>), L<Net::SSH>, L<ssh>, L<FS::svc_acct_pop>,
1272 schema.html from the base documentation.