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
17 use Scalar::Util qw( blessed );
21 use Crypt::PasswdMD5 1.2;
23 use Authen::Passphrase;
24 use FS::UID qw( datasrc driver_name );
26 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
27 use FS::Msgcat qw(gettext);
28 use FS::UI::bytecount;
33 use FS::cust_main_invoice;
37 use FS::radius_usergroup;
44 @ISA = qw( FS::svc_Common );
47 $me = '[FS::svc_acct]';
49 #ask FS::UID to run this stuff for us later
50 FS::UID->install_callback( sub {
52 $dir_prefix = $conf->config('home');
53 @shells = $conf->config('shells');
54 $usernamemin = $conf->config('usernamemin') || 2;
55 $usernamemax = $conf->config('usernamemax');
56 $passwordmin = $conf->config('passwordmin') || 6;
57 $passwordmax = $conf->config('passwordmax') || 8;
58 $username_letter = $conf->exists('username-letter');
59 $username_letterfirst = $conf->exists('username-letterfirst');
60 $username_noperiod = $conf->exists('username-noperiod');
61 $username_nounderscore = $conf->exists('username-nounderscore');
62 $username_nodash = $conf->exists('username-nodash');
63 $username_uppercase = $conf->exists('username-uppercase');
64 $username_ampersand = $conf->exists('username-ampersand');
65 $username_percent = $conf->exists('username-percent');
66 $password_noampersand = $conf->exists('password-noexclamation');
67 $password_noexclamation = $conf->exists('password-noexclamation');
68 $dirhash = $conf->config('dirhash') || 0;
69 if ( $conf->exists('warning_email') ) {
70 $warning_template = new Text::Template (
72 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
73 ) or warn "can't create warning email template: $Text::Template::ERROR";
74 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
75 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
76 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
77 $warning_cc = $conf->config('warning_email-cc');
79 $warning_template = '';
81 $warning_subject = '';
82 $warning_mimetype = '';
85 $smtpmachine = $conf->config('smtpmachine');
86 $radius_password = $conf->config('radius-password') || 'Password';
87 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
88 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
92 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
93 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
97 my ( $hashref, $cache ) = @_;
98 if ( $hashref->{'svc_acct_svcnum'} ) {
99 $self->{'_domsvc'} = FS::svc_domain->new( {
100 'svcnum' => $hashref->{'domsvc'},
101 'domain' => $hashref->{'svc_acct_domain'},
102 'catchall' => $hashref->{'svc_acct_catchall'},
109 FS::svc_acct - Object methods for svc_acct records
115 $record = new FS::svc_acct \%hash;
116 $record = new FS::svc_acct { 'column' => 'value' };
118 $error = $record->insert;
120 $error = $new_record->replace($old_record);
122 $error = $record->delete;
124 $error = $record->check;
126 $error = $record->suspend;
128 $error = $record->unsuspend;
130 $error = $record->cancel;
132 %hash = $record->radius;
134 %hash = $record->radius_reply;
136 %hash = $record->radius_check;
138 $domain = $record->domain;
140 $svc_domain = $record->svc_domain;
142 $email = $record->email;
144 $seconds_since = $record->seconds_since($timestamp);
148 An FS::svc_acct object represents an account. FS::svc_acct inherits from
149 FS::svc_Common. The following fields are currently supported:
153 =item svcnum - primary key (assigned automatcially for new accounts)
157 =item _password - generated if blank
159 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
161 =item sec_phrase - security phrase
163 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
171 =item dir - set automatically if blank (and uid is not)
175 =item quota - (unimplementd)
177 =item slipip - IP address
187 =item domsvc - svcnum from svc_domain
189 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
191 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
201 Creates a new account. To add the account to the database, see L<"insert">.
208 'longname_plural' => 'Access accounts and mailboxes',
209 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
210 'display_weight' => 10,
211 'cancel_weight' => 50,
213 'dir' => 'Home directory',
216 def_label => 'UID (set to fixed and blank for no UIDs)',
219 'slipip' => 'IP address',
220 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
222 label => 'Access number',
224 select_table => 'svc_acct_pop',
225 select_key => 'popnum',
226 select_label => 'city',
232 disable_default => 1,
239 disable_inventory => 1,
242 '_password' => 'Password',
245 def_label => 'GID (when blank, defaults to UID)',
249 #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)',
251 def_label=> 'Shell (set to blank for no shell tracking)',
253 #select_list => [ $conf->config('shells') ],
254 select_list => [ $conf ? $conf->config('shells') : () ],
255 disable_inventory => 1,
258 'finger' => 'Real name (GECOS)',
261 #def_label => 'svcnum from svc_domain',
263 select_table => 'svc_domain',
264 select_key => 'svcnum',
265 select_label => 'domain',
266 disable_inventory => 1,
270 label => 'RADIUS groups',
271 type => 'radius_usergroup_selector',
272 disable_inventory => 1,
275 'seconds' => { label => 'Seconds',
276 label_sort => 'with Time Remaining',
278 disable_inventory => 1,
281 'upbytes' => { label => 'Upload',
283 disable_inventory => 1,
285 'format' => \&FS::UI::bytecount::display_bytecount,
286 'parse' => \&FS::UI::bytecount::parse_bytecount,
288 'downbytes' => { label => 'Download',
290 disable_inventory => 1,
292 'format' => \&FS::UI::bytecount::display_bytecount,
293 'parse' => \&FS::UI::bytecount::parse_bytecount,
295 'totalbytes'=> { label => 'Total up and download',
297 disable_inventory => 1,
299 'format' => \&FS::UI::bytecount::display_bytecount,
300 'parse' => \&FS::UI::bytecount::parse_bytecount,
302 'seconds_threshold' => { label => 'Seconds threshold',
304 disable_inventory => 1,
307 'upbytes_threshold' => { label => 'Upload threshold',
309 disable_inventory => 1,
311 'format' => \&FS::UI::bytecount::display_bytecount,
312 'parse' => \&FS::UI::bytecount::parse_bytecount,
314 'downbytes_threshold' => { label => 'Download threshold',
316 disable_inventory => 1,
318 'format' => \&FS::UI::bytecount::display_bytecount,
319 'parse' => \&FS::UI::bytecount::parse_bytecount,
321 'totalbytes_threshold'=> { label => 'Total up and download threshold',
323 disable_inventory => 1,
325 'format' => \&FS::UI::bytecount::display_bytecount,
326 'parse' => \&FS::UI::bytecount::parse_bytecount,
329 label => 'Last login',
333 label => 'Last logout',
340 sub table { 'svc_acct'; }
342 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
346 #false laziness with edit/svc_acct.cgi
348 my( $self, $groups ) = @_;
349 if ( ref($groups) eq 'ARRAY' ) {
351 } elsif ( length($groups) ) {
352 [ split(/\s*,\s*/, $groups) ];
361 shift->_lastlog('in', @_);
365 shift->_lastlog('out', @_);
369 my( $self, $op, $time ) = @_;
371 if ( defined($time) ) {
372 warn "$me last_log$op called on svcnum ". $self->svcnum.
373 ' ('. $self->email. "): $time\n"
378 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
382 my $sth = $dbh->prepare( $sql )
383 or die "Error preparing $sql: ". $dbh->errstr;
384 my $rv = $sth->execute($time, $self->svcnum);
385 die "Error executing $sql: ". $sth->errstr
387 die "Can't update last_log$op for svcnum". $self->svcnum
390 $self->{'Hash'}->{"last_log$op"} = $time;
392 $self->getfield("last_log$op");
396 =item search_sql STRING
398 Class method which returns an SQL fragment to search for the given string.
403 my( $class, $string ) = @_;
404 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
405 my( $username, $domain ) = ( $1, $2 );
406 my $q_username = dbh->quote($username);
407 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
409 "svc_acct.username = $q_username AND ( ".
410 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
415 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
417 $class->search_sql_field('slipip', $string ).
419 $class->search_sql_field('username', $string ).
422 $class->search_sql_field('username', $string);
426 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
428 Returns the "username@domain" string for this account.
430 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
442 =item insert [ , OPTION => VALUE ... ]
444 Adds this account to the database. If there is an error, returns the error,
445 otherwise returns false.
447 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
448 defined. An FS::cust_svc record will be created and inserted.
450 The additional field I<usergroup> can optionally be defined; if so it should
451 contain an arrayref of group names. See L<FS::radius_usergroup>.
453 The additional field I<child_objects> can optionally be defined; if so it
454 should contain an arrayref of FS::tablename objects. They will have their
455 svcnum fields set and will be inserted after this record, but before any
456 exports are run. Each element of the array can also optionally be a
457 two-element array reference containing the child object and the name of an
458 alternate field to be filled in with the newly-inserted svcnum, for example
459 C<[ $svc_forward, 'srcsvc' ]>
461 Currently available options are: I<depend_jobnum>
463 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
464 jobnums), all provisioning jobs will have a dependancy on the supplied
465 jobnum(s) (they will not run until the specific job(s) complete(s)).
467 (TODOC: L<FS::queue> and L<freeside-queued>)
469 (TODOC: new exports!)
478 warn "[$me] insert called on $self: ". Dumper($self).
479 "\nwith options: ". Dumper(%options);
482 local $SIG{HUP} = 'IGNORE';
483 local $SIG{INT} = 'IGNORE';
484 local $SIG{QUIT} = 'IGNORE';
485 local $SIG{TERM} = 'IGNORE';
486 local $SIG{TSTP} = 'IGNORE';
487 local $SIG{PIPE} = 'IGNORE';
489 my $oldAutoCommit = $FS::UID::AutoCommit;
490 local $FS::UID::AutoCommit = 0;
493 my $error = $self->check;
494 return $error if $error;
496 if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
497 my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
498 unless ( $cust_svc ) {
499 $dbh->rollback if $oldAutoCommit;
500 return "no cust_svc record found for svcnum ". $self->svcnum;
502 $self->pkgnum($cust_svc->pkgnum);
503 $self->svcpart($cust_svc->svcpart);
507 $error = $self->SUPER::insert(
508 'jobnums' => \@jobnums,
509 'child_objects' => $self->child_objects,
513 $dbh->rollback if $oldAutoCommit;
517 if ( $self->usergroup ) {
518 foreach my $groupname ( @{$self->usergroup} ) {
519 my $radius_usergroup = new FS::radius_usergroup ( {
520 svcnum => $self->svcnum,
521 groupname => $groupname,
523 my $error = $radius_usergroup->insert;
525 $dbh->rollback if $oldAutoCommit;
531 unless ( $skip_fuzzyfiles ) {
532 $error = $self->queue_fuzzyfiles_update;
534 $dbh->rollback if $oldAutoCommit;
535 return "updating fuzzy search cache: $error";
539 my $cust_pkg = $self->cust_svc->cust_pkg;
542 my $cust_main = $cust_pkg->cust_main;
543 my $agentnum = $cust_main->agentnum;
545 if ( $conf->exists('emailinvoiceautoalways')
546 || $conf->exists('emailinvoiceauto')
547 && ! $cust_main->invoicing_list_emailonly
549 my @invoicing_list = $cust_main->invoicing_list;
550 push @invoicing_list, $self->email;
551 $cust_main->invoicing_list(\@invoicing_list);
555 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
556 = ('','','','','','');
558 if ( $conf->exists('welcome_email', $agentnum) ) {
559 $welcome_template = new Text::Template (
561 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
562 ) or warn "can't create welcome email template: $Text::Template::ERROR";
563 $welcome_from = $conf->config('welcome_email-from', $agentnum);
564 # || 'your-isp-is-dum'
565 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
567 $welcome_subject_template = new Text::Template (
569 SOURCE => $welcome_subject,
570 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
571 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
574 if ( $welcome_template && $cust_pkg ) {
575 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
579 'custnum' => $self->custnum,
580 'username' => $self->username,
581 'password' => $self->_password,
582 'first' => $cust_main->first,
583 'last' => $cust_main->getfield('last'),
584 'pkg' => $cust_pkg->part_pkg->pkg,
586 my $wqueue = new FS::queue {
587 'svcnum' => $self->svcnum,
588 'job' => 'FS::svc_acct::send_email'
590 my $error = $wqueue->insert(
592 'from' => $welcome_from,
593 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
594 'mimetype' => $welcome_mimetype,
595 'body' => $welcome_template->fill_in( HASH => \%hash, ),
598 $dbh->rollback if $oldAutoCommit;
599 return "error queuing welcome email: $error";
602 if ( $options{'depend_jobnum'} ) {
603 warn "$me depend_jobnum found; adding to welcome email dependancies"
605 if ( ref($options{'depend_jobnum'}) ) {
606 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
607 "to welcome email dependancies"
609 push @jobnums, @{ $options{'depend_jobnum'} };
611 warn "$me adding job $options{'depend_jobnum'} ".
612 "to welcome email dependancies"
614 push @jobnums, $options{'depend_jobnum'};
618 foreach my $jobnum ( @jobnums ) {
619 my $error = $wqueue->depend_insert($jobnum);
621 $dbh->rollback if $oldAutoCommit;
622 return "error queuing welcome email job dependancy: $error";
632 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
638 Deletes this account from the database. If there is an error, returns the
639 error, otherwise returns false.
641 The corresponding FS::cust_svc record will be deleted as well.
643 (TODOC: new exports!)
650 return "can't delete system account" if $self->_check_system;
652 return "Can't delete an account which is a (svc_forward) source!"
653 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
655 return "Can't delete an account which is a (svc_forward) destination!"
656 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
658 return "Can't delete an account with (svc_www) web service!"
659 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
661 # what about records in session ? (they should refer to history table)
663 local $SIG{HUP} = 'IGNORE';
664 local $SIG{INT} = 'IGNORE';
665 local $SIG{QUIT} = 'IGNORE';
666 local $SIG{TERM} = 'IGNORE';
667 local $SIG{TSTP} = 'IGNORE';
668 local $SIG{PIPE} = 'IGNORE';
670 my $oldAutoCommit = $FS::UID::AutoCommit;
671 local $FS::UID::AutoCommit = 0;
674 foreach my $cust_main_invoice (
675 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
677 unless ( defined($cust_main_invoice) ) {
678 warn "WARNING: something's wrong with qsearch";
681 my %hash = $cust_main_invoice->hash;
682 $hash{'dest'} = $self->email;
683 my $new = new FS::cust_main_invoice \%hash;
684 my $error = $new->replace($cust_main_invoice);
686 $dbh->rollback if $oldAutoCommit;
691 foreach my $svc_domain (
692 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
694 my %hash = new FS::svc_domain->hash;
695 $hash{'catchall'} = '';
696 my $new = new FS::svc_domain \%hash;
697 my $error = $new->replace($svc_domain);
699 $dbh->rollback if $oldAutoCommit;
704 my $error = $self->SUPER::delete;
706 $dbh->rollback if $oldAutoCommit;
710 foreach my $radius_usergroup (
711 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
713 my $error = $radius_usergroup->delete;
715 $dbh->rollback if $oldAutoCommit;
720 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
724 =item replace OLD_RECORD
726 Replaces OLD_RECORD with this one in the database. If there is an error,
727 returns the error, otherwise returns false.
729 The additional field I<usergroup> can optionally be defined; if so it should
730 contain an arrayref of group names. See L<FS::radius_usergroup>.
738 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
742 warn "$me replacing $old with $new\n" if $DEBUG;
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 $error = $new->SUPER::replace($old, @_);
820 $dbh->rollback if $oldAutoCommit;
821 return $error if $error;
824 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
825 $error = $new->queue_fuzzyfiles_update;
827 $dbh->rollback if $oldAutoCommit;
828 return "updating fuzzy search cache: $error";
832 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
836 =item queue_fuzzyfiles_update
838 Used by insert & replace to update the fuzzy search cache
842 sub queue_fuzzyfiles_update {
845 local $SIG{HUP} = 'IGNORE';
846 local $SIG{INT} = 'IGNORE';
847 local $SIG{QUIT} = 'IGNORE';
848 local $SIG{TERM} = 'IGNORE';
849 local $SIG{TSTP} = 'IGNORE';
850 local $SIG{PIPE} = 'IGNORE';
852 my $oldAutoCommit = $FS::UID::AutoCommit;
853 local $FS::UID::AutoCommit = 0;
856 my $queue = new FS::queue {
857 'svcnum' => $self->svcnum,
858 'job' => 'FS::svc_acct::append_fuzzyfiles'
860 my $error = $queue->insert($self->username);
862 $dbh->rollback if $oldAutoCommit;
863 return "queueing job (transaction rolled back): $error";
866 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
874 Suspends this account by calling export-specific suspend hooks. If there is
875 an error, returns the error, otherwise returns false.
877 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
883 return "can't suspend system account" if $self->_check_system;
884 $self->SUPER::suspend(@_);
889 Unsuspends this account by by calling export-specific suspend hooks. If there
890 is an error, returns the error, otherwise returns false.
892 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
898 my %hash = $self->hash;
899 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
900 $hash{_password} = $1;
901 my $new = new FS::svc_acct ( \%hash );
902 my $error = $new->replace($self);
903 return $error if $error;
906 $self->SUPER::unsuspend(@_);
911 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
913 If the B<auto_unset_catchall> configuration option is set, this method will
914 automatically remove any references to the canceled service in the catchall
915 field of svc_domain. This allows packages that contain both a svc_domain and
916 its catchall svc_acct to be canceled in one step.
921 # Only one thing to do at this level
923 foreach my $svc_domain (
924 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
925 if($conf->exists('auto_unset_catchall')) {
926 my %hash = $svc_domain->hash;
927 $hash{catchall} = '';
928 my $new = new FS::svc_domain ( \%hash );
929 my $error = $new->replace($svc_domain);
930 return $error if $error;
932 return "cannot unprovision svc_acct #".$self->svcnum.
933 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
937 $self->SUPER::cancel(@_);
943 Checks all fields to make sure this is a valid service. If there is an error,
944 returns the error, otherwise returns false. Called by the insert and replace
947 Sets any fixed values; see L<FS::part_svc>.
954 my($recref) = $self->hashref;
956 my $x = $self->setfixed( $self->_fieldhandlers );
957 return $x unless ref($x);
960 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
962 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
965 my $error = $self->ut_numbern('svcnum')
966 #|| $self->ut_number('domsvc')
967 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
968 || $self->ut_textn('sec_phrase')
969 || $self->ut_snumbern('seconds')
970 || $self->ut_snumbern('upbytes')
971 || $self->ut_snumbern('downbytes')
972 || $self->ut_snumbern('totalbytes')
973 || $self->ut_enum( '_password_encoding',
974 [ '', qw( plain crypt ldap ) ]
977 return $error if $error;
979 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
980 if ( $username_uppercase ) {
981 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
982 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
983 $recref->{username} = $1;
985 $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
986 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
987 $recref->{username} = $1;
990 if ( $username_letterfirst ) {
991 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
992 } elsif ( $username_letter ) {
993 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
995 if ( $username_noperiod ) {
996 $recref->{username} =~ /\./ and return gettext('illegal_username');
998 if ( $username_nounderscore ) {
999 $recref->{username} =~ /_/ and return gettext('illegal_username');
1001 if ( $username_nodash ) {
1002 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1004 unless ( $username_ampersand ) {
1005 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1007 unless ( $username_percent ) {
1008 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1011 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1012 $recref->{popnum} = $1;
1013 return "Unknown popnum" unless
1014 ! $recref->{popnum} ||
1015 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1017 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1019 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1020 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1022 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1023 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1024 #not all systems use gid=uid
1025 #you can set a fixed gid in part_svc
1027 return "Only root can have uid 0"
1028 if $recref->{uid} == 0
1029 && $recref->{username} !~ /^(root|toor|smtp)$/;
1031 unless ( $recref->{username} eq 'sync' ) {
1032 if ( grep $_ eq $recref->{shell}, @shells ) {
1033 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1035 return "Illegal shell \`". $self->shell. "\'; ".
1036 "shells configuration value contains: @shells";
1039 $recref->{shell} = '/bin/sync';
1043 $recref->{gid} ne '' ?
1044 return "Can't have gid without uid" : ( $recref->{gid}='' );
1045 #$recref->{dir} ne '' ?
1046 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1047 $recref->{shell} ne '' ?
1048 return "Can't have shell without uid" : ( $recref->{shell}='' );
1051 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1053 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1054 or return "Illegal directory: ". $recref->{dir};
1055 $recref->{dir} = $1;
1056 return "Illegal directory"
1057 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1058 return "Illegal directory"
1059 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1060 unless ( $recref->{dir} ) {
1061 $recref->{dir} = $dir_prefix . '/';
1062 if ( $dirhash > 0 ) {
1063 for my $h ( 1 .. $dirhash ) {
1064 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1066 } elsif ( $dirhash < 0 ) {
1067 for my $h ( reverse $dirhash .. -1 ) {
1068 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1071 $recref->{dir} .= $recref->{username};
1077 # $error = $self->ut_textn('finger');
1078 # return $error if $error;
1079 if ( $self->getfield('finger') eq '' ) {
1080 my $cust_pkg = $self->svcnum
1081 ? $self->cust_svc->cust_pkg
1082 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1084 my $cust_main = $cust_pkg->cust_main;
1085 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1088 $self->getfield('finger') =~
1089 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1090 or return "Illegal finger: ". $self->getfield('finger');
1091 $self->setfield('finger', $1);
1093 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1094 $recref->{quota} = $1;
1096 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1097 if ( $recref->{slipip} eq '' ) {
1098 $recref->{slipip} = '';
1099 } elsif ( $recref->{slipip} eq '0e0' ) {
1100 $recref->{slipip} = '0e0';
1102 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1103 or return "Illegal slipip: ". $self->slipip;
1104 $recref->{slipip} = $1;
1109 #arbitrary RADIUS stuff; allow ut_textn for now
1110 foreach ( grep /^radius_/, fields('svc_acct') ) {
1111 $self->ut_textn($_);
1114 if ( $recref->{_password_encoding} eq 'ldap' ) {
1116 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1117 $recref->{_password} = uc($1).$2;
1119 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1122 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1124 if ( $recref->{_password} =~
1125 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1126 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1129 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1132 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1135 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1137 #generate a password if it is blank
1138 $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1139 unless length( $recref->{_password} );
1141 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1142 $recref->{_password} = $1;
1144 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1145 FS::Msgcat::_gettext('illegal_password_characters').
1146 ": ". $recref->{_password};
1149 if ( $password_noampersand ) {
1150 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1152 if ( $password_noexclamation ) {
1153 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1158 #carp "warning: _password_encoding unspecified\n";
1160 #generate a password if it is blank
1161 unless ( length( $recref->{_password} ) ) {
1163 $recref->{_password} =
1164 join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1165 $recref->{_password_encoding} = 'plain';
1169 #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1170 if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1171 $recref->{_password} = $1.$3;
1172 $recref->{_password_encoding} = 'plain';
1173 } elsif ( $recref->{_password} =~
1174 /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1176 $recref->{_password} = $1.$3;
1177 $recref->{_password_encoding} = 'crypt';
1178 } elsif ( $recref->{_password} eq '*' ) {
1179 $recref->{_password} = '*';
1180 $recref->{_password_encoding} = 'crypt';
1181 } elsif ( $recref->{_password} eq '!' ) {
1182 $recref->{_password_encoding} = 'crypt';
1183 $recref->{_password} = '!';
1184 } elsif ( $recref->{_password} eq '!!' ) {
1185 $recref->{_password} = '!!';
1186 $recref->{_password_encoding} = 'crypt';
1188 #return "Illegal password";
1189 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1190 FS::Msgcat::_gettext('illegal_password_characters').
1191 ": ". $recref->{_password};
1198 $self->SUPER::check;
1204 Internal function to check the username against the list of system usernames
1205 from the I<system_usernames> configuration value. Returns true if the username
1206 is listed on the system username list.
1212 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1213 $conf->config('system_usernames')
1217 =item _check_duplicate
1219 Internal method to check for duplicates usernames, username@domain pairs and
1222 If the I<global_unique-username> configuration value is set to B<username> or
1223 B<username@domain>, enforces global username or username@domain uniqueness.
1225 In all cases, check for duplicate uids and usernames or username@domain pairs
1226 per export and with identical I<svcpart> values.
1230 sub _check_duplicate {
1233 my $global_unique = $conf->config('global_unique-username') || 'none';
1234 return '' if $global_unique eq 'disabled';
1238 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1239 unless ( $part_svc ) {
1240 return 'unknown svcpart '. $self->svcpart;
1243 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1244 qsearch( 'svc_acct', { 'username' => $self->username } );
1245 return gettext('username_in_use')
1246 if $global_unique eq 'username' && @dup_user;
1248 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1249 qsearch( 'svc_acct', { 'username' => $self->username,
1250 'domsvc' => $self->domsvc } );
1251 return gettext('username_in_use')
1252 if $global_unique eq 'username@domain' && @dup_userdomain;
1255 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1256 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1257 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1258 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1263 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1264 my $exports = FS::part_export::export_info('svc_acct');
1265 my %conflict_user_svcpart;
1266 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1268 foreach my $part_export ( $part_svc->part_export ) {
1270 #this will catch to the same exact export
1271 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1273 #this will catch to exports w/same exporthost+type ???
1274 #my @other_part_export = qsearch('part_export', {
1275 # 'machine' => $part_export->machine,
1276 # 'exporttype' => $part_export->exporttype,
1278 #foreach my $other_part_export ( @other_part_export ) {
1279 # push @svcparts, map { $_->svcpart }
1280 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1283 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1284 #silly kludge to avoid uninitialized value errors
1285 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1286 ? $exports->{$part_export->exporttype}{'nodomain'}
1288 if ( $nodomain =~ /^Y/i ) {
1289 $conflict_user_svcpart{$_} = $part_export->exportnum
1292 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1297 foreach my $dup_user ( @dup_user ) {
1298 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1299 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1300 return "duplicate username ". $self->username.
1301 ": conflicts with svcnum ". $dup_user->svcnum.
1302 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1306 foreach my $dup_userdomain ( @dup_userdomain ) {
1307 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1308 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1309 return "duplicate username\@domain ". $self->email.
1310 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1311 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1315 foreach my $dup_uid ( @dup_uid ) {
1316 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1317 if ( exists($conflict_user_svcpart{$dup_svcpart})
1318 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1319 return "duplicate uid ". $self->uid.
1320 ": conflicts with svcnum ". $dup_uid->svcnum.
1322 ( $conflict_user_svcpart{$dup_svcpart}
1323 || $conflict_userdomain_svcpart{$dup_svcpart} );
1335 Depriciated, use radius_reply instead.
1340 carp "FS::svc_acct::radius depriciated, use radius_reply";
1341 $_[0]->radius_reply;
1346 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1347 reply attributes of this record.
1349 Note that this is now the preferred method for reading RADIUS attributes -
1350 accessing the columns directly is discouraged, as the column names are
1351 expected to change in the future.
1358 return %{ $self->{'radius_reply'} }
1359 if exists $self->{'radius_reply'};
1364 my($column, $attrib) = ($1, $2);
1365 #$attrib =~ s/_/\-/g;
1366 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1367 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1369 if ( $self->slipip && $self->slipip ne '0e0' ) {
1370 $reply{$radius_ip} = $self->slipip;
1373 if ( $self->seconds !~ /^$/ ) {
1374 $reply{'Session-Timeout'} = $self->seconds;
1382 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1383 check attributes of this record.
1385 Note that this is now the preferred method for reading RADIUS attributes -
1386 accessing the columns directly is discouraged, as the column names are
1387 expected to change in the future.
1394 return %{ $self->{'radius_check'} }
1395 if exists $self->{'radius_check'};
1400 my($column, $attrib) = ($1, $2);
1401 #$attrib =~ s/_/\-/g;
1402 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1403 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1406 my($pw_attrib, $password) = $self->radius_password;
1407 $check{$pw_attrib} = $password;
1409 my $cust_svc = $self->cust_svc;
1410 die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1412 my $cust_pkg = $cust_svc->cust_pkg;
1413 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1414 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1421 =item radius_password
1423 Returns a key/value pair containing the RADIUS attribute name and value
1428 sub radius_password {
1431 my($pw_attrib, $password);
1432 if ( $self->_password_encoding eq 'ldap' ) {
1434 $pw_attrib = 'Password-With-Header';
1435 $password = $self->_password;
1437 } elsif ( $self->_password_encoding eq 'crypt' ) {
1439 $pw_attrib = 'Crypt-Password';
1440 $password = $self->_password;
1442 } elsif ( $self->_password_encoding eq 'plain' ) {
1444 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1445 $password = $self->_password;
1449 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1450 $password = $self->_password;
1454 ($pw_attrib, $password);
1460 This method instructs the object to "snapshot" or freeze RADIUS check and
1461 reply attributes to the current values.
1465 #bah, my english is too broken this morning
1466 #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
1467 #the FS::cust_pkg's replace method to trigger the correct export updates when
1468 #package dates change)
1473 $self->{$_} = { $self->$_() }
1474 foreach qw( radius_reply radius_check );
1478 =item forget_snapshot
1480 This methos instructs the object to forget any previously snapshotted
1481 RADIUS check and reply attributes.
1485 sub forget_snapshot {
1489 foreach qw( radius_reply radius_check );
1493 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1495 Returns the domain associated with this account.
1497 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1504 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1505 my $svc_domain = $self->svc_domain(@_)
1506 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1507 $svc_domain->domain;
1512 Returns the FS::svc_domain record for this account's domain (see
1517 # FS::h_svc_acct has a history-aware svc_domain override
1522 ? $self->{'_domsvc'}
1523 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1528 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1532 #inherited from svc_Common
1534 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1536 Returns an email address associated with the account.
1538 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1545 $self->username. '@'. $self->domain(@_);
1550 Returns an array of FS::acct_snarf records associated with the account.
1551 If the acct_snarf table does not exist or there are no associated records,
1552 an empty list is returned
1558 return () unless dbdef->table('acct_snarf');
1559 eval "use FS::acct_snarf;";
1561 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1564 =item decrement_upbytes OCTETS
1566 Decrements the I<upbytes> field of this record by the given amount. If there
1567 is an error, returns the error, otherwise returns false.
1571 sub decrement_upbytes {
1572 shift->_op_usage('-', 'upbytes', @_);
1575 =item increment_upbytes OCTETS
1577 Increments the I<upbytes> field of this record by the given amount. If there
1578 is an error, returns the error, otherwise returns false.
1582 sub increment_upbytes {
1583 shift->_op_usage('+', 'upbytes', @_);
1586 =item decrement_downbytes OCTETS
1588 Decrements the I<downbytes> field of this record by the given amount. If there
1589 is an error, returns the error, otherwise returns false.
1593 sub decrement_downbytes {
1594 shift->_op_usage('-', 'downbytes', @_);
1597 =item increment_downbytes OCTETS
1599 Increments the I<downbytes> field of this record by the given amount. If there
1600 is an error, returns the error, otherwise returns false.
1604 sub increment_downbytes {
1605 shift->_op_usage('+', 'downbytes', @_);
1608 =item decrement_totalbytes OCTETS
1610 Decrements the I<totalbytes> field of this record by the given amount. If there
1611 is an error, returns the error, otherwise returns false.
1615 sub decrement_totalbytes {
1616 shift->_op_usage('-', 'totalbytes', @_);
1619 =item increment_totalbytes OCTETS
1621 Increments the I<totalbytes> field of this record by the given amount. If there
1622 is an error, returns the error, otherwise returns false.
1626 sub increment_totalbytes {
1627 shift->_op_usage('+', 'totalbytes', @_);
1630 =item decrement_seconds SECONDS
1632 Decrements the I<seconds> field of this record by the given amount. If there
1633 is an error, returns the error, otherwise returns false.
1637 sub decrement_seconds {
1638 shift->_op_usage('-', 'seconds', @_);
1641 =item increment_seconds SECONDS
1643 Increments the I<seconds> field of this record by the given amount. If there
1644 is an error, returns the error, otherwise returns false.
1648 sub increment_seconds {
1649 shift->_op_usage('+', 'seconds', @_);
1657 my %op2condition = (
1658 '-' => sub { my($self, $column, $amount) = @_;
1659 $self->$column - $amount <= 0;
1661 '+' => sub { my($self, $column, $amount) = @_;
1662 $self->$column + $amount > 0;
1665 my %op2warncondition = (
1666 '-' => sub { my($self, $column, $amount) = @_;
1667 my $threshold = $column . '_threshold';
1668 $self->$column - $amount <= $self->$threshold + 0;
1670 '+' => sub { my($self, $column, $amount) = @_;
1671 $self->$column + $amount > 0;
1676 my( $self, $op, $column, $amount ) = @_;
1678 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1679 ' ('. $self->email. "): $op $amount\n"
1682 return '' unless $amount;
1684 local $SIG{HUP} = 'IGNORE';
1685 local $SIG{INT} = 'IGNORE';
1686 local $SIG{QUIT} = 'IGNORE';
1687 local $SIG{TERM} = 'IGNORE';
1688 local $SIG{TSTP} = 'IGNORE';
1689 local $SIG{PIPE} = 'IGNORE';
1691 my $oldAutoCommit = $FS::UID::AutoCommit;
1692 local $FS::UID::AutoCommit = 0;
1695 my $sql = "UPDATE svc_acct SET $column = ".
1696 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1697 " $op ? WHERE svcnum = ?";
1701 my $sth = $dbh->prepare( $sql )
1702 or die "Error preparing $sql: ". $dbh->errstr;
1703 my $rv = $sth->execute($amount, $self->svcnum);
1704 die "Error executing $sql: ". $sth->errstr
1705 unless defined($rv);
1706 die "Can't update $column for svcnum". $self->svcnum
1709 my $action = $op2action{$op};
1711 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1712 ( $action eq 'suspend' && !$self->overlimit
1713 || $action eq 'unsuspend' && $self->overlimit )
1715 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1716 if ($part_export->option('overlimit_groups')) {
1718 my $other = new FS::svc_acct $self->hashref;
1719 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1720 ($self, $part_export->option('overlimit_groups'));
1721 $other->usergroup( $groups );
1722 if ($action eq 'suspend'){
1723 $new = $other; $old = $self;
1725 $new = $self; $old = $other;
1727 my $error = $part_export->export_replace($new, $old);
1728 $error ||= $self->overlimit($action);
1730 $dbh->rollback if $oldAutoCommit;
1731 return "Error replacing radius groups in export, ${op}: $error";
1737 if ( $conf->exists("svc_acct-usage_$action")
1738 && &{$op2condition{$op}}($self, $column, $amount) ) {
1739 #my $error = $self->$action();
1740 my $error = $self->cust_svc->cust_pkg->$action();
1741 # $error ||= $self->overlimit($action);
1743 $dbh->rollback if $oldAutoCommit;
1744 return "Error ${action}ing: $error";
1748 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1749 my $wqueue = new FS::queue {
1750 'svcnum' => $self->svcnum,
1751 'job' => 'FS::svc_acct::reached_threshold',
1756 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1760 my $error = $wqueue->insert(
1761 'svcnum' => $self->svcnum,
1763 'column' => $column,
1767 $dbh->rollback if $oldAutoCommit;
1768 return "Error queuing threshold activity: $error";
1772 warn "$me update successful; committing\n"
1774 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1780 my( $self, $valueref ) = @_;
1782 warn "$me set_usage called for svcnum ". $self->svcnum.
1783 ' ('. $self->email. "): ".
1784 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1787 local $SIG{HUP} = 'IGNORE';
1788 local $SIG{INT} = 'IGNORE';
1789 local $SIG{QUIT} = 'IGNORE';
1790 local $SIG{TERM} = 'IGNORE';
1791 local $SIG{TSTP} = 'IGNORE';
1792 local $SIG{PIPE} = 'IGNORE';
1794 local $FS::svc_Common::noexport_hack = 1;
1795 my $oldAutoCommit = $FS::UID::AutoCommit;
1796 local $FS::UID::AutoCommit = 0;
1801 foreach my $field (keys %$valueref){
1802 $reset = 1 if $valueref->{$field};
1803 $self->setfield($field, $valueref->{$field});
1804 $self->setfield( $field.'_threshold',
1805 int($self->getfield($field)
1806 * ( $conf->exists('svc_acct-usage_threshold')
1807 ? 1 - $conf->config('svc_acct-usage_threshold')/100
1812 $handyhash{$field} = $self->getfield($field);
1813 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1815 #my $error = $self->replace; #NO! we avoid the call to ->check for
1816 #die $error if $error; #services not explicity changed via the UI
1818 my $sql = "UPDATE svc_acct SET " .
1819 join (',', map { "$_ = ?" } (keys %handyhash) ).
1820 " WHERE svcnum = ?";
1825 if (scalar(keys %handyhash)) {
1826 my $sth = $dbh->prepare( $sql )
1827 or die "Error preparing $sql: ". $dbh->errstr;
1828 my $rv = $sth->execute((values %handyhash), $self->svcnum);
1829 die "Error executing $sql: ". $sth->errstr
1830 unless defined($rv);
1831 die "Can't update usage for svcnum ". $self->svcnum
1838 if ($self->overlimit) {
1839 $error = $self->overlimit('unsuspend');
1840 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1841 if ($part_export->option('overlimit_groups')) {
1842 my $old = new FS::svc_acct $self->hashref;
1843 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1844 ($self, $part_export->option('overlimit_groups'));
1845 $old->usergroup( $groups );
1846 $error ||= $part_export->export_replace($self, $old);
1851 if ( $conf->exists("svc_acct-usage_unsuspend")) {
1852 $error ||= $self->cust_svc->cust_pkg->unsuspend;
1855 $dbh->rollback if $oldAutoCommit;
1856 return "Error unsuspending: $error";
1860 warn "$me update successful; committing\n"
1862 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1868 =item recharge HASHREF
1870 Increments usage columns by the amount specified in HASHREF as
1871 column=>amount pairs.
1876 my ($self, $vhash) = @_;
1879 warn "[$me] recharge called on $self: ". Dumper($self).
1880 "\nwith vhash: ". Dumper($vhash);
1883 my $oldAutoCommit = $FS::UID::AutoCommit;
1884 local $FS::UID::AutoCommit = 0;
1888 foreach my $column (keys %$vhash){
1889 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1893 $dbh->rollback if $oldAutoCommit;
1895 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1900 =item is_rechargeable
1902 Returns true if this svc_account can be "recharged" and false otherwise.
1906 sub is_rechargable {
1908 $self->seconds ne ''
1909 || $self->upbytes ne ''
1910 || $self->downbytes ne ''
1911 || $self->totalbytes ne '';
1914 =item seconds_since TIMESTAMP
1916 Returns the number of seconds this account has been online since TIMESTAMP,
1917 according to the session monitor (see L<FS::Session>).
1919 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
1920 L<Time::Local> and L<Date::Parse> for conversion functions.
1924 #note: POD here, implementation in FS::cust_svc
1927 $self->cust_svc->seconds_since(@_);
1930 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1932 Returns the numbers of seconds this account has been online between
1933 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1934 external SQL radacct table, specified via sqlradius export. Sessions which
1935 started in the specified range but are still open are counted from session
1936 start to the end of the range (unless they are over 1 day old, in which case
1937 they are presumed missing their stop record and not counted). Also, sessions
1938 which end in the range but started earlier are counted from the start of the
1939 range to session end. Finally, sessions which start before the range but end
1940 after are counted for the entire range.
1942 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1943 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1948 #note: POD here, implementation in FS::cust_svc
1949 sub seconds_since_sqlradacct {
1951 $self->cust_svc->seconds_since_sqlradacct(@_);
1954 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1956 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1957 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1958 TIMESTAMP_END (exclusive).
1960 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1961 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
1966 #note: POD here, implementation in FS::cust_svc
1967 sub attribute_since_sqlradacct {
1969 $self->cust_svc->attribute_since_sqlradacct(@_);
1972 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1974 Returns an array of hash references of this customers login history for the
1975 given time range. (document this better)
1979 sub get_session_history {
1981 $self->cust_svc->get_session_history(@_);
1984 =item last_login_text
1986 Returns text describing the time of last login.
1990 sub last_login_text {
1992 $self->last_login ? ctime($self->last_login) : 'unknown';
1995 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2000 my($self, $start, $end, %opt ) = @_;
2002 my $did = $self->username; #yup
2004 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2006 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2008 #SELECT $for_update * FROM cdr
2009 # WHERE calldate >= $start #need a conversion
2010 # AND calldate < $end #ditto
2011 # AND ( charged_party = "$did"
2012 # OR charged_party = "$prefix$did" #if length($prefix);
2013 # OR ( ( charged_party IS NULL OR charged_party = '' )
2015 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2018 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2021 if ( length($prefix) ) {
2023 " AND ( charged_party = '$did'
2024 OR charged_party = '$prefix$did'
2025 OR ( ( charged_party IS NULL OR charged_party = '' )
2027 ( src = '$did' OR src = '$prefix$did' )
2033 " AND ( charged_party = '$did'
2034 OR ( ( charged_party IS NULL OR charged_party = '' )
2044 'select' => "$for_update *",
2047 #( freesidestatus IS NULL OR freesidestatus = '' )
2048 'freesidestatus' => '',
2050 'extra_sql' => $charged_or_src,
2058 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2064 if ( $self->usergroup ) {
2065 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2066 unless ref($self->usergroup) eq 'ARRAY';
2067 #when provisioning records, export callback runs in svc_Common.pm before
2068 #radius_usergroup records can be inserted...
2069 @{$self->usergroup};
2071 map { $_->groupname }
2072 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2076 =item clone_suspended
2078 Constructor used by FS::part_export::_export_suspend fallback. Document
2083 sub clone_suspended {
2085 my %hash = $self->hash;
2086 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2087 new FS::svc_acct \%hash;
2090 =item clone_kludge_unsuspend
2092 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2097 sub clone_kludge_unsuspend {
2099 my %hash = $self->hash;
2100 $hash{_password} = '';
2101 new FS::svc_acct \%hash;
2104 =item check_password
2106 Checks the supplied password against the (possibly encrypted) password in the
2107 database. Returns true for a successful authentication, false for no match.
2109 Currently supported encryptions are: classic DES crypt() and MD5
2113 sub check_password {
2114 my($self, $check_password) = @_;
2116 #remove old-style SUSPENDED kludge, they should be allowed to login to
2117 #self-service and pay up
2118 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2120 if ( $self->_password_encoding eq 'ldap' ) {
2122 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2123 return $auth->match($check_password);
2125 } elsif ( $self->_password_encoding eq 'crypt' ) {
2127 my $auth = from_crypt Authen::Passphrase $self->_password;
2128 return $auth->match($check_password);
2130 } elsif ( $self->_password_encoding eq 'plain' ) {
2132 return $check_password eq $password;
2136 #XXX this could be replaced with Authen::Passphrase stuff
2138 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2140 } elsif ( length($password) < 13 ) { #plaintext
2141 $check_password eq $password;
2142 } elsif ( length($password) == 13 ) { #traditional DES crypt
2143 crypt($check_password, $password) eq $password;
2144 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2145 unix_md5_crypt($check_password, $password) eq $password;
2146 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2147 warn "Can't check password: Blowfish encryption not yet supported, ".
2148 "svcnum ". $self->svcnum. "\n";
2151 warn "Can't check password: Unrecognized encryption for svcnum ".
2152 $self->svcnum. "\n";
2160 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2162 Returns an encrypted password, either by passing through an encrypted password
2163 in the database or by encrypting a plaintext password from the database.
2165 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2166 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2167 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2168 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2169 encryption type is only used if the password is not already encrypted in the
2174 sub crypt_password {
2177 if ( $self->_password_encoding eq 'ldap' ) {
2179 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2182 #XXX this could be replaced with Authen::Passphrase stuff
2184 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2185 if ( $encryption eq 'crypt' ) {
2188 $saltset[int(rand(64))].$saltset[int(rand(64))]
2190 } elsif ( $encryption eq 'md5' ) {
2191 unix_md5_crypt( $self->_password );
2192 } elsif ( $encryption eq 'blowfish' ) {
2193 croak "unknown encryption method $encryption";
2195 croak "unknown encryption method $encryption";
2198 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2202 } elsif ( $self->_password_encoding eq 'crypt' ) {
2204 return $self->_password;
2206 } elsif ( $self->_password_encoding eq 'plain' ) {
2208 #XXX this could be replaced with Authen::Passphrase stuff
2210 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2211 if ( $encryption eq 'crypt' ) {
2214 $saltset[int(rand(64))].$saltset[int(rand(64))]
2216 } elsif ( $encryption eq 'md5' ) {
2217 unix_md5_crypt( $self->_password );
2218 } elsif ( $encryption eq 'blowfish' ) {
2219 croak "unknown encryption method $encryption";
2221 croak "unknown encryption method $encryption";
2226 if ( length($self->_password) == 13
2227 || $self->_password =~ /^\$(1|2a?)\$/
2228 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2234 #XXX this could be replaced with Authen::Passphrase stuff
2236 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2237 if ( $encryption eq 'crypt' ) {
2240 $saltset[int(rand(64))].$saltset[int(rand(64))]
2242 } elsif ( $encryption eq 'md5' ) {
2243 unix_md5_crypt( $self->_password );
2244 } elsif ( $encryption eq 'blowfish' ) {
2245 croak "unknown encryption method $encryption";
2247 croak "unknown encryption method $encryption";
2256 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2258 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2259 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2260 "{MD5}5426824942db4253f87a1009fd5d2d4".
2262 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2263 to work the same as the B</crypt_password> method.
2269 #eventually should check a "password-encoding" field
2271 if ( $self->_password_encoding eq 'ldap' ) {
2273 return $self->_password;
2275 } elsif ( $self->_password_encoding eq 'crypt' ) {
2277 if ( length($self->_password) == 13 ) { #crypt
2278 return '{CRYPT}'. $self->_password;
2279 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2281 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2282 # die "Blowfish encryption not supported in this context, svcnum ".
2283 # $self->svcnum. "\n";
2285 warn "encryption method not (yet?) supported in LDAP context";
2286 return '{CRYPT}*'; #unsupported, should not auth
2289 } elsif ( $self->_password_encoding eq 'plain' ) {
2291 return '{PLAIN}'. $self->_password;
2293 #return '{CLEARTEXT}'. $self->_password; #?
2297 if ( length($self->_password) == 13 ) { #crypt
2298 return '{CRYPT}'. $self->_password;
2299 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2301 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2302 warn "Blowfish encryption not supported in this context, svcnum ".
2303 $self->svcnum. "\n";
2306 #are these two necessary anymore?
2307 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2308 return '{SSHA}'. $1;
2309 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2310 return '{NS-MTA-MD5}'. $1;
2313 return '{PLAIN}'. $self->_password;
2315 #return '{CLEARTEXT}'. $self->_password; #?
2317 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2318 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2319 #if ( $encryption eq 'crypt' ) {
2320 # return '{CRYPT}'. crypt(
2322 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2324 #} elsif ( $encryption eq 'md5' ) {
2325 # unix_md5_crypt( $self->_password );
2326 #} elsif ( $encryption eq 'blowfish' ) {
2327 # croak "unknown encryption method $encryption";
2329 # croak "unknown encryption method $encryption";
2337 =item domain_slash_username
2339 Returns $domain/$username/
2343 sub domain_slash_username {
2345 $self->domain. '/'. $self->username. '/';
2348 =item virtual_maildir
2350 Returns $domain/maildirs/$username/
2354 sub virtual_maildir {
2356 $self->domain. '/maildirs/'. $self->username. '/';
2367 This is the FS::svc_acct job-queue-able version. It still uses
2368 FS::Misc::send_email under-the-hood.
2375 eval "use FS::Misc qw(send_email)";
2378 $opt{mimetype} ||= 'text/plain';
2379 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2381 my $error = send_email(
2382 'from' => $opt{from},
2384 'subject' => $opt{subject},
2385 'content-type' => $opt{mimetype},
2386 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2388 die $error if $error;
2391 =item check_and_rebuild_fuzzyfiles
2395 sub check_and_rebuild_fuzzyfiles {
2396 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2397 -e "$dir/svc_acct.username"
2398 or &rebuild_fuzzyfiles;
2401 =item rebuild_fuzzyfiles
2405 sub rebuild_fuzzyfiles {
2407 use Fcntl qw(:flock);
2409 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2413 open(USERNAMELOCK,">>$dir/svc_acct.username")
2414 or die "can't open $dir/svc_acct.username: $!";
2415 flock(USERNAMELOCK,LOCK_EX)
2416 or die "can't lock $dir/svc_acct.username: $!";
2418 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2420 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2421 or die "can't open $dir/svc_acct.username.tmp: $!";
2422 print USERNAMECACHE join("\n", @all_username), "\n";
2423 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2425 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2435 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2436 open(USERNAMECACHE,"<$dir/svc_acct.username")
2437 or die "can't open $dir/svc_acct.username: $!";
2438 my @array = map { chomp; $_; } <USERNAMECACHE>;
2439 close USERNAMECACHE;
2443 =item append_fuzzyfiles USERNAME
2447 sub append_fuzzyfiles {
2448 my $username = shift;
2450 &check_and_rebuild_fuzzyfiles;
2452 use Fcntl qw(:flock);
2454 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2456 open(USERNAME,">>$dir/svc_acct.username")
2457 or die "can't open $dir/svc_acct.username: $!";
2458 flock(USERNAME,LOCK_EX)
2459 or die "can't lock $dir/svc_acct.username: $!";
2461 print USERNAME "$username\n";
2463 flock(USERNAME,LOCK_UN)
2464 or die "can't unlock $dir/svc_acct.username: $!";
2472 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2476 sub radius_usergroup_selector {
2477 my $sel_groups = shift;
2478 my %sel_groups = map { $_=>1 } @$sel_groups;
2480 my $selectname = shift || 'radius_usergroup';
2483 my $sth = $dbh->prepare(
2484 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2485 ) or die $dbh->errstr;
2486 $sth->execute() or die $sth->errstr;
2487 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2491 function ${selectname}_doadd(object) {
2492 var myvalue = object.${selectname}_add.value;
2493 var optionName = new Option(myvalue,myvalue,false,true);
2494 var length = object.$selectname.length;
2495 object.$selectname.options[length] = optionName;
2496 object.${selectname}_add.value = "";
2499 <SELECT MULTIPLE NAME="$selectname">
2502 foreach my $group ( @all_groups ) {
2503 $html .= qq(<OPTION VALUE="$group");
2504 if ( $sel_groups{$group} ) {
2505 $html .= ' SELECTED';
2506 $sel_groups{$group} = 0;
2508 $html .= ">$group</OPTION>\n";
2510 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2511 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2513 $html .= '</SELECT>';
2515 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2516 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2521 =item reached_threshold
2523 Performs some activities when svc_acct thresholds (such as number of seconds
2524 remaining) are reached.
2528 sub reached_threshold {
2531 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2532 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2534 if ( $opt{'op'} eq '+' ){
2535 $svc_acct->setfield( $opt{'column'}.'_threshold',
2536 int($svc_acct->getfield($opt{'column'})
2537 * ( $conf->exists('svc_acct-usage_threshold')
2538 ? $conf->config('svc_acct-usage_threshold')/100
2543 my $error = $svc_acct->replace;
2544 die $error if $error;
2545 }elsif ( $opt{'op'} eq '-' ){
2547 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2548 return '' if ($threshold eq '' );
2550 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2551 my $error = $svc_acct->replace;
2552 die $error if $error; # email next time, i guess
2554 if ( $warning_template ) {
2555 eval "use FS::Misc qw(send_email)";
2558 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2559 my $cust_main = $cust_pkg->cust_main;
2561 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2562 $cust_main->invoicing_list,
2563 ($opt{'to'} ? $opt{'to'} : ())
2566 my $mimetype = $warning_mimetype;
2567 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2569 my $body = $warning_template->fill_in( HASH => {
2570 'custnum' => $cust_main->custnum,
2571 'username' => $svc_acct->username,
2572 'password' => $svc_acct->_password,
2573 'first' => $cust_main->first,
2574 'last' => $cust_main->getfield('last'),
2575 'pkg' => $cust_pkg->part_pkg->pkg,
2576 'column' => $opt{'column'},
2577 'amount' => $opt{'column'} =~/bytes/
2578 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2579 : $svc_acct->getfield($opt{'column'}),
2580 'threshold' => $opt{'column'} =~/bytes/
2581 ? FS::UI::bytecount::display_bytecount($threshold)
2586 my $error = send_email(
2587 'from' => $warning_from,
2589 'subject' => $warning_subject,
2590 'content-type' => $mimetype,
2591 'body' => [ map "$_\n", split("\n", $body) ],
2593 die $error if $error;
2596 die "unknown op: " . $opt{'op'};
2604 The $recref stuff in sub check should be cleaned up.
2606 The suspend, unsuspend and cancel methods update the database, but not the
2607 current object. This is probably a bug as it's unexpected and
2610 radius_usergroup_selector? putting web ui components in here? they should
2611 probably live somewhere else...
2613 insertion of RADIUS group stuff in insert could be done with child_objects now
2614 (would probably clean up export of them too)
2618 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2619 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2620 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2621 L<freeside-queued>), L<FS::svc_acct_pop>,
2622 schema.html from the base documentation.
2626 =item domain_select_hash %OPTIONS
2628 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2629 may at present purchase.
2631 Currently available options are: I<pkgnum> I<svcpart>
2635 sub domain_select_hash {
2636 my ($self, %options) = @_;
2642 $part_svc = $self->part_svc;
2643 $cust_pkg = $self->cust_svc->cust_pkg
2647 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2648 if $options{'svcpart'};
2650 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2651 if $options{'pkgnum'};
2653 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2654 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2655 %domains = map { $_->svcnum => $_->domain }
2656 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2657 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2658 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2659 %domains = map { $_->svcnum => $_->domain }
2660 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2661 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2662 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2664 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2667 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2668 my $svc_domain = qsearchs('svc_domain',
2669 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2670 if ( $svc_domain ) {
2671 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2673 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2674 $part_svc->part_svc_column('domsvc')->columnvalue;