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', 'last_login' ],
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,
326 label => 'Last login',
330 label => 'Last logout',
337 sub table { 'svc_acct'; }
341 #false laziness with edit/svc_acct.cgi
343 my( $self, $groups ) = @_;
344 if ( ref($groups) eq 'ARRAY' ) {
346 } elsif ( length($groups) ) {
347 [ split(/\s*,\s*/, $groups) ];
356 shift->_lastlog('in', @_);
360 shift->_lastlog('out', @_);
364 my( $self, $op, $time ) = @_;
366 if ( defined($time) ) {
367 warn "$me last_log$op called on svcnum ". $self->svcnum.
368 ' ('. $self->email. "): $time\n"
373 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
377 my $sth = $dbh->prepare( $sql )
378 or die "Error preparing $sql: ". $dbh->errstr;
379 my $rv = $sth->execute($time, $self->svcnum);
380 die "Error executing $sql: ". $sth->errstr
382 die "Can't update last_log$op for svcnum". $self->svcnum
385 $self->{'Hash'}->{"last_log$op"} = $time;
387 $self->getfield("last_log$op");
391 =item search_sql STRING
393 Class method which returns an SQL fragment to search for the given string.
398 my( $class, $string ) = @_;
399 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
400 my( $username, $domain ) = ( $1, $2 );
401 my $q_username = dbh->quote($username);
402 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
404 "svc_acct.username = $q_username AND ( ".
405 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
410 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
412 $class->search_sql_field('slipip', $string ).
414 $class->search_sql_field('username', $string ).
417 $class->search_sql_field('username', $string);
421 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
423 Returns the "username@domain" string for this account.
425 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
437 =item insert [ , OPTION => VALUE ... ]
439 Adds this account to the database. If there is an error, returns the error,
440 otherwise returns false.
442 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
443 defined. An FS::cust_svc record will be created and inserted.
445 The additional field I<usergroup> can optionally be defined; if so it should
446 contain an arrayref of group names. See L<FS::radius_usergroup>.
448 The additional field I<child_objects> can optionally be defined; if so it
449 should contain an arrayref of FS::tablename objects. They will have their
450 svcnum fields set and will be inserted after this record, but before any
451 exports are run. Each element of the array can also optionally be a
452 two-element array reference containing the child object and the name of an
453 alternate field to be filled in with the newly-inserted svcnum, for example
454 C<[ $svc_forward, 'srcsvc' ]>
456 Currently available options are: I<depend_jobnum>
458 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
459 jobnums), all provisioning jobs will have a dependancy on the supplied
460 jobnum(s) (they will not run until the specific job(s) complete(s)).
462 (TODOC: L<FS::queue> and L<freeside-queued>)
464 (TODOC: new exports!)
473 warn "[$me] insert called on $self: ". Dumper($self).
474 "\nwith options: ". Dumper(%options);
477 local $SIG{HUP} = 'IGNORE';
478 local $SIG{INT} = 'IGNORE';
479 local $SIG{QUIT} = 'IGNORE';
480 local $SIG{TERM} = 'IGNORE';
481 local $SIG{TSTP} = 'IGNORE';
482 local $SIG{PIPE} = 'IGNORE';
484 my $oldAutoCommit = $FS::UID::AutoCommit;
485 local $FS::UID::AutoCommit = 0;
488 my $error = $self->check;
489 return $error if $error;
491 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
492 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
493 unless ( $cust_svc ) {
494 $dbh->rollback if $oldAutoCommit;
495 return "no cust_svc record found for svcnum ". $self->svcnum;
497 $self->pkgnum($cust_svc->pkgnum);
498 $self->svcpart($cust_svc->svcpart);
501 $error = $self->_check_duplicate;
503 $dbh->rollback if $oldAutoCommit;
508 $error = $self->SUPER::insert(
509 'jobnums' => \@jobnums,
510 'child_objects' => $self->child_objects,
514 $dbh->rollback if $oldAutoCommit;
518 if ( $self->usergroup ) {
519 foreach my $groupname ( @{$self->usergroup} ) {
520 my $radius_usergroup = new FS::radius_usergroup ( {
521 svcnum => $self->svcnum,
522 groupname => $groupname,
524 my $error = $radius_usergroup->insert;
526 $dbh->rollback if $oldAutoCommit;
532 unless ( $skip_fuzzyfiles ) {
533 $error = $self->queue_fuzzyfiles_update;
535 $dbh->rollback if $oldAutoCommit;
536 return "updating fuzzy search cache: $error";
540 my $cust_pkg = $self->cust_svc->cust_pkg;
543 my $cust_main = $cust_pkg->cust_main;
544 my $agentnum = $cust_main->agentnum;
546 if ( $conf->exists('emailinvoiceautoalways')
547 || $conf->exists('emailinvoiceauto')
548 && ! $cust_main->invoicing_list_emailonly
550 my @invoicing_list = $cust_main->invoicing_list;
551 push @invoicing_list, $self->email;
552 $cust_main->invoicing_list(\@invoicing_list);
556 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
557 = ('','','','','','');
559 if ( $conf->exists('welcome_email', $agentnum) ) {
560 $welcome_template = new Text::Template (
562 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
563 ) or warn "can't create welcome email template: $Text::Template::ERROR";
564 $welcome_from = $conf->config('welcome_email-from', $agentnum);
565 # || 'your-isp-is-dum'
566 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
568 $welcome_subject_template = new Text::Template (
570 SOURCE => $welcome_subject,
571 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
572 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
575 if ( $welcome_template && $cust_pkg ) {
576 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
580 'custnum' => $self->custnum,
581 'username' => $self->username,
582 'password' => $self->_password,
583 'first' => $cust_main->first,
584 'last' => $cust_main->getfield('last'),
585 'pkg' => $cust_pkg->part_pkg->pkg,
587 my $wqueue = new FS::queue {
588 'svcnum' => $self->svcnum,
589 'job' => 'FS::svc_acct::send_email'
591 my $error = $wqueue->insert(
593 'from' => $welcome_from,
594 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
595 'mimetype' => $welcome_mimetype,
596 'body' => $welcome_template->fill_in( HASH => \%hash, ),
599 $dbh->rollback if $oldAutoCommit;
600 return "error queuing welcome email: $error";
603 if ( $options{'depend_jobnum'} ) {
604 warn "$me depend_jobnum found; adding to welcome email dependancies"
606 if ( ref($options{'depend_jobnum'}) ) {
607 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
608 "to welcome email dependancies"
610 push @jobnums, @{ $options{'depend_jobnum'} };
612 warn "$me adding job $options{'depend_jobnum'} ".
613 "to welcome email dependancies"
615 push @jobnums, $options{'depend_jobnum'};
619 foreach my $jobnum ( @jobnums ) {
620 my $error = $wqueue->depend_insert($jobnum);
622 $dbh->rollback if $oldAutoCommit;
623 return "error queuing welcome email job dependancy: $error";
633 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
639 Deletes this account from the database. If there is an error, returns the
640 error, otherwise returns false.
642 The corresponding FS::cust_svc record will be deleted as well.
644 (TODOC: new exports!)
651 return "can't delete system account" if $self->_check_system;
653 return "Can't delete an account which is a (svc_forward) source!"
654 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
656 return "Can't delete an account which is a (svc_forward) destination!"
657 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
659 return "Can't delete an account with (svc_www) web service!"
660 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
662 # what about records in session ? (they should refer to history table)
664 local $SIG{HUP} = 'IGNORE';
665 local $SIG{INT} = 'IGNORE';
666 local $SIG{QUIT} = 'IGNORE';
667 local $SIG{TERM} = 'IGNORE';
668 local $SIG{TSTP} = 'IGNORE';
669 local $SIG{PIPE} = 'IGNORE';
671 my $oldAutoCommit = $FS::UID::AutoCommit;
672 local $FS::UID::AutoCommit = 0;
675 foreach my $cust_main_invoice (
676 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
678 unless ( defined($cust_main_invoice) ) {
679 warn "WARNING: something's wrong with qsearch";
682 my %hash = $cust_main_invoice->hash;
683 $hash{'dest'} = $self->email;
684 my $new = new FS::cust_main_invoice \%hash;
685 my $error = $new->replace($cust_main_invoice);
687 $dbh->rollback if $oldAutoCommit;
692 foreach my $svc_domain (
693 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
695 my %hash = new FS::svc_domain->hash;
696 $hash{'catchall'} = '';
697 my $new = new FS::svc_domain \%hash;
698 my $error = $new->replace($svc_domain);
700 $dbh->rollback if $oldAutoCommit;
705 my $error = $self->SUPER::delete;
707 $dbh->rollback if $oldAutoCommit;
711 foreach my $radius_usergroup (
712 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
714 my $error = $radius_usergroup->delete;
716 $dbh->rollback if $oldAutoCommit;
721 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
725 =item replace OLD_RECORD
727 Replaces OLD_RECORD with this one in the database. If there is an error,
728 returns the error, otherwise returns false.
730 The additional field I<usergroup> can optionally be defined; if so it should
731 contain an arrayref of group names. See L<FS::radius_usergroup>.
737 my ( $new, $old ) = ( shift, shift );
739 warn "$me replacing $old with $new\n" if $DEBUG;
741 # We absolutely have to have an old vs. new record to make this work.
742 if (!defined($old)) {
743 $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
746 return "can't modify system account" if $old->_check_system;
749 #no warnings 'numeric'; #alas, a 5.006-ism
752 foreach my $xid (qw( uid gid )) {
754 return "Can't change $xid!"
755 if ! $conf->exists("svc_acct-edit_$xid")
756 && $old->$xid() != $new->$xid()
757 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
762 #change homdir when we change username
763 $new->setfield('dir', '') if $old->username ne $new->username;
765 local $SIG{HUP} = 'IGNORE';
766 local $SIG{INT} = 'IGNORE';
767 local $SIG{QUIT} = 'IGNORE';
768 local $SIG{TERM} = 'IGNORE';
769 local $SIG{TSTP} = 'IGNORE';
770 local $SIG{PIPE} = 'IGNORE';
772 my $oldAutoCommit = $FS::UID::AutoCommit;
773 local $FS::UID::AutoCommit = 0;
776 # redundant, but so $new->usergroup gets set
777 $error = $new->check;
778 return $error if $error;
780 $old->usergroup( [ $old->radius_groups ] );
782 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
783 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
785 if ( $new->usergroup ) {
786 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
787 my @newgroups = @{$new->usergroup};
788 foreach my $oldgroup ( @{$old->usergroup} ) {
789 if ( grep { $oldgroup eq $_ } @newgroups ) {
790 @newgroups = grep { $oldgroup ne $_ } @newgroups;
793 my $radius_usergroup = qsearchs('radius_usergroup', {
794 svcnum => $old->svcnum,
795 groupname => $oldgroup,
797 my $error = $radius_usergroup->delete;
799 $dbh->rollback if $oldAutoCommit;
800 return "error deleting radius_usergroup $oldgroup: $error";
804 foreach my $newgroup ( @newgroups ) {
805 my $radius_usergroup = new FS::radius_usergroup ( {
806 svcnum => $new->svcnum,
807 groupname => $newgroup,
809 my $error = $radius_usergroup->insert;
811 $dbh->rollback if $oldAutoCommit;
812 return "error adding radius_usergroup $newgroup: $error";
818 if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
819 $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
820 $error = $new->_check_duplicate;
822 $dbh->rollback if $oldAutoCommit;
827 $error = $new->SUPER::replace($old, @_);
829 $dbh->rollback if $oldAutoCommit;
830 return $error if $error;
833 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
834 $error = $new->queue_fuzzyfiles_update;
836 $dbh->rollback if $oldAutoCommit;
837 return "updating fuzzy search cache: $error";
841 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
845 =item queue_fuzzyfiles_update
847 Used by insert & replace to update the fuzzy search cache
851 sub queue_fuzzyfiles_update {
854 local $SIG{HUP} = 'IGNORE';
855 local $SIG{INT} = 'IGNORE';
856 local $SIG{QUIT} = 'IGNORE';
857 local $SIG{TERM} = 'IGNORE';
858 local $SIG{TSTP} = 'IGNORE';
859 local $SIG{PIPE} = 'IGNORE';
861 my $oldAutoCommit = $FS::UID::AutoCommit;
862 local $FS::UID::AutoCommit = 0;
865 my $queue = new FS::queue {
866 'svcnum' => $self->svcnum,
867 'job' => 'FS::svc_acct::append_fuzzyfiles'
869 my $error = $queue->insert($self->username);
871 $dbh->rollback if $oldAutoCommit;
872 return "queueing job (transaction rolled back): $error";
875 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
883 Suspends this account by calling export-specific suspend hooks. If there is
884 an error, returns the error, otherwise returns false.
886 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
892 return "can't suspend system account" if $self->_check_system;
893 $self->SUPER::suspend(@_);
898 Unsuspends this account by by calling export-specific suspend hooks. If there
899 is an error, returns the error, otherwise returns false.
901 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
907 my %hash = $self->hash;
908 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
909 $hash{_password} = $1;
910 my $new = new FS::svc_acct ( \%hash );
911 my $error = $new->replace($self);
912 return $error if $error;
915 $self->SUPER::unsuspend(@_);
920 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
922 If the B<auto_unset_catchall> configuration option is set, this method will
923 automatically remove any references to the canceled service in the catchall
924 field of svc_domain. This allows packages that contain both a svc_domain and
925 its catchall svc_acct to be canceled in one step.
930 # Only one thing to do at this level
932 foreach my $svc_domain (
933 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
934 if($conf->exists('auto_unset_catchall')) {
935 my %hash = $svc_domain->hash;
936 $hash{catchall} = '';
937 my $new = new FS::svc_domain ( \%hash );
938 my $error = $new->replace($svc_domain);
939 return $error if $error;
941 return "cannot unprovision svc_acct #".$self->svcnum.
942 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
946 $self->SUPER::cancel(@_);
952 Checks all fields to make sure this is a valid service. If there is an error,
953 returns the error, otherwise returns false. Called by the insert and replace
956 Sets any fixed values; see L<FS::part_svc>.
963 my($recref) = $self->hashref;
965 my $x = $self->setfixed( $self->_fieldhandlers );
966 return $x unless ref($x);
969 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
971 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
974 my $error = $self->ut_numbern('svcnum')
975 #|| $self->ut_number('domsvc')
976 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
977 || $self->ut_textn('sec_phrase')
978 || $self->ut_snumbern('seconds')
979 || $self->ut_snumbern('upbytes')
980 || $self->ut_snumbern('downbytes')
981 || $self->ut_snumbern('totalbytes')
982 || $self->ut_enum( '_password_encoding',
983 [ '', qw( plain crypt ldap ) ]
986 return $error if $error;
988 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
989 if ( $username_uppercase ) {
990 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
991 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
992 $recref->{username} = $1;
994 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
995 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
996 $recref->{username} = $1;
999 if ( $username_letterfirst ) {
1000 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1001 } elsif ( $username_letter ) {
1002 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1004 if ( $username_noperiod ) {
1005 $recref->{username} =~ /\./ and return gettext('illegal_username');
1007 if ( $username_nounderscore ) {
1008 $recref->{username} =~ /_/ and return gettext('illegal_username');
1010 if ( $username_nodash ) {
1011 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1013 unless ( $username_ampersand ) {
1014 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1016 unless ( $username_percent ) {
1017 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1020 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1021 $recref->{popnum} = $1;
1022 return "Unknown popnum" unless
1023 ! $recref->{popnum} ||
1024 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1026 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1028 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1029 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1031 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1032 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1033 #not all systems use gid=uid
1034 #you can set a fixed gid in part_svc
1036 return "Only root can have uid 0"
1037 if $recref->{uid} == 0
1038 && $recref->{username} !~ /^(root|toor|smtp)$/;
1040 unless ( $recref->{username} eq 'sync' ) {
1041 if ( grep $_ eq $recref->{shell}, @shells ) {
1042 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1044 return "Illegal shell \`". $self->shell. "\'; ".
1045 "shells configuration value contains: @shells";
1048 $recref->{shell} = '/bin/sync';
1052 $recref->{gid} ne '' ?
1053 return "Can't have gid without uid" : ( $recref->{gid}='' );
1054 #$recref->{dir} ne '' ?
1055 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1056 $recref->{shell} ne '' ?
1057 return "Can't have shell without uid" : ( $recref->{shell}='' );
1060 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1062 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1063 or return "Illegal directory: ". $recref->{dir};
1064 $recref->{dir} = $1;
1065 return "Illegal directory"
1066 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1067 return "Illegal directory"
1068 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1069 unless ( $recref->{dir} ) {
1070 $recref->{dir} = $dir_prefix . '/';
1071 if ( $dirhash > 0 ) {
1072 for my $h ( 1 .. $dirhash ) {
1073 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1075 } elsif ( $dirhash < 0 ) {
1076 for my $h ( reverse $dirhash .. -1 ) {
1077 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1080 $recref->{dir} .= $recref->{username};
1086 # $error = $self->ut_textn('finger');
1087 # return $error if $error;
1088 if ( $self->getfield('finger') eq '' ) {
1089 my $cust_pkg = $self->svcnum
1090 ? $self->cust_svc->cust_pkg
1091 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1093 my $cust_main = $cust_pkg->cust_main;
1094 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1097 $self->getfield('finger') =~
1098 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1099 or return "Illegal finger: ". $self->getfield('finger');
1100 $self->setfield('finger', $1);
1102 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1103 $recref->{quota} = $1;
1105 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1106 if ( $recref->{slipip} eq '' ) {
1107 $recref->{slipip} = '';
1108 } elsif ( $recref->{slipip} eq '0e0' ) {
1109 $recref->{slipip} = '0e0';
1111 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1112 or return "Illegal slipip: ". $self->slipip;
1113 $recref->{slipip} = $1;
1118 #arbitrary RADIUS stuff; allow ut_textn for now
1119 foreach ( grep /^radius_/, fields('svc_acct') ) {
1120 $self->ut_textn($_);
1123 if ( $recref->{_password_encoding} eq 'ldap' ) {
1125 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1126 $recref->{_password} = uc($1).$2;
1128 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1131 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1133 if ( $recref->{_password} =~
1134 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1135 /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1138 $recref->{_password} = $1.$2;
1141 return 'Illegal (crypt-encoded) password';
1144 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1146 #generate a password if it is blank
1147 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1148 unless length( $recref->{_password} );
1150 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1151 $recref->{_password} = $1;
1153 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1154 FS::Msgcat::_gettext('illegal_password_characters').
1155 ": ". $recref->{_password};
1158 if ( $password_noampersand ) {
1159 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1161 if ( $password_noexclamation ) {
1162 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1167 #carp "warning: _password_encoding unspecified\n";
1169 #generate a password if it is blank
1170 unless ( length( $recref->{_password} ) ) {
1172 $recref->{_password} =
1173 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1174 $recref->{_password_encoding} = 'plain';
1178 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1179 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1180 $recref->{_password} = $1.$3;
1181 $recref->{_password_encoding} = 'plain';
1182 } elsif ( $recref->{_password} =~
1183 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1185 $recref->{_password} = $1.$3;
1186 $recref->{_password_encoding} = 'crypt';
1187 } elsif ( $recref->{_password} eq '*' ) {
1188 $recref->{_password} = '*';
1189 $recref->{_password_encoding} = 'crypt';
1190 } elsif ( $recref->{_password} eq '!' ) {
1191 $recref->{_password_encoding} = 'crypt';
1192 $recref->{_password} = '!';
1193 } elsif ( $recref->{_password} eq '!!' ) {
1194 $recref->{_password} = '!!';
1195 $recref->{_password_encoding} = 'crypt';
1197 #return "Illegal password";
1198 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1199 FS::Msgcat::_gettext('illegal_password_characters').
1200 ": ". $recref->{_password};
1207 $self->SUPER::check;
1213 Internal function to check the username against the list of system usernames
1214 from the I<system_usernames> configuration value. Returns true if the username
1215 is listed on the system username list.
1221 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1222 $conf->config('system_usernames')
1226 =item _check_duplicate
1228 Internal function to check for duplicates usernames, username@domain pairs and
1231 If the I<global_unique-username> configuration value is set to B<username> or
1232 B<username@domain>, enforces global username or username@domain uniqueness.
1234 In all cases, check for duplicate uids and usernames or username@domain pairs
1235 per export and with identical I<svcpart> values.
1239 sub _check_duplicate {
1242 my $global_unique = $conf->config('global_unique-username') || 'none';
1243 return '' if $global_unique eq 'disabled';
1245 warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1246 if ( driver_name =~ /^Pg/i ) {
1247 dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1249 } elsif ( driver_name =~ /^mysql/i ) {
1250 dbh->do("SELECT * FROM duplicate_lock
1251 WHERE lockname = 'svc_acct'
1253 ) or die dbh->errstr;
1255 die "unknown database ". driver_name.
1256 "; don't know how to lock for duplicate search";
1258 warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1260 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1261 unless ( $part_svc ) {
1262 return 'unknown svcpart '. $self->svcpart;
1265 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1266 qsearch( 'svc_acct', { 'username' => $self->username } );
1267 return gettext('username_in_use')
1268 if $global_unique eq 'username' && @dup_user;
1270 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1271 qsearch( 'svc_acct', { 'username' => $self->username,
1272 'domsvc' => $self->domsvc } );
1273 return gettext('username_in_use')
1274 if $global_unique eq 'username@domain' && @dup_userdomain;
1277 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1278 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1279 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1280 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1285 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1286 my $exports = FS::part_export::export_info('svc_acct');
1287 my %conflict_user_svcpart;
1288 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1290 foreach my $part_export ( $part_svc->part_export ) {
1292 #this will catch to the same exact export
1293 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1295 #this will catch to exports w/same exporthost+type ???
1296 #my @other_part_export = qsearch('part_export', {
1297 # 'machine' => $part_export->machine,
1298 # 'exporttype' => $part_export->exporttype,
1300 #foreach my $other_part_export ( @other_part_export ) {
1301 # push @svcparts, map { $_->svcpart }
1302 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1305 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1306 #silly kludge to avoid uninitialized value errors
1307 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1308 ? $exports->{$part_export->exporttype}{'nodomain'}
1310 if ( $nodomain =~ /^Y/i ) {
1311 $conflict_user_svcpart{$_} = $part_export->exportnum
1314 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1319 foreach my $dup_user ( @dup_user ) {
1320 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1321 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1322 return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1323 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1327 foreach my $dup_userdomain ( @dup_userdomain ) {
1328 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1329 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1330 return "duplicate username\@domain: conflicts with svcnum ".
1331 $dup_userdomain->svcnum. " via exportnum ".
1332 $conflict_userdomain_svcpart{$dup_svcpart};
1336 foreach my $dup_uid ( @dup_uid ) {
1337 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1338 if ( exists($conflict_user_svcpart{$dup_svcpart})
1339 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1340 return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1341 " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1342 || $conflict_userdomain_svcpart{$dup_svcpart};
1354 Depriciated, use radius_reply instead.
1359 carp "FS::svc_acct::radius depriciated, use radius_reply";
1360 $_[0]->radius_reply;
1365 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1366 reply attributes of this record.
1368 Note that this is now the preferred method for reading RADIUS attributes -
1369 accessing the columns directly is discouraged, as the column names are
1370 expected to change in the future.
1377 return %{ $self->{'radius_reply'} }
1378 if exists $self->{'radius_reply'};
1383 my($column, $attrib) = ($1, $2);
1384 #$attrib =~ s/_/\-/g;
1385 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1386 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1388 if ( $self->slipip && $self->slipip ne '0e0' ) {
1389 $reply{$radius_ip} = $self->slipip;
1392 if ( $self->seconds !~ /^$/ ) {
1393 $reply{'Session-Timeout'} = $self->seconds;
1401 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1402 check attributes of this record.
1404 Note that this is now the preferred method for reading RADIUS attributes -
1405 accessing the columns directly is discouraged, as the column names are
1406 expected to change in the future.
1413 return %{ $self->{'radius_check'} }
1414 if exists $self->{'radius_check'};
1419 my($column, $attrib) = ($1, $2);
1420 #$attrib =~ s/_/\-/g;
1421 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1422 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1424 my $password = $self->_password;
1425 my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password'; $check{$pw_attrib} = $password;
1427 my $cust_svc = $self->cust_svc;
1428 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1430 my $cust_pkg = $cust_svc->cust_pkg;
1431 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1432 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1441 This method instructs the object to "snapshot" or freeze RADIUS check and
1442 reply attributes to the current values.
1446 #bah, my english is too broken this morning
1447 #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
1448 #the FS::cust_pkg's replace method to trigger the correct export updates when
1449 #package dates change)
1454 $self->{$_} = { $self->$_() }
1455 foreach qw( radius_reply radius_check );
1459 =item forget_snapshot
1461 This methos instructs the object to forget any previously snapshotted
1462 RADIUS check and reply attributes.
1466 sub forget_snapshot {
1470 foreach qw( radius_reply radius_check );
1474 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1476 Returns the domain associated with this account.
1478 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1485 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1486 my $svc_domain = $self->svc_domain(@_)
1487 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1488 $svc_domain->domain;
1493 Returns the FS::svc_domain record for this account's domain (see
1498 # FS::h_svc_acct has a history-aware svc_domain override
1503 ? $self->{'_domsvc'}
1504 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1509 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1513 #inherited from svc_Common
1515 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1517 Returns an email address associated with the account.
1519 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1526 $self->username. '@'. $self->domain(@_);
1531 Returns an array of FS::acct_snarf records associated with the account.
1532 If the acct_snarf table does not exist or there are no associated records,
1533 an empty list is returned
1539 return () unless dbdef->table('acct_snarf');
1540 eval "use FS::acct_snarf;";
1542 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1545 =item decrement_upbytes OCTETS
1547 Decrements the I<upbytes> field of this record by the given amount. If there
1548 is an error, returns the error, otherwise returns false.
1552 sub decrement_upbytes {
1553 shift->_op_usage('-', 'upbytes', @_);
1556 =item increment_upbytes OCTETS
1558 Increments the I<upbytes> field of this record by the given amount. If there
1559 is an error, returns the error, otherwise returns false.
1563 sub increment_upbytes {
1564 shift->_op_usage('+', 'upbytes', @_);
1567 =item decrement_downbytes OCTETS
1569 Decrements the I<downbytes> field of this record by the given amount. If there
1570 is an error, returns the error, otherwise returns false.
1574 sub decrement_downbytes {
1575 shift->_op_usage('-', 'downbytes', @_);
1578 =item increment_downbytes OCTETS
1580 Increments the I<downbytes> field of this record by the given amount. If there
1581 is an error, returns the error, otherwise returns false.
1585 sub increment_downbytes {
1586 shift->_op_usage('+', 'downbytes', @_);
1589 =item decrement_totalbytes OCTETS
1591 Decrements the I<totalbytes> field of this record by the given amount. If there
1592 is an error, returns the error, otherwise returns false.
1596 sub decrement_totalbytes {
1597 shift->_op_usage('-', 'totalbytes', @_);
1600 =item increment_totalbytes OCTETS
1602 Increments the I<totalbytes> field of this record by the given amount. If there
1603 is an error, returns the error, otherwise returns false.
1607 sub increment_totalbytes {
1608 shift->_op_usage('+', 'totalbytes', @_);
1611 =item decrement_seconds SECONDS
1613 Decrements the I<seconds> field of this record by the given amount. If there
1614 is an error, returns the error, otherwise returns false.
1618 sub decrement_seconds {
1619 shift->_op_usage('-', 'seconds', @_);
1622 =item increment_seconds SECONDS
1624 Increments the I<seconds> field of this record by the given amount. If there
1625 is an error, returns the error, otherwise returns false.
1629 sub increment_seconds {
1630 shift->_op_usage('+', 'seconds', @_);
1638 my %op2condition = (
1639 '-' => sub { my($self, $column, $amount) = @_;
1640 $self->$column - $amount <= 0;
1642 '+' => sub { my($self, $column, $amount) = @_;
1643 $self->$column + $amount > 0;
1646 my %op2warncondition = (
1647 '-' => sub { my($self, $column, $amount) = @_;
1648 my $threshold = $column . '_threshold';
1649 $self->$column - $amount <= $self->$threshold + 0;
1651 '+' => sub { my($self, $column, $amount) = @_;
1652 $self->$column + $amount > 0;
1657 my( $self, $op, $column, $amount ) = @_;
1659 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1660 ' ('. $self->email. "): $op $amount\n"
1663 return '' unless $amount;
1665 local $SIG{HUP} = 'IGNORE';
1666 local $SIG{INT} = 'IGNORE';
1667 local $SIG{QUIT} = 'IGNORE';
1668 local $SIG{TERM} = 'IGNORE';
1669 local $SIG{TSTP} = 'IGNORE';
1670 local $SIG{PIPE} = 'IGNORE';
1672 my $oldAutoCommit = $FS::UID::AutoCommit;
1673 local $FS::UID::AutoCommit = 0;
1676 my $sql = "UPDATE svc_acct SET $column = ".
1677 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1678 " $op ? WHERE svcnum = ?";
1682 my $sth = $dbh->prepare( $sql )
1683 or die "Error preparing $sql: ". $dbh->errstr;
1684 my $rv = $sth->execute($amount, $self->svcnum);
1685 die "Error executing $sql: ". $sth->errstr
1686 unless defined($rv);
1687 die "Can't update $column for svcnum". $self->svcnum
1690 my $action = $op2action{$op};
1692 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1693 ( $action eq 'suspend' && !$self->overlimit
1694 || $action eq 'unsuspend' && $self->overlimit )
1696 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1697 if ($part_export->option('overlimit_groups')) {
1699 my $other = new FS::svc_acct $self->hashref;
1700 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1701 ($self, $part_export->option('overlimit_groups'));
1702 $other->usergroup( $groups );
1703 if ($action eq 'suspend'){
1704 $new = $other; $old = $self;
1706 $new = $self; $old = $other;
1708 my $error = $part_export->export_replace($new, $old);
1709 $error ||= $self->overlimit($action);
1711 $dbh->rollback if $oldAutoCommit;
1712 return "Error replacing radius groups in export, ${op}: $error";
1718 if ( $conf->exists("svc_acct-usage_$action")
1719 && &{$op2condition{$op}}($self, $column, $amount) ) {
1720 #my $error = $self->$action();
1721 my $error = $self->cust_svc->cust_pkg->$action();
1722 # $error ||= $self->overlimit($action);
1724 $dbh->rollback if $oldAutoCommit;
1725 return "Error ${action}ing: $error";
1729 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1730 my $wqueue = new FS::queue {
1731 'svcnum' => $self->svcnum,
1732 'job' => 'FS::svc_acct::reached_threshold',
1737 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1741 my $error = $wqueue->insert(
1742 'svcnum' => $self->svcnum,
1744 'column' => $column,
1748 $dbh->rollback if $oldAutoCommit;
1749 return "Error queuing threshold activity: $error";
1753 warn "$me update successful; committing\n"
1755 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1761 my( $self, $valueref ) = @_;
1763 warn "$me set_usage called for svcnum ". $self->svcnum.
1764 ' ('. $self->email. "): ".
1765 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1768 local $SIG{HUP} = 'IGNORE';
1769 local $SIG{INT} = 'IGNORE';
1770 local $SIG{QUIT} = 'IGNORE';
1771 local $SIG{TERM} = 'IGNORE';
1772 local $SIG{TSTP} = 'IGNORE';
1773 local $SIG{PIPE} = 'IGNORE';
1775 local $FS::svc_Common::noexport_hack = 1;
1776 my $oldAutoCommit = $FS::UID::AutoCommit;
1777 local $FS::UID::AutoCommit = 0;
1782 foreach my $field (keys %$valueref){
1783 $reset = 1 if $valueref->{$field};
1784 $self->setfield($field, $valueref->{$field});
1785 $self->setfield( $field.'_threshold',
1786 int($self->getfield($field)
1787 * ( $conf->exists('svc_acct-usage_threshold')
1788 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1793 $handyhash{$field} = $self->getfield($field);
1794 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1796 #my $error = $self->replace; #NO! we avoid the call to ->check for
1797 #die $error if $error; #services not explicity changed via the UI
1799 my $sql = "UPDATE svc_acct SET " .
1800 join (',', map { "$_ = ?" } (keys %handyhash) ).
1801 " WHERE svcnum = ?";
1806 if (scalar(keys %handyhash)) {
1807 my $sth = $dbh->prepare( $sql )
1808 or die "Error preparing $sql: ". $dbh->errstr;
1809 my $rv = $sth->execute((values %handyhash), $self->svcnum);
1810 die "Error executing $sql: ". $sth->errstr
1811 unless defined($rv);
1812 die "Can't update usage for svcnum ". $self->svcnum
1819 if ($self->overlimit) {
1820 $error = $self->overlimit('unsuspend');
1821 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1822 if ($part_export->option('overlimit_groups')) {
1823 my $old = new FS::svc_acct $self->hashref;
1824 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1825 ($self, $part_export->option('overlimit_groups'));
1826 $old->usergroup( $groups );
1827 $error ||= $part_export->export_replace($self, $old);
1832 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1833 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1836 $dbh->rollback if $oldAutoCommit;
1837 return "Error unsuspending: $error";
1841 warn "$me update successful; committing\n"
1843 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1849 =item recharge HASHREF
1851 Increments usage columns by the amount specified in HASHREF as
1852 column=>amount pairs.
1857 my ($self, $vhash) = @_;
1860 warn "[$me] recharge called on $self: ". Dumper($self).
1861 "\nwith vhash: ". Dumper($vhash);
1864 my $oldAutoCommit = $FS::UID::AutoCommit;
1865 local $FS::UID::AutoCommit = 0;
1869 foreach my $column (keys %$vhash){
1870 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1874 $dbh->rollback if $oldAutoCommit;
1876 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1881 =item is_rechargeable
1883 Returns true if this svc_account can be "recharged" and false otherwise.
1887 sub is_rechargable {
1889 $self->seconds ne ''
1890 || $self->upbytes ne ''
1891 || $self->downbytes ne ''
1892 || $self->totalbytes ne '';
1895 =item seconds_since TIMESTAMP
1897 Returns the number of seconds this account has been online since TIMESTAMP,
1898 according to the session monitor (see L<FS::Session>).
1900 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1901 L<Time::Local> and L<Date::Parse> for conversion functions.
1905 #note: POD here, implementation in FS::cust_svc
1908 $self->cust_svc->seconds_since(@_);
1911 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1913 Returns the numbers of seconds this account has been online between
1914 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1915 external SQL radacct table, specified via sqlradius export. Sessions which
1916 started in the specified range but are still open are counted from session
1917 start to the end of the range (unless they are over 1 day old, in which case
1918 they are presumed missing their stop record and not counted). Also, sessions
1919 which end in the range but started earlier are counted from the start of the
1920 range to session end. Finally, sessions which start before the range but end
1921 after are counted for the entire range.
1923 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1924 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1929 #note: POD here, implementation in FS::cust_svc
1930 sub seconds_since_sqlradacct {
1932 $self->cust_svc->seconds_since_sqlradacct(@_);
1935 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1937 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1938 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1939 TIMESTAMP_END (exclusive).
1941 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1942 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1947 #note: POD here, implementation in FS::cust_svc
1948 sub attribute_since_sqlradacct {
1950 $self->cust_svc->attribute_since_sqlradacct(@_);
1953 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1955 Returns an array of hash references of this customers login history for the
1956 given time range. (document this better)
1960 sub get_session_history {
1962 $self->cust_svc->get_session_history(@_);
1965 =item last_login_text
1967 Returns text describing the time of last login.
1971 sub last_login_text {
1973 $self->last_login ? ctime($self->last_login) : 'unknown';
1976 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1981 my($self, $start, $end, %opt ) = @_;
1983 my $did = $self->username; #yup
1985 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1987 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1989 #SELECT $for_update * FROM cdr
1990 # WHERE calldate >= $start #need a conversion
1991 # AND calldate < $end #ditto
1992 # AND ( charged_party = "$did"
1993 # OR charged_party = "$prefix$did" #if length($prefix);
1994 # OR ( ( charged_party IS NULL OR charged_party = '' )
1996 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1999 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2002 if ( length($prefix) ) {
2004 " AND ( charged_party = '$did'
2005 OR charged_party = '$prefix$did'
2006 OR ( ( charged_party IS NULL OR charged_party = '' )
2008 ( src = '$did' OR src = '$prefix$did' )
2014 " AND ( charged_party = '$did'
2015 OR ( ( charged_party IS NULL OR charged_party = '' )
2025 'select' => "$for_update *",
2028 #( freesidestatus IS NULL OR freesidestatus = '' )
2029 'freesidestatus' => '',
2031 'extra_sql' => $charged_or_src,
2039 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2045 if ( $self->usergroup ) {
2046 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2047 unless ref($self->usergroup) eq 'ARRAY';
2048 #when provisioning records, export callback runs in svc_Common.pm before
2049 #radius_usergroup records can be inserted...
2050 @{$self->usergroup};
2052 map { $_->groupname }
2053 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2057 =item clone_suspended
2059 Constructor used by FS::part_export::_export_suspend fallback. Document
2064 sub clone_suspended {
2066 my %hash = $self->hash;
2067 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2068 new FS::svc_acct \%hash;
2071 =item clone_kludge_unsuspend
2073 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2078 sub clone_kludge_unsuspend {
2080 my %hash = $self->hash;
2081 $hash{_password} = '';
2082 new FS::svc_acct \%hash;
2085 =item check_password
2087 Checks the supplied password against the (possibly encrypted) password in the
2088 database. Returns true for a successful authentication, false for no match.
2090 Currently supported encryptions are: classic DES crypt() and MD5
2094 sub check_password {
2095 my($self, $check_password) = @_;
2097 #remove old-style SUSPENDED kludge, they should be allowed to login to
2098 #self-service and pay up
2099 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2101 if ( $self->_password_encoding eq 'ldap' ) {
2103 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2104 return $auth->match($check_password);
2106 } elsif ( $self->_password_encoding eq 'crypt' ) {
2108 my $auth = from_crypt Authen::Passphrase $self->_password;
2109 return $auth->match($check_password);
2111 } elsif ( $self->_password_encoding eq 'plain' ) {
2113 return $check_password eq $password;
2117 #XXX this could be replaced with Authen::Passphrase stuff
2119 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2121 } elsif ( length($password) < 13 ) { #plaintext
2122 $check_password eq $password;
2123 } elsif ( length($password) == 13 ) { #traditional DES crypt
2124 crypt($check_password, $password) eq $password;
2125 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2126 unix_md5_crypt($check_password, $password) eq $password;
2127 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2128 warn "Can't check password: Blowfish encryption not yet supported, ".
2129 "svcnum ". $self->svcnum. "\n";
2132 warn "Can't check password: Unrecognized encryption for svcnum ".
2133 $self->svcnum. "\n";
2141 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2143 Returns an encrypted password, either by passing through an encrypted password
2144 in the database or by encrypting a plaintext password from the database.
2146 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2147 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2148 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2149 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2150 encryption type is only used if the password is not already encrypted in the
2155 sub crypt_password {
2158 if ( $self->_password_encoding eq 'ldap' ) {
2160 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2163 #XXX this could be replaced with Authen::Passphrase stuff
2165 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2166 if ( $encryption eq 'crypt' ) {
2169 $saltset[int(rand(64))].$saltset[int(rand(64))]
2171 } elsif ( $encryption eq 'md5' ) {
2172 unix_md5_crypt( $self->_password );
2173 } elsif ( $encryption eq 'blowfish' ) {
2174 croak "unknown encryption method $encryption";
2176 croak "unknown encryption method $encryption";
2179 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2183 } elsif ( $self->_password_encoding eq 'crypt' ) {
2185 return $self->_password;
2187 } elsif ( $self->_password_encoding eq 'plain' ) {
2189 #XXX this could be replaced with Authen::Passphrase stuff
2191 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2192 if ( $encryption eq 'crypt' ) {
2195 $saltset[int(rand(64))].$saltset[int(rand(64))]
2197 } elsif ( $encryption eq 'md5' ) {
2198 unix_md5_crypt( $self->_password );
2199 } elsif ( $encryption eq 'blowfish' ) {
2200 croak "unknown encryption method $encryption";
2202 croak "unknown encryption method $encryption";
2207 if ( length($self->_password) == 13
2208 || $self->_password =~ /^\$(1|2a?)\$/
2209 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2215 #XXX this could be replaced with Authen::Passphrase stuff
2217 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2218 if ( $encryption eq 'crypt' ) {
2221 $saltset[int(rand(64))].$saltset[int(rand(64))]
2223 } elsif ( $encryption eq 'md5' ) {
2224 unix_md5_crypt( $self->_password );
2225 } elsif ( $encryption eq 'blowfish' ) {
2226 croak "unknown encryption method $encryption";
2228 croak "unknown encryption method $encryption";
2237 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2239 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2240 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2241 "{MD5}5426824942db4253f87a1009fd5d2d4".
2243 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2244 to work the same as the B</crypt_password> method.
2250 #eventually should check a "password-encoding" field
2252 if ( $self->_password_encoding eq 'ldap' ) {
2254 return $self->_password;
2256 } elsif ( $self->_password_encoding eq 'crypt' ) {
2258 if ( length($self->_password) == 13 ) { #crypt
2259 return '{CRYPT}'. $self->_password;
2260 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2262 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2263 # die "Blowfish encryption not supported in this context, svcnum ".
2264 # $self->svcnum. "\n";
2266 warn "encryption method not (yet?) supported in LDAP context";
2267 return '{CRYPT}*'; #unsupported, should not auth
2270 } elsif ( $self->_password_encoding eq 'plain' ) {
2272 return '{PLAIN}'. $self->_password;
2274 #return '{CLEARTEXT}'. $self->_password; #?
2278 if ( length($self->_password) == 13 ) { #crypt
2279 return '{CRYPT}'. $self->_password;
2280 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2282 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2283 warn "Blowfish encryption not supported in this context, svcnum ".
2284 $self->svcnum. "\n";
2287 #are these two necessary anymore?
2288 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2289 return '{SSHA}'. $1;
2290 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2291 return '{NS-MTA-MD5}'. $1;
2294 return '{PLAIN}'. $self->_password;
2296 #return '{CLEARTEXT}'. $self->_password; #?
2298 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2299 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2300 #if ( $encryption eq 'crypt' ) {
2301 # return '{CRYPT}'. crypt(
2303 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2305 #} elsif ( $encryption eq 'md5' ) {
2306 # unix_md5_crypt( $self->_password );
2307 #} elsif ( $encryption eq 'blowfish' ) {
2308 # croak "unknown encryption method $encryption";
2310 # croak "unknown encryption method $encryption";
2318 =item domain_slash_username
2320 Returns $domain/$username/
2324 sub domain_slash_username {
2326 $self->domain. '/'. $self->username. '/';
2329 =item virtual_maildir
2331 Returns $domain/maildirs/$username/
2335 sub virtual_maildir {
2337 $self->domain. '/maildirs/'. $self->username. '/';
2348 This is the FS::svc_acct job-queue-able version. It still uses
2349 FS::Misc::send_email under-the-hood.
2356 eval "use FS::Misc qw(send_email)";
2359 $opt{mimetype} ||= 'text/plain';
2360 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2362 my $error = send_email(
2363 'from' => $opt{from},
2365 'subject' => $opt{subject},
2366 'content-type' => $opt{mimetype},
2367 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2369 die $error if $error;
2372 =item check_and_rebuild_fuzzyfiles
2376 sub check_and_rebuild_fuzzyfiles {
2377 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2378 -e "$dir/svc_acct.username"
2379 or &rebuild_fuzzyfiles;
2382 =item rebuild_fuzzyfiles
2386 sub rebuild_fuzzyfiles {
2388 use Fcntl qw(:flock);
2390 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2394 open(USERNAMELOCK,">>$dir/svc_acct.username")
2395 or die "can't open $dir/svc_acct.username: $!";
2396 flock(USERNAMELOCK,LOCK_EX)
2397 or die "can't lock $dir/svc_acct.username: $!";
2399 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2401 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2402 or die "can't open $dir/svc_acct.username.tmp: $!";
2403 print USERNAMECACHE join("\n", @all_username), "\n";
2404 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2406 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2416 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2417 open(USERNAMECACHE,"<$dir/svc_acct.username")
2418 or die "can't open $dir/svc_acct.username: $!";
2419 my @array = map { chomp; $_; } <USERNAMECACHE>;
2420 close USERNAMECACHE;
2424 =item append_fuzzyfiles USERNAME
2428 sub append_fuzzyfiles {
2429 my $username = shift;
2431 &check_and_rebuild_fuzzyfiles;
2433 use Fcntl qw(:flock);
2435 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2437 open(USERNAME,">>$dir/svc_acct.username")
2438 or die "can't open $dir/svc_acct.username: $!";
2439 flock(USERNAME,LOCK_EX)
2440 or die "can't lock $dir/svc_acct.username: $!";
2442 print USERNAME "$username\n";
2444 flock(USERNAME,LOCK_UN)
2445 or die "can't unlock $dir/svc_acct.username: $!";
2453 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2457 sub radius_usergroup_selector {
2458 my $sel_groups = shift;
2459 my %sel_groups = map { $_=>1 } @$sel_groups;
2461 my $selectname = shift || 'radius_usergroup';
2464 my $sth = $dbh->prepare(
2465 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2466 ) or die $dbh->errstr;
2467 $sth->execute() or die $sth->errstr;
2468 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2472 function ${selectname}_doadd(object) {
2473 var myvalue = object.${selectname}_add.value;
2474 var optionName = new Option(myvalue,myvalue,false,true);
2475 var length = object.$selectname.length;
2476 object.$selectname.options[length] = optionName;
2477 object.${selectname}_add.value = "";
2480 <SELECT MULTIPLE NAME="$selectname">
2483 foreach my $group ( @all_groups ) {
2484 $html .= qq(<OPTION VALUE="$group");
2485 if ( $sel_groups{$group} ) {
2486 $html .= ' SELECTED';
2487 $sel_groups{$group} = 0;
2489 $html .= ">$group</OPTION>\n";
2491 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2492 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2494 $html .= '</SELECT>';
2496 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2497 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2502 =item reached_threshold
2504 Performs some activities when svc_acct thresholds (such as number of seconds
2505 remaining) are reached.
2509 sub reached_threshold {
2512 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2513 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2515 if ( $opt{'op'} eq '+' ){
2516 $svc_acct->setfield( $opt{'column'}.'_threshold',
2517 int($svc_acct->getfield($opt{'column'})
2518 * ( $conf->exists('svc_acct-usage_threshold')
2519 ? $conf->config('svc_acct-usage_threshold')/100
2524 my $error = $svc_acct->replace;
2525 die $error if $error;
2526 }elsif ( $opt{'op'} eq '-' ){
2528 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2529 return '' if ($threshold eq '' );
2531 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2532 my $error = $svc_acct->replace;
2533 die $error if $error; # email next time, i guess
2535 if ( $warning_template ) {
2536 eval "use FS::Misc qw(send_email)";
2539 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2540 my $cust_main = $cust_pkg->cust_main;
2542 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2543 $cust_main->invoicing_list,
2544 ($opt{'to'} ? $opt{'to'} : ())
2547 my $mimetype = $warning_mimetype;
2548 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2550 my $body = $warning_template->fill_in( HASH => {
2551 'custnum' => $cust_main->custnum,
2552 'username' => $svc_acct->username,
2553 'password' => $svc_acct->_password,
2554 'first' => $cust_main->first,
2555 'last' => $cust_main->getfield('last'),
2556 'pkg' => $cust_pkg->part_pkg->pkg,
2557 'column' => $opt{'column'},
2558 'amount' => $opt{'column'} =~/bytes/
2559 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2560 : $svc_acct->getfield($opt{'column'}),
2561 'threshold' => $opt{'column'} =~/bytes/
2562 ? FS::UI::bytecount::display_bytecount($threshold)
2567 my $error = send_email(
2568 'from' => $warning_from,
2570 'subject' => $warning_subject,
2571 'content-type' => $mimetype,
2572 'body' => [ map "$_\n", split("\n", $body) ],
2574 die $error if $error;
2577 die "unknown op: " . $opt{'op'};
2585 The $recref stuff in sub check should be cleaned up.
2587 The suspend, unsuspend and cancel methods update the database, but not the
2588 current object. This is probably a bug as it's unexpected and
2591 radius_usergroup_selector? putting web ui components in here? they should
2592 probably live somewhere else...
2594 insertion of RADIUS group stuff in insert could be done with child_objects now
2595 (would probably clean up export of them too)
2599 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2600 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2601 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2602 L<freeside-queued>), L<FS::svc_acct_pop>,
2603 schema.html from the base documentation.
2607 =item domain_select_hash %OPTIONS
2609 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2610 may at present purchase.
2612 Currently available options are: I<pkgnum> I<svcpart>
2616 sub domain_select_hash {
2617 my ($self, %options) = @_;
2623 $part_svc = $self->part_svc;
2624 $cust_pkg = $self->cust_svc->cust_pkg
2628 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2629 if $options{'svcpart'};
2631 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2632 if $options{'pkgnum'};
2634 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2635 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2636 %domains = map { $_->svcnum => $_->domain }
2637 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2638 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2639 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2640 %domains = map { $_->svcnum => $_->domain }
2641 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2642 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2643 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2645 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2648 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2649 my $svc_domain = qsearchs('svc_domain',
2650 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2651 if ( $svc_domain ) {
2652 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2654 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2655 $part_svc->part_svc_column('domsvc')->columnvalue;