4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
5 $dir_prefix @shells $usernamemin
6 $usernamemax $passwordmin $passwordmax
7 $username_ampersand $username_letter $username_letterfirst
8 $username_noperiod $username_nounderscore $username_nodash
9 $username_uppercase $username_percent
10 $password_noampersand $password_noexclamation
11 $warning_template $warning_from $warning_subject $warning_mimetype
14 $radius_password $radius_ip
20 use Crypt::PasswdMD5 1.2;
22 use Authen::Passphrase;
23 use FS::UID qw( datasrc driver_name );
25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
26 use FS::Msgcat qw(gettext);
27 use FS::UI::bytecount;
32 use FS::cust_main_invoice;
36 use FS::radius_usergroup;
43 @ISA = qw( FS::svc_Common );
46 $me = '[FS::svc_acct]';
48 #ask FS::UID to run this stuff for us later
49 $FS::UID::callback{'FS::svc_acct'} = sub {
51 $dir_prefix = $conf->config('home');
52 @shells = $conf->config('shells');
53 $usernamemin = $conf->config('usernamemin') || 2;
54 $usernamemax = $conf->config('usernamemax');
55 $passwordmin = $conf->config('passwordmin') || 6;
56 $passwordmax = $conf->config('passwordmax') || 8;
57 $username_letter = $conf->exists('username-letter');
58 $username_letterfirst = $conf->exists('username-letterfirst');
59 $username_noperiod = $conf->exists('username-noperiod');
60 $username_nounderscore = $conf->exists('username-nounderscore');
61 $username_nodash = $conf->exists('username-nodash');
62 $username_uppercase = $conf->exists('username-uppercase');
63 $username_ampersand = $conf->exists('username-ampersand');
64 $username_percent = $conf->exists('username-percent');
65 $password_noampersand = $conf->exists('password-noexclamation');
66 $password_noexclamation = $conf->exists('password-noexclamation');
67 $dirhash = $conf->config('dirhash') || 0;
68 if ( $conf->exists('warning_email') ) {
69 $warning_template = new Text::Template (
71 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
72 ) or warn "can't create warning email template: $Text::Template::ERROR";
73 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
74 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
75 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
76 $warning_cc = $conf->config('warning_email-cc');
78 $warning_template = '';
80 $warning_subject = '';
81 $warning_mimetype = '';
84 $smtpmachine = $conf->config('smtpmachine');
85 $radius_password = $conf->config('radius-password') || 'Password';
86 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
87 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
90 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
91 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
95 my ( $hashref, $cache ) = @_;
96 if ( $hashref->{'svc_acct_svcnum'} ) {
97 $self->{'_domsvc'} = FS::svc_domain->new( {
98 'svcnum' => $hashref->{'domsvc'},
99 'domain' => $hashref->{'svc_acct_domain'},
100 'catchall' => $hashref->{'svc_acct_catchall'},
107 FS::svc_acct - Object methods for svc_acct records
113 $record = new FS::svc_acct \%hash;
114 $record = new FS::svc_acct { 'column' => 'value' };
116 $error = $record->insert;
118 $error = $new_record->replace($old_record);
120 $error = $record->delete;
122 $error = $record->check;
124 $error = $record->suspend;
126 $error = $record->unsuspend;
128 $error = $record->cancel;
130 %hash = $record->radius;
132 %hash = $record->radius_reply;
134 %hash = $record->radius_check;
136 $domain = $record->domain;
138 $svc_domain = $record->svc_domain;
140 $email = $record->email;
142 $seconds_since = $record->seconds_since($timestamp);
146 An FS::svc_acct object represents an account. FS::svc_acct inherits from
147 FS::svc_Common. The following fields are currently supported:
151 =item svcnum - primary key (assigned automatcially for new accounts)
155 =item _password - generated if blank
157 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
159 =item sec_phrase - security phrase
161 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
169 =item dir - set automatically if blank (and uid is not)
173 =item quota - (unimplementd)
175 =item slipip - IP address
185 =item domsvc - svcnum from svc_domain
187 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
189 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
199 Creates a new account. To add the account to the database, see L<"insert">.
206 'longname_plural' => 'Access accounts and mailboxes',
207 'sorts' => [ 'username', 'uid', 'seconds' ],
208 'display_weight' => 10,
209 'cancel_weight' => 50,
211 'dir' => 'Home directory',
214 def_label => 'UID (set to fixed and blank for no UIDs)',
217 'slipip' => 'IP address',
218 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
220 label => 'Access number',
222 select_table => 'svc_acct_pop',
223 select_key => 'popnum',
224 select_label => 'city',
230 disable_default => 1,
237 disable_inventory => 1,
240 '_password' => 'Password',
243 def_label => 'GID (when blank, defaults to UID)',
247 #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
249 def_label=> 'Shell (set to blank for no shell tracking)',
251 select_list => [ $conf->config('shells') ],
252 disable_inventory => 1,
255 'finger' => 'Real name (GECOS)',
258 #def_label => 'svcnum from svc_domain',
260 select_table => 'svc_domain',
261 select_key => 'svcnum',
262 select_label => 'domain',
263 disable_inventory => 1,
267 label => 'RADIUS groups',
268 type => 'radius_usergroup_selector',
269 disable_inventory => 1,
272 'seconds' => { label => 'Seconds',
273 label_sort => 'with Time Remaining',
275 disable_inventory => 1,
278 'upbytes' => { label => 'Upload',
280 disable_inventory => 1,
282 'format' => \&FS::UI::bytecount::display_bytecount,
283 'parse' => \&FS::UI::bytecount::parse_bytecount,
285 'downbytes' => { label => 'Download',
287 disable_inventory => 1,
289 'format' => \&FS::UI::bytecount::display_bytecount,
290 'parse' => \&FS::UI::bytecount::parse_bytecount,
292 'totalbytes'=> { label => 'Total up and download',
294 disable_inventory => 1,
296 'format' => \&FS::UI::bytecount::display_bytecount,
297 'parse' => \&FS::UI::bytecount::parse_bytecount,
299 'seconds_threshold' => { label => 'Seconds threshold',
301 disable_inventory => 1,
304 'upbytes_threshold' => { label => 'Upload threshold',
306 disable_inventory => 1,
308 'format' => \&FS::UI::bytecount::display_bytecount,
309 'parse' => \&FS::UI::bytecount::parse_bytecount,
311 'downbytes_threshold' => { label => 'Download threshold',
313 disable_inventory => 1,
315 'format' => \&FS::UI::bytecount::display_bytecount,
316 'parse' => \&FS::UI::bytecount::parse_bytecount,
318 'totalbytes_threshold'=> { label => 'Total up and download threshold',
320 disable_inventory => 1,
322 'format' => \&FS::UI::bytecount::display_bytecount,
323 'parse' => \&FS::UI::bytecount::parse_bytecount,
329 sub table { 'svc_acct'; }
333 #false laziness with edit/svc_acct.cgi
335 my( $self, $groups ) = @_;
336 if ( ref($groups) eq 'ARRAY' ) {
338 } elsif ( length($groups) ) {
339 [ split(/\s*,\s*/, $groups) ];
347 =item search_sql STRING
349 Class method which returns an SQL fragment to search for the given string.
354 my( $class, $string ) = @_;
355 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
356 my( $username, $domain ) = ( $1, $2 );
357 my $q_username = dbh->quote($username);
358 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
360 "svc_acct.username = $q_username AND ( ".
361 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
366 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
368 $class->search_sql_field('slipip', $string ).
370 $class->search_sql_field('username', $string ).
373 $class->search_sql_field('username', $string);
377 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
379 Returns the "username@domain" string for this account.
381 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
393 =item insert [ , OPTION => VALUE ... ]
395 Adds this account to the database. If there is an error, returns the error,
396 otherwise returns false.
398 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
399 defined. An FS::cust_svc record will be created and inserted.
401 The additional field I<usergroup> can optionally be defined; if so it should
402 contain an arrayref of group names. See L<FS::radius_usergroup>.
404 The additional field I<child_objects> can optionally be defined; if so it
405 should contain an arrayref of FS::tablename objects. They will have their
406 svcnum fields set and will be inserted after this record, but before any
407 exports are run. Each element of the array can also optionally be a
408 two-element array reference containing the child object and the name of an
409 alternate field to be filled in with the newly-inserted svcnum, for example
410 C<[ $svc_forward, 'srcsvc' ]>
412 Currently available options are: I<depend_jobnum>
414 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
415 jobnums), all provisioning jobs will have a dependancy on the supplied
416 jobnum(s) (they will not run until the specific job(s) complete(s)).
418 (TODOC: L<FS::queue> and L<freeside-queued>)
420 (TODOC: new exports!)
429 warn "[$me] insert called on $self: ". Dumper($self).
430 "\nwith options: ". Dumper(%options);
433 local $SIG{HUP} = 'IGNORE';
434 local $SIG{INT} = 'IGNORE';
435 local $SIG{QUIT} = 'IGNORE';
436 local $SIG{TERM} = 'IGNORE';
437 local $SIG{TSTP} = 'IGNORE';
438 local $SIG{PIPE} = 'IGNORE';
440 my $oldAutoCommit = $FS::UID::AutoCommit;
441 local $FS::UID::AutoCommit = 0;
444 my $error = $self->check;
445 return $error if $error;
447 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
448 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
449 unless ( $cust_svc ) {
450 $dbh->rollback if $oldAutoCommit;
451 return "no cust_svc record found for svcnum ". $self->svcnum;
453 $self->pkgnum($cust_svc->pkgnum);
454 $self->svcpart($cust_svc->svcpart);
457 $error = $self->_check_duplicate;
459 $dbh->rollback if $oldAutoCommit;
464 $error = $self->SUPER::insert(
465 'jobnums' => \@jobnums,
466 'child_objects' => $self->child_objects,
470 $dbh->rollback if $oldAutoCommit;
474 if ( $self->usergroup ) {
475 foreach my $groupname ( @{$self->usergroup} ) {
476 my $radius_usergroup = new FS::radius_usergroup ( {
477 svcnum => $self->svcnum,
478 groupname => $groupname,
480 my $error = $radius_usergroup->insert;
482 $dbh->rollback if $oldAutoCommit;
488 unless ( $skip_fuzzyfiles ) {
489 $error = $self->queue_fuzzyfiles_update;
491 $dbh->rollback if $oldAutoCommit;
492 return "updating fuzzy search cache: $error";
496 my $cust_pkg = $self->cust_svc->cust_pkg;
499 my $cust_main = $cust_pkg->cust_main;
500 my $agentnum = $cust_main->agentnum;
502 if ( $conf->exists('emailinvoiceautoalways')
503 || $conf->exists('emailinvoiceauto')
504 && ! $cust_main->invoicing_list_emailonly
506 my @invoicing_list = $cust_main->invoicing_list;
507 push @invoicing_list, $self->email;
508 $cust_main->invoicing_list(\@invoicing_list);
512 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
513 = ('','','','','','');
515 if ( $conf->exists('welcome_email', $agentnum) ) {
516 $welcome_template = new Text::Template (
518 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
519 ) or warn "can't create welcome email template: $Text::Template::ERROR";
520 $welcome_from = $conf->config('welcome_email-from', $agentnum);
521 # || 'your-isp-is-dum'
522 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
524 $welcome_subject_template = new Text::Template (
526 SOURCE => $welcome_subject,
527 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
528 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
531 if ( $welcome_template && $cust_pkg ) {
532 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
536 'custnum' => $self->custnum,
537 'username' => $self->username,
538 'password' => $self->_password,
539 'first' => $cust_main->first,
540 'last' => $cust_main->getfield('last'),
541 'pkg' => $cust_pkg->part_pkg->pkg,
543 my $wqueue = new FS::queue {
544 'svcnum' => $self->svcnum,
545 'job' => 'FS::svc_acct::send_email'
547 my $error = $wqueue->insert(
549 'from' => $welcome_from,
550 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
551 'mimetype' => $welcome_mimetype,
552 'body' => $welcome_template->fill_in( HASH => \%hash, ),
555 $dbh->rollback if $oldAutoCommit;
556 return "error queuing welcome email: $error";
559 if ( $options{'depend_jobnum'} ) {
560 warn "$me depend_jobnum found; adding to welcome email dependancies"
562 if ( ref($options{'depend_jobnum'}) ) {
563 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
564 "to welcome email dependancies"
566 push @jobnums, @{ $options{'depend_jobnum'} };
568 warn "$me adding job $options{'depend_jobnum'} ".
569 "to welcome email dependancies"
571 push @jobnums, $options{'depend_jobnum'};
575 foreach my $jobnum ( @jobnums ) {
576 my $error = $wqueue->depend_insert($jobnum);
578 $dbh->rollback if $oldAutoCommit;
579 return "error queuing welcome email job dependancy: $error";
589 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
595 Deletes this account from the database. If there is an error, returns the
596 error, otherwise returns false.
598 The corresponding FS::cust_svc record will be deleted as well.
600 (TODOC: new exports!)
607 return "can't delete system account" if $self->_check_system;
609 return "Can't delete an account which is a (svc_forward) source!"
610 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
612 return "Can't delete an account which is a (svc_forward) destination!"
613 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
615 return "Can't delete an account with (svc_www) web service!"
616 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
618 # what about records in session ? (they should refer to history table)
620 local $SIG{HUP} = 'IGNORE';
621 local $SIG{INT} = 'IGNORE';
622 local $SIG{QUIT} = 'IGNORE';
623 local $SIG{TERM} = 'IGNORE';
624 local $SIG{TSTP} = 'IGNORE';
625 local $SIG{PIPE} = 'IGNORE';
627 my $oldAutoCommit = $FS::UID::AutoCommit;
628 local $FS::UID::AutoCommit = 0;
631 foreach my $cust_main_invoice (
632 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
634 unless ( defined($cust_main_invoice) ) {
635 warn "WARNING: something's wrong with qsearch";
638 my %hash = $cust_main_invoice->hash;
639 $hash{'dest'} = $self->email;
640 my $new = new FS::cust_main_invoice \%hash;
641 my $error = $new->replace($cust_main_invoice);
643 $dbh->rollback if $oldAutoCommit;
648 foreach my $svc_domain (
649 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
651 my %hash = new FS::svc_domain->hash;
652 $hash{'catchall'} = '';
653 my $new = new FS::svc_domain \%hash;
654 my $error = $new->replace($svc_domain);
656 $dbh->rollback if $oldAutoCommit;
661 my $error = $self->SUPER::delete;
663 $dbh->rollback if $oldAutoCommit;
667 foreach my $radius_usergroup (
668 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
670 my $error = $radius_usergroup->delete;
672 $dbh->rollback if $oldAutoCommit;
677 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
681 =item replace OLD_RECORD
683 Replaces OLD_RECORD with this one in the database. If there is an error,
684 returns the error, otherwise returns false.
686 The additional field I<usergroup> can optionally be defined; if so it should
687 contain an arrayref of group names. See L<FS::radius_usergroup>.
693 my ( $new, $old ) = ( shift, shift );
695 warn "$me replacing $old with $new\n" if $DEBUG;
697 # We absolutely have to have an old vs. new record to make this work.
698 if (!defined($old)) {
699 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
702 return "can't modify system account" if $old->_check_system;
705 #no warnings 'numeric'; #alas, a 5.006-ism
708 foreach my $xid (qw( uid gid )) {
710 return "Can't change $xid!"
711 if ! $conf->exists("svc_acct-edit_$xid")
712 && $old->$xid() != $new->$xid()
713 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
718 #change homdir when we change username
719 $new->setfield('dir', '') if $old->username ne $new->username;
721 local $SIG{HUP} = 'IGNORE';
722 local $SIG{INT} = 'IGNORE';
723 local $SIG{QUIT} = 'IGNORE';
724 local $SIG{TERM} = 'IGNORE';
725 local $SIG{TSTP} = 'IGNORE';
726 local $SIG{PIPE} = 'IGNORE';
728 my $oldAutoCommit = $FS::UID::AutoCommit;
729 local $FS::UID::AutoCommit = 0;
732 # redundant, but so $new->usergroup gets set
733 $error = $new->check;
734 return $error if $error;
736 $old->usergroup( [ $old->radius_groups ] );
738 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
739 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
741 if ( $new->usergroup ) {
742 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
743 my @newgroups = @{$new->usergroup};
744 foreach my $oldgroup ( @{$old->usergroup} ) {
745 if ( grep { $oldgroup eq $_ } @newgroups ) {
746 @newgroups = grep { $oldgroup ne $_ } @newgroups;
749 my $radius_usergroup = qsearchs('radius_usergroup', {
750 svcnum => $old->svcnum,
751 groupname => $oldgroup,
753 my $error = $radius_usergroup->delete;
755 $dbh->rollback if $oldAutoCommit;
756 return "error deleting radius_usergroup $oldgroup: $error";
760 foreach my $newgroup ( @newgroups ) {
761 my $radius_usergroup = new FS::radius_usergroup ( {
762 svcnum => $new->svcnum,
763 groupname => $newgroup,
765 my $error = $radius_usergroup->insert;
767 $dbh->rollback if $oldAutoCommit;
768 return "error adding radius_usergroup $newgroup: $error";
774 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
775 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
776 $error = $new->_check_duplicate;
778 $dbh->rollback if $oldAutoCommit;
783 $error = $new->SUPER::replace($old, @_);
785 $dbh->rollback if $oldAutoCommit;
786 return $error if $error;
789 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
790 $error = $new->queue_fuzzyfiles_update;
792 $dbh->rollback if $oldAutoCommit;
793 return "updating fuzzy search cache: $error";
797 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
801 =item queue_fuzzyfiles_update
803 Used by insert & replace to update the fuzzy search cache
807 sub queue_fuzzyfiles_update {
810 local $SIG{HUP} = 'IGNORE';
811 local $SIG{INT} = 'IGNORE';
812 local $SIG{QUIT} = 'IGNORE';
813 local $SIG{TERM} = 'IGNORE';
814 local $SIG{TSTP} = 'IGNORE';
815 local $SIG{PIPE} = 'IGNORE';
817 my $oldAutoCommit = $FS::UID::AutoCommit;
818 local $FS::UID::AutoCommit = 0;
821 my $queue = new FS::queue {
822 'svcnum' => $self->svcnum,
823 'job' => 'FS::svc_acct::append_fuzzyfiles'
825 my $error = $queue->insert($self->username);
827 $dbh->rollback if $oldAutoCommit;
828 return "queueing job (transaction rolled back): $error";
831 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
839 Suspends this account by calling export-specific suspend hooks. If there is
840 an error, returns the error, otherwise returns false.
842 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
848 return "can't suspend system account" if $self->_check_system;
849 $self->SUPER::suspend(@_);
854 Unsuspends this account by by calling export-specific suspend hooks. If there
855 is an error, returns the error, otherwise returns false.
857 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
863 my %hash = $self->hash;
864 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
865 $hash{_password} = $1;
866 my $new = new FS::svc_acct ( \%hash );
867 my $error = $new->replace($self);
868 return $error if $error;
871 $self->SUPER::unsuspend(@_);
876 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
878 If the B<auto_unset_catchall> configuration option is set, this method will
879 automatically remove any references to the canceled service in the catchall
880 field of svc_domain. This allows packages that contain both a svc_domain and
881 its catchall svc_acct to be canceled in one step.
886 # Only one thing to do at this level
888 foreach my $svc_domain (
889 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
890 if($conf->exists('auto_unset_catchall')) {
891 my %hash = $svc_domain->hash;
892 $hash{catchall} = '';
893 my $new = new FS::svc_domain ( \%hash );
894 my $error = $new->replace($svc_domain);
895 return $error if $error;
897 return "cannot unprovision svc_acct #".$self->svcnum.
898 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
902 $self->SUPER::cancel(@_);
908 Checks all fields to make sure this is a valid service. If there is an error,
909 returns the error, otherwise returns false. Called by the insert and replace
912 Sets any fixed values; see L<FS::part_svc>.
919 my($recref) = $self->hashref;
921 my $x = $self->setfixed( $self->_fieldhandlers );
922 return $x unless ref($x);
925 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
927 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
930 my $error = $self->ut_numbern('svcnum')
931 #|| $self->ut_number('domsvc')
932 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
933 || $self->ut_textn('sec_phrase')
934 || $self->ut_snumbern('seconds')
935 || $self->ut_snumbern('upbytes')
936 || $self->ut_snumbern('downbytes')
937 || $self->ut_snumbern('totalbytes')
938 || $self->ut_enum( '_password_encoding',
939 [ '', qw( plain crypt ldap ) ]
942 return $error if $error;
944 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
945 if ( $username_uppercase ) {
946 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
947 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
948 $recref->{username} = $1;
950 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
951 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
952 $recref->{username} = $1;
955 if ( $username_letterfirst ) {
956 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
957 } elsif ( $username_letter ) {
958 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
960 if ( $username_noperiod ) {
961 $recref->{username} =~ /\./ and return gettext('illegal_username');
963 if ( $username_nounderscore ) {
964 $recref->{username} =~ /_/ and return gettext('illegal_username');
966 if ( $username_nodash ) {
967 $recref->{username} =~ /\-/ and return gettext('illegal_username');
969 unless ( $username_ampersand ) {
970 $recref->{username} =~ /\&/ and return gettext('illegal_username');
972 unless ( $username_percent ) {
973 $recref->{username} =~ /\%/ and return gettext('illegal_username');
976 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
977 $recref->{popnum} = $1;
978 return "Unknown popnum" unless
979 ! $recref->{popnum} ||
980 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
982 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
984 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
985 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
987 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
988 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
989 #not all systems use gid=uid
990 #you can set a fixed gid in part_svc
992 return "Only root can have uid 0"
993 if $recref->{uid} == 0
994 && $recref->{username} !~ /^(root|toor|smtp)$/;
996 unless ( $recref->{username} eq 'sync' ) {
997 if ( grep $_ eq $recref->{shell}, @shells ) {
998 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1000 return "Illegal shell \`". $self->shell. "\'; ".
1001 "shells configuration value contains: @shells";
1004 $recref->{shell} = '/bin/sync';
1008 $recref->{gid} ne '' ?
1009 return "Can't have gid without uid" : ( $recref->{gid}='' );
1010 #$recref->{dir} ne '' ?
1011 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1012 $recref->{shell} ne '' ?
1013 return "Can't have shell without uid" : ( $recref->{shell}='' );
1016 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1018 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1019 or return "Illegal directory: ". $recref->{dir};
1020 $recref->{dir} = $1;
1021 return "Illegal directory"
1022 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1023 return "Illegal directory"
1024 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1025 unless ( $recref->{dir} ) {
1026 $recref->{dir} = $dir_prefix . '/';
1027 if ( $dirhash > 0 ) {
1028 for my $h ( 1 .. $dirhash ) {
1029 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1031 } elsif ( $dirhash < 0 ) {
1032 for my $h ( reverse $dirhash .. -1 ) {
1033 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1036 $recref->{dir} .= $recref->{username};
1042 # $error = $self->ut_textn('finger');
1043 # return $error if $error;
1044 if ( $self->getfield('finger') eq '' ) {
1045 my $cust_pkg = $self->svcnum
1046 ? $self->cust_svc->cust_pkg
1047 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1049 my $cust_main = $cust_pkg->cust_main;
1050 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1053 $self->getfield('finger') =~
1054 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1055 or return "Illegal finger: ". $self->getfield('finger');
1056 $self->setfield('finger', $1);
1058 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1059 $recref->{quota} = $1;
1061 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1062 if ( $recref->{slipip} eq '' ) {
1063 $recref->{slipip} = '';
1064 } elsif ( $recref->{slipip} eq '0e0' ) {
1065 $recref->{slipip} = '0e0';
1067 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1068 or return "Illegal slipip: ". $self->slipip;
1069 $recref->{slipip} = $1;
1074 #arbitrary RADIUS stuff; allow ut_textn for now
1075 foreach ( grep /^radius_/, fields('svc_acct') ) {
1076 $self->ut_textn($_);
1079 if ( $recref->{_password_encoding} eq 'ldap' ) {
1081 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1082 $recref->{_password} = uc($1).$2;
1084 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1087 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1089 if ( $recref->{_password} =~
1090 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1091 /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1094 $recref->{_password} = $1.$2;
1097 return 'Illegal (crypt-encoded) password';
1100 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1102 #generate a password if it is blank
1103 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1104 unless length( $recref->{_password} );
1106 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1107 $recref->{_password} = $1;
1109 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1110 FS::Msgcat::_gettext('illegal_password_characters').
1111 ": ". $recref->{_password};
1114 if ( $password_noampersand ) {
1115 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1117 if ( $password_noexclamation ) {
1118 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1123 #carp "warning: _password_encoding unspecified\n";
1125 #generate a password if it is blank
1126 unless ( length( $recref->{_password} ) ) {
1128 $recref->{_password} =
1129 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1130 $recref->{_password_encoding} = 'plain';
1134 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1135 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1136 $recref->{_password} = $1.$3;
1137 $recref->{_password_encoding} = 'plain';
1138 } elsif ( $recref->{_password} =~
1139 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1141 $recref->{_password} = $1.$3;
1142 $recref->{_password_encoding} = 'crypt';
1143 } elsif ( $recref->{_password} eq '*' ) {
1144 $recref->{_password} = '*';
1145 $recref->{_password_encoding} = 'crypt';
1146 } elsif ( $recref->{_password} eq '!' ) {
1147 $recref->{_password_encoding} = 'crypt';
1148 $recref->{_password} = '!';
1149 } elsif ( $recref->{_password} eq '!!' ) {
1150 $recref->{_password} = '!!';
1151 $recref->{_password_encoding} = 'crypt';
1153 #return "Illegal password";
1154 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1155 FS::Msgcat::_gettext('illegal_password_characters').
1156 ": ". $recref->{_password};
1163 $self->SUPER::check;
1169 Internal function to check the username against the list of system usernames
1170 from the I<system_usernames> configuration value. Returns true if the username
1171 is listed on the system username list.
1177 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1178 $conf->config('system_usernames')
1182 =item _check_duplicate
1184 Internal function to check for duplicates usernames, username@domain pairs and
1187 If the I<global_unique-username> configuration value is set to B<username> or
1188 B<username@domain>, enforces global username or username@domain uniqueness.
1190 In all cases, check for duplicate uids and usernames or username@domain pairs
1191 per export and with identical I<svcpart> values.
1195 sub _check_duplicate {
1198 my $global_unique = $conf->config('global_unique-username') || 'none';
1199 return '' if $global_unique eq 'disabled';
1201 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1202 if ( driver_name =~ /^Pg/i ) {
1203 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1205 } elsif ( driver_name =~ /^mysql/i ) {
1206 dbh->do("SELECT * FROM duplicate_lock
1207 WHERE lockname = 'svc_acct'
1209 ) or die dbh->errstr;
1211 die "unknown database ". driver_name.
1212 "; don't know how to lock for duplicate search";
1214 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1216 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1217 unless ( $part_svc ) {
1218 return 'unknown svcpart '. $self->svcpart;
1221 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1222 qsearch( 'svc_acct', { 'username' => $self->username } );
1223 return gettext('username_in_use')
1224 if $global_unique eq 'username' && @dup_user;
1226 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1227 qsearch( 'svc_acct', { 'username' => $self->username,
1228 'domsvc' => $self->domsvc } );
1229 return gettext('username_in_use')
1230 if $global_unique eq 'username@domain' && @dup_userdomain;
1233 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1234 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1235 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1236 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1241 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1242 my $exports = FS::part_export::export_info('svc_acct');
1243 my %conflict_user_svcpart;
1244 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1246 foreach my $part_export ( $part_svc->part_export ) {
1248 #this will catch to the same exact export
1249 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1251 #this will catch to exports w/same exporthost+type ???
1252 #my @other_part_export = qsearch('part_export', {
1253 # 'machine' => $part_export->machine,
1254 # 'exporttype' => $part_export->exporttype,
1256 #foreach my $other_part_export ( @other_part_export ) {
1257 # push @svcparts, map { $_->svcpart }
1258 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1261 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1262 #silly kludge to avoid uninitialized value errors
1263 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1264 ? $exports->{$part_export->exporttype}{'nodomain'}
1266 if ( $nodomain =~ /^Y/i ) {
1267 $conflict_user_svcpart{$_} = $part_export->exportnum
1270 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1275 foreach my $dup_user ( @dup_user ) {
1276 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1277 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1278 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1279 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1283 foreach my $dup_userdomain ( @dup_userdomain ) {
1284 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1285 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1286 return "duplicate username\@domain: conflicts with svcnum ".
1287 $dup_userdomain->svcnum. " via exportnum ".
1288 $conflict_userdomain_svcpart{$dup_svcpart};
1292 foreach my $dup_uid ( @dup_uid ) {
1293 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1294 if ( exists($conflict_user_svcpart{$dup_svcpart})
1295 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1296 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1297 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1298 || $conflict_userdomain_svcpart{$dup_svcpart};
1310 Depriciated, use radius_reply instead.
1315 carp "FS::svc_acct::radius depriciated, use radius_reply";
1316 $_[0]->radius_reply;
1321 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1322 reply attributes of this record.
1324 Note that this is now the preferred method for reading RADIUS attributes -
1325 accessing the columns directly is discouraged, as the column names are
1326 expected to change in the future.
1333 return %{ $self->{'radius_reply'} }
1334 if exists $self->{'radius_reply'};
1339 my($column, $attrib) = ($1, $2);
1340 #$attrib =~ s/_/\-/g;
1341 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1342 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1344 if ( $self->slipip && $self->slipip ne '0e0' ) {
1345 $reply{$radius_ip} = $self->slipip;
1348 if ( $self->seconds !~ /^$/ ) {
1349 $reply{'Session-Timeout'} = $self->seconds;
1357 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1358 check attributes of this record.
1360 Note that this is now the preferred method for reading RADIUS attributes -
1361 accessing the columns directly is discouraged, as the column names are
1362 expected to change in the future.
1369 return %{ $self->{'radius_check'} }
1370 if exists $self->{'radius_check'};
1375 my($column, $attrib) = ($1, $2);
1376 #$attrib =~ s/_/\-/g;
1377 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1378 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1380 my $password = $self->_password;
1381 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1383 my $cust_svc = $self->cust_svc;
1384 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1386 my $cust_pkg = $cust_svc->cust_pkg;
1387 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1388 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1397 This method instructs the object to "snapshot" or freeze RADIUS check and
1398 reply attributes to the current values.
1402 #bah, my english is too broken this morning
1403 #Of note is the "Expiration" attribute, which, for accounts in prepaid packages, is typically defined on-the-fly as the associated packages cust_pkg.bill. (This is used by
1404 #the FS::cust_pkg's replace method to trigger the correct export updates when
1405 #package dates change)
1410 $self->{$_} = { $self->$_() }
1411 foreach qw( radius_reply radius_check );
1415 =item forget_snapshot
1417 This methos instructs the object to forget any previously snapshotted
1418 RADIUS check and reply attributes.
1422 sub forget_snapshot {
1426 foreach qw( radius_reply radius_check );
1430 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1432 Returns the domain associated with this account.
1434 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1441 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1442 my $svc_domain = $self->svc_domain(@_)
1443 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1444 $svc_domain->domain;
1449 Returns the FS::svc_domain record for this account's domain (see
1454 # FS::h_svc_acct has a history-aware svc_domain override
1459 ? $self->{'_domsvc'}
1460 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1465 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1469 #inherited from svc_Common
1471 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1473 Returns an email address associated with the account.
1475 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1482 $self->username. '@'. $self->domain(@_);
1487 Returns an array of FS::acct_snarf records associated with the account.
1488 If the acct_snarf table does not exist or there are no associated records,
1489 an empty list is returned
1495 return () unless dbdef->table('acct_snarf');
1496 eval "use FS::acct_snarf;";
1498 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1501 =item decrement_upbytes OCTETS
1503 Decrements the I<upbytes> field of this record by the given amount. If there
1504 is an error, returns the error, otherwise returns false.
1508 sub decrement_upbytes {
1509 shift->_op_usage('-', 'upbytes', @_);
1512 =item increment_upbytes OCTETS
1514 Increments the I<upbytes> field of this record by the given amount. If there
1515 is an error, returns the error, otherwise returns false.
1519 sub increment_upbytes {
1520 shift->_op_usage('+', 'upbytes', @_);
1523 =item decrement_downbytes OCTETS
1525 Decrements the I<downbytes> field of this record by the given amount. If there
1526 is an error, returns the error, otherwise returns false.
1530 sub decrement_downbytes {
1531 shift->_op_usage('-', 'downbytes', @_);
1534 =item increment_downbytes OCTETS
1536 Increments the I<downbytes> field of this record by the given amount. If there
1537 is an error, returns the error, otherwise returns false.
1541 sub increment_downbytes {
1542 shift->_op_usage('+', 'downbytes', @_);
1545 =item decrement_totalbytes OCTETS
1547 Decrements the I<totalbytes> field of this record by the given amount. If there
1548 is an error, returns the error, otherwise returns false.
1552 sub decrement_totalbytes {
1553 shift->_op_usage('-', 'totalbytes', @_);
1556 =item increment_totalbytes OCTETS
1558 Increments the I<totalbytes> field of this record by the given amount. If there
1559 is an error, returns the error, otherwise returns false.
1563 sub increment_totalbytes {
1564 shift->_op_usage('+', 'totalbytes', @_);
1567 =item decrement_seconds SECONDS
1569 Decrements the I<seconds> field of this record by the given amount. If there
1570 is an error, returns the error, otherwise returns false.
1574 sub decrement_seconds {
1575 shift->_op_usage('-', 'seconds', @_);
1578 =item increment_seconds SECONDS
1580 Increments the I<seconds> field of this record by the given amount. If there
1581 is an error, returns the error, otherwise returns false.
1585 sub increment_seconds {
1586 shift->_op_usage('+', 'seconds', @_);
1594 my %op2condition = (
1595 '-' => sub { my($self, $column, $amount) = @_;
1596 $self->$column - $amount <= 0;
1598 '+' => sub { my($self, $column, $amount) = @_;
1599 $self->$column + $amount > 0;
1602 my %op2warncondition = (
1603 '-' => sub { my($self, $column, $amount) = @_;
1604 my $threshold = $column . '_threshold';
1605 $self->$column - $amount <= $self->$threshold + 0;
1607 '+' => sub { my($self, $column, $amount) = @_;
1608 $self->$column + $amount > 0;
1613 my( $self, $op, $column, $amount ) = @_;
1615 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1616 ' ('. $self->email. "): $op $amount\n"
1619 return '' unless $amount;
1621 local $SIG{HUP} = 'IGNORE';
1622 local $SIG{INT} = 'IGNORE';
1623 local $SIG{QUIT} = 'IGNORE';
1624 local $SIG{TERM} = 'IGNORE';
1625 local $SIG{TSTP} = 'IGNORE';
1626 local $SIG{PIPE} = 'IGNORE';
1628 my $oldAutoCommit = $FS::UID::AutoCommit;
1629 local $FS::UID::AutoCommit = 0;
1632 my $sql = "UPDATE svc_acct SET $column = ".
1633 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1634 " $op ? WHERE svcnum = ?";
1638 my $sth = $dbh->prepare( $sql )
1639 or die "Error preparing $sql: ". $dbh->errstr;
1640 my $rv = $sth->execute($amount, $self->svcnum);
1641 die "Error executing $sql: ". $sth->errstr
1642 unless defined($rv);
1643 die "Can't update $column for svcnum". $self->svcnum
1646 my $action = $op2action{$op};
1648 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1649 ( $action eq 'suspend' && !$self->overlimit
1650 || $action eq 'unsuspend' && $self->overlimit )
1652 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1653 if ($part_export->option('overlimit_groups')) {
1655 my $other = new FS::svc_acct $self->hashref;
1656 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1657 ($self, $part_export->option('overlimit_groups'));
1658 $other->usergroup( $groups );
1659 if ($action eq 'suspend'){
1660 $new = $other; $old = $self;
1662 $new = $self; $old = $other;
1664 my $error = $part_export->export_replace($new, $old);
1665 $error ||= $self->overlimit($action);
1667 $dbh->rollback if $oldAutoCommit;
1668 return "Error replacing radius groups in export, ${op}: $error";
1674 if ( $conf->exists("svc_acct-usage_$action")
1675 && &{$op2condition{$op}}($self, $column, $amount) ) {
1676 #my $error = $self->$action();
1677 my $error = $self->cust_svc->cust_pkg->$action();
1678 # $error ||= $self->overlimit($action);
1680 $dbh->rollback if $oldAutoCommit;
1681 return "Error ${action}ing: $error";
1685 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1686 my $wqueue = new FS::queue {
1687 'svcnum' => $self->svcnum,
1688 'job' => 'FS::svc_acct::reached_threshold',
1693 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1697 my $error = $wqueue->insert(
1698 'svcnum' => $self->svcnum,
1700 'column' => $column,
1704 $dbh->rollback if $oldAutoCommit;
1705 return "Error queuing threshold activity: $error";
1709 warn "$me update successful; committing\n"
1711 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1717 my( $self, $valueref ) = @_;
1719 warn "$me set_usage called for svcnum ". $self->svcnum.
1720 ' ('. $self->email. "): ".
1721 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1724 local $SIG{HUP} = 'IGNORE';
1725 local $SIG{INT} = 'IGNORE';
1726 local $SIG{QUIT} = 'IGNORE';
1727 local $SIG{TERM} = 'IGNORE';
1728 local $SIG{TSTP} = 'IGNORE';
1729 local $SIG{PIPE} = 'IGNORE';
1731 local $FS::svc_Common::noexport_hack = 1;
1732 my $oldAutoCommit = $FS::UID::AutoCommit;
1733 local $FS::UID::AutoCommit = 0;
1738 foreach my $field (keys %$valueref){
1739 $reset = 1 if $valueref->{$field};
1740 $self->setfield($field, $valueref->{$field});
1741 $self->setfield( $field.'_threshold',
1742 int($self->getfield($field)
1743 * ( $conf->exists('svc_acct-usage_threshold')
1744 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1749 $handyhash{$field} = $self->getfield($field);
1750 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1752 #my $error = $self->replace; #NO! we avoid the call to ->check for
1753 #die $error if $error; #services not explicity changed via the UI
1755 my $sql = "UPDATE svc_acct SET " .
1756 join (',', map { "$_ = ?" } (keys %handyhash) ).
1757 " WHERE svcnum = ?";
1762 if (scalar(keys %handyhash)) {
1763 my $sth = $dbh->prepare( $sql )
1764 or die "Error preparing $sql: ". $dbh->errstr;
1765 my $rv = $sth->execute((values %handyhash), $self->svcnum);
1766 die "Error executing $sql: ". $sth->errstr
1767 unless defined($rv);
1768 die "Can't update usage for svcnum ". $self->svcnum
1775 if ($self->overlimit) {
1776 $error = $self->overlimit('unsuspend');
1777 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1778 if ($part_export->option('overlimit_groups')) {
1779 my $old = new FS::svc_acct $self->hashref;
1780 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1781 ($self, $part_export->option('overlimit_groups'));
1782 $old->usergroup( $groups );
1783 $error ||= $part_export->export_replace($self, $old);
1788 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1789 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1792 $dbh->rollback if $oldAutoCommit;
1793 return "Error unsuspending: $error";
1797 warn "$me update successful; committing\n"
1799 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1805 =item recharge HASHREF
1807 Increments usage columns by the amount specified in HASHREF as
1808 column=>amount pairs.
1813 my ($self, $vhash) = @_;
1816 warn "[$me] recharge called on $self: ". Dumper($self).
1817 "\nwith vhash: ". Dumper($vhash);
1820 my $oldAutoCommit = $FS::UID::AutoCommit;
1821 local $FS::UID::AutoCommit = 0;
1825 foreach my $column (keys %$vhash){
1826 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1830 $dbh->rollback if $oldAutoCommit;
1832 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1837 =item is_rechargeable
1839 Returns true if this svc_account can be "recharged" and false otherwise.
1843 sub is_rechargable {
1845 $self->seconds ne ''
1846 || $self->upbytes ne ''
1847 || $self->downbytes ne ''
1848 || $self->totalbytes ne '';
1851 =item seconds_since TIMESTAMP
1853 Returns the number of seconds this account has been online since TIMESTAMP,
1854 according to the session monitor (see L<FS::Session>).
1856 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1857 L<Time::Local> and L<Date::Parse> for conversion functions.
1861 #note: POD here, implementation in FS::cust_svc
1864 $self->cust_svc->seconds_since(@_);
1867 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1869 Returns the numbers of seconds this account has been online between
1870 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1871 external SQL radacct table, specified via sqlradius export. Sessions which
1872 started in the specified range but are still open are counted from session
1873 start to the end of the range (unless they are over 1 day old, in which case
1874 they are presumed missing their stop record and not counted). Also, sessions
1875 which end in the range but started earlier are counted from the start of the
1876 range to session end. Finally, sessions which start before the range but end
1877 after are counted for the entire range.
1879 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1880 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1885 #note: POD here, implementation in FS::cust_svc
1886 sub seconds_since_sqlradacct {
1888 $self->cust_svc->seconds_since_sqlradacct(@_);
1891 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1893 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1894 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1895 TIMESTAMP_END (exclusive).
1897 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1898 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1903 #note: POD here, implementation in FS::cust_svc
1904 sub attribute_since_sqlradacct {
1906 $self->cust_svc->attribute_since_sqlradacct(@_);
1909 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1911 Returns an array of hash references of this customers login history for the
1912 given time range. (document this better)
1916 sub get_session_history {
1918 $self->cust_svc->get_session_history(@_);
1921 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1926 my($self, $start, $end, %opt ) = @_;
1928 my $did = $self->username; #yup
1930 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1932 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1934 #SELECT $for_update * FROM cdr
1935 # WHERE calldate >= $start #need a conversion
1936 # AND calldate < $end #ditto
1937 # AND ( charged_party = "$did"
1938 # OR charged_party = "$prefix$did" #if length($prefix);
1939 # OR ( ( charged_party IS NULL OR charged_party = '' )
1941 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1944 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
1947 if ( length($prefix) ) {
1949 " AND ( charged_party = '$did'
1950 OR charged_party = '$prefix$did'
1951 OR ( ( charged_party IS NULL OR charged_party = '' )
1953 ( src = '$did' OR src = '$prefix$did' )
1959 " AND ( charged_party = '$did'
1960 OR ( ( charged_party IS NULL OR charged_party = '' )
1970 'select' => "$for_update *",
1973 #( freesidestatus IS NULL OR freesidestatus = '' )
1974 'freesidestatus' => '',
1976 'extra_sql' => $charged_or_src,
1984 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1990 if ( $self->usergroup ) {
1991 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1992 unless ref($self->usergroup) eq 'ARRAY';
1993 #when provisioning records, export callback runs in svc_Common.pm before
1994 #radius_usergroup records can be inserted...
1995 @{$self->usergroup};
1997 map { $_->groupname }
1998 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2002 =item clone_suspended
2004 Constructor used by FS::part_export::_export_suspend fallback. Document
2009 sub clone_suspended {
2011 my %hash = $self->hash;
2012 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2013 new FS::svc_acct \%hash;
2016 =item clone_kludge_unsuspend
2018 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2023 sub clone_kludge_unsuspend {
2025 my %hash = $self->hash;
2026 $hash{_password} = '';
2027 new FS::svc_acct \%hash;
2030 =item check_password
2032 Checks the supplied password against the (possibly encrypted) password in the
2033 database. Returns true for a successful authentication, false for no match.
2035 Currently supported encryptions are: classic DES crypt() and MD5
2039 sub check_password {
2040 my($self, $check_password) = @_;
2042 #remove old-style SUSPENDED kludge, they should be allowed to login to
2043 #self-service and pay up
2044 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2046 if ( $self->_password_encoding eq 'ldap' ) {
2048 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2049 return $auth->match($check_password);
2051 } elsif ( $self->_password_encoding eq 'crypt' ) {
2053 my $auth = from_crypt Authen::Passphrase $self->_password;
2054 return $auth->match($check_password);
2056 } elsif ( $self->_password_encoding eq 'plain' ) {
2058 return $check_password eq $password;
2062 #XXX this could be replaced with Authen::Passphrase stuff
2064 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2066 } elsif ( length($password) < 13 ) { #plaintext
2067 $check_password eq $password;
2068 } elsif ( length($password) == 13 ) { #traditional DES crypt
2069 crypt($check_password, $password) eq $password;
2070 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2071 unix_md5_crypt($check_password, $password) eq $password;
2072 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2073 warn "Can't check password: Blowfish encryption not yet supported, ".
2074 "svcnum ". $self->svcnum. "\n";
2077 warn "Can't check password: Unrecognized encryption for svcnum ".
2078 $self->svcnum. "\n";
2086 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2088 Returns an encrypted password, either by passing through an encrypted password
2089 in the database or by encrypting a plaintext password from the database.
2091 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2092 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2093 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2094 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2095 encryption type is only used if the password is not already encrypted in the
2100 sub crypt_password {
2103 if ( $self->_password_encoding eq 'ldap' ) {
2105 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2108 #XXX this could be replaced with Authen::Passphrase stuff
2110 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2111 if ( $encryption eq 'crypt' ) {
2114 $saltset[int(rand(64))].$saltset[int(rand(64))]
2116 } elsif ( $encryption eq 'md5' ) {
2117 unix_md5_crypt( $self->_password );
2118 } elsif ( $encryption eq 'blowfish' ) {
2119 croak "unknown encryption method $encryption";
2121 croak "unknown encryption method $encryption";
2124 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2128 } elsif ( $self->_password_encoding eq 'crypt' ) {
2130 return $self->_password;
2132 } elsif ( $self->_password_encoding eq 'plain' ) {
2134 #XXX this could be replaced with Authen::Passphrase stuff
2136 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2137 if ( $encryption eq 'crypt' ) {
2140 $saltset[int(rand(64))].$saltset[int(rand(64))]
2142 } elsif ( $encryption eq 'md5' ) {
2143 unix_md5_crypt( $self->_password );
2144 } elsif ( $encryption eq 'blowfish' ) {
2145 croak "unknown encryption method $encryption";
2147 croak "unknown encryption method $encryption";
2152 if ( length($self->_password) == 13
2153 || $self->_password =~ /^\$(1|2a?)\$/
2154 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2160 #XXX this could be replaced with Authen::Passphrase stuff
2162 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2163 if ( $encryption eq 'crypt' ) {
2166 $saltset[int(rand(64))].$saltset[int(rand(64))]
2168 } elsif ( $encryption eq 'md5' ) {
2169 unix_md5_crypt( $self->_password );
2170 } elsif ( $encryption eq 'blowfish' ) {
2171 croak "unknown encryption method $encryption";
2173 croak "unknown encryption method $encryption";
2182 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2184 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2185 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2186 "{MD5}5426824942db4253f87a1009fd5d2d4".
2188 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2189 to work the same as the B</crypt_password> method.
2195 #eventually should check a "password-encoding" field
2197 if ( $self->_password_encoding eq 'ldap' ) {
2199 return $self->_password;
2201 } elsif ( $self->_password_encoding eq 'crypt' ) {
2203 if ( length($self->_password) == 13 ) { #crypt
2204 return '{CRYPT}'. $self->_password;
2205 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2207 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2208 # die "Blowfish encryption not supported in this context, svcnum ".
2209 # $self->svcnum. "\n";
2211 warn "encryption method not (yet?) supported in LDAP context";
2212 return '{CRYPT}*'; #unsupported, should not auth
2215 } elsif ( $self->_password_encoding eq 'plain' ) {
2217 return '{PLAIN}'. $self->_password;
2219 #return '{CLEARTEXT}'. $self->_password; #?
2223 if ( length($self->_password) == 13 ) { #crypt
2224 return '{CRYPT}'. $self->_password;
2225 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2227 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2228 warn "Blowfish encryption not supported in this context, svcnum ".
2229 $self->svcnum. "\n";
2232 #are these two necessary anymore?
2233 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2234 return '{SSHA}'. $1;
2235 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2236 return '{NS-MTA-MD5}'. $1;
2239 return '{PLAIN}'. $self->_password;
2241 #return '{CLEARTEXT}'. $self->_password; #?
2243 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2244 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2245 #if ( $encryption eq 'crypt' ) {
2246 # return '{CRYPT}'. crypt(
2248 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2250 #} elsif ( $encryption eq 'md5' ) {
2251 # unix_md5_crypt( $self->_password );
2252 #} elsif ( $encryption eq 'blowfish' ) {
2253 # croak "unknown encryption method $encryption";
2255 # croak "unknown encryption method $encryption";
2263 =item domain_slash_username
2265 Returns $domain/$username/
2269 sub domain_slash_username {
2271 $self->domain. '/'. $self->username. '/';
2274 =item virtual_maildir
2276 Returns $domain/maildirs/$username/
2280 sub virtual_maildir {
2282 $self->domain. '/maildirs/'. $self->username. '/';
2293 This is the FS::svc_acct job-queue-able version. It still uses
2294 FS::Misc::send_email under-the-hood.
2301 eval "use FS::Misc qw(send_email)";
2304 $opt{mimetype} ||= 'text/plain';
2305 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2307 my $error = send_email(
2308 'from' => $opt{from},
2310 'subject' => $opt{subject},
2311 'content-type' => $opt{mimetype},
2312 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2314 die $error if $error;
2317 =item check_and_rebuild_fuzzyfiles
2321 sub check_and_rebuild_fuzzyfiles {
2322 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2323 -e "$dir/svc_acct.username"
2324 or &rebuild_fuzzyfiles;
2327 =item rebuild_fuzzyfiles
2331 sub rebuild_fuzzyfiles {
2333 use Fcntl qw(:flock);
2335 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2339 open(USERNAMELOCK,">>$dir/svc_acct.username")
2340 or die "can't open $dir/svc_acct.username: $!";
2341 flock(USERNAMELOCK,LOCK_EX)
2342 or die "can't lock $dir/svc_acct.username: $!";
2344 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2346 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2347 or die "can't open $dir/svc_acct.username.tmp: $!";
2348 print USERNAMECACHE join("\n", @all_username), "\n";
2349 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2351 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2361 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2362 open(USERNAMECACHE,"<$dir/svc_acct.username")
2363 or die "can't open $dir/svc_acct.username: $!";
2364 my @array = map { chomp; $_; } <USERNAMECACHE>;
2365 close USERNAMECACHE;
2369 =item append_fuzzyfiles USERNAME
2373 sub append_fuzzyfiles {
2374 my $username = shift;
2376 &check_and_rebuild_fuzzyfiles;
2378 use Fcntl qw(:flock);
2380 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2382 open(USERNAME,">>$dir/svc_acct.username")
2383 or die "can't open $dir/svc_acct.username: $!";
2384 flock(USERNAME,LOCK_EX)
2385 or die "can't lock $dir/svc_acct.username: $!";
2387 print USERNAME "$username\n";
2389 flock(USERNAME,LOCK_UN)
2390 or die "can't unlock $dir/svc_acct.username: $!";
2398 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2402 sub radius_usergroup_selector {
2403 my $sel_groups = shift;
2404 my %sel_groups = map { $_=>1 } @$sel_groups;
2406 my $selectname = shift || 'radius_usergroup';
2409 my $sth = $dbh->prepare(
2410 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2411 ) or die $dbh->errstr;
2412 $sth->execute() or die $sth->errstr;
2413 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2417 function ${selectname}_doadd(object) {
2418 var myvalue = object.${selectname}_add.value;
2419 var optionName = new Option(myvalue,myvalue,false,true);
2420 var length = object.$selectname.length;
2421 object.$selectname.options[length] = optionName;
2422 object.${selectname}_add.value = "";
2425 <SELECT MULTIPLE NAME="$selectname">
2428 foreach my $group ( @all_groups ) {
2429 $html .= qq(<OPTION VALUE="$group");
2430 if ( $sel_groups{$group} ) {
2431 $html .= ' SELECTED';
2432 $sel_groups{$group} = 0;
2434 $html .= ">$group</OPTION>\n";
2436 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2437 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2439 $html .= '</SELECT>';
2441 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2442 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2447 =item reached_threshold
2449 Performs some activities when svc_acct thresholds (such as number of seconds
2450 remaining) are reached.
2454 sub reached_threshold {
2457 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2458 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2460 if ( $opt{'op'} eq '+' ){
2461 $svc_acct->setfield( $opt{'column'}.'_threshold',
2462 int($svc_acct->getfield($opt{'column'})
2463 * ( $conf->exists('svc_acct-usage_threshold')
2464 ? $conf->config('svc_acct-usage_threshold')/100
2469 my $error = $svc_acct->replace;
2470 die $error if $error;
2471 }elsif ( $opt{'op'} eq '-' ){
2473 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2474 return '' if ($threshold eq '' );
2476 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2477 my $error = $svc_acct->replace;
2478 die $error if $error; # email next time, i guess
2480 if ( $warning_template ) {
2481 eval "use FS::Misc qw(send_email)";
2484 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2485 my $cust_main = $cust_pkg->cust_main;
2487 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2488 $cust_main->invoicing_list,
2489 ($opt{'to'} ? $opt{'to'} : ())
2492 my $mimetype = $warning_mimetype;
2493 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2495 my $body = $warning_template->fill_in( HASH => {
2496 'custnum' => $cust_main->custnum,
2497 'username' => $svc_acct->username,
2498 'password' => $svc_acct->_password,
2499 'first' => $cust_main->first,
2500 'last' => $cust_main->getfield('last'),
2501 'pkg' => $cust_pkg->part_pkg->pkg,
2502 'column' => $opt{'column'},
2503 'amount' => $opt{'column'} =~/bytes/
2504 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2505 : $svc_acct->getfield($opt{'column'}),
2506 'threshold' => $opt{'column'} =~/bytes/
2507 ? FS::UI::bytecount::display_bytecount($threshold)
2512 my $error = send_email(
2513 'from' => $warning_from,
2515 'subject' => $warning_subject,
2516 'content-type' => $mimetype,
2517 'body' => [ map "$_\n", split("\n", $body) ],
2519 die $error if $error;
2522 die "unknown op: " . $opt{'op'};
2530 The $recref stuff in sub check should be cleaned up.
2532 The suspend, unsuspend and cancel methods update the database, but not the
2533 current object. This is probably a bug as it's unexpected and
2536 radius_usergroup_selector? putting web ui components in here? they should
2537 probably live somewhere else...
2539 insertion of RADIUS group stuff in insert could be done with child_objects now
2540 (would probably clean up export of them too)
2544 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2545 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2546 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2547 L<freeside-queued>), L<FS::svc_acct_pop>,
2548 schema.html from the base documentation.
2552 =item domain_select_hash %OPTIONS
2554 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2555 may at present purchase.
2557 Currently available options are: I<pkgnum> I<svcpart>
2561 sub domain_select_hash {
2562 my ($self, %options) = @_;
2568 $part_svc = $self->part_svc;
2569 $cust_pkg = $self->cust_svc->cust_pkg
2573 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2574 if $options{'svcpart'};
2576 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2577 if $options{'pkgnum'};
2579 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2580 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2581 %domains = map { $_->svcnum => $_->domain }
2582 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2583 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2584 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2585 %domains = map { $_->svcnum => $_->domain }
2586 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2587 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2588 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2590 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2593 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2594 my $svc_domain = qsearchs('svc_domain',
2595 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2596 if ( $svc_domain ) {
2597 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2599 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2600 $part_svc->part_svc_column('domsvc')->columnvalue;