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 $username_colon
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 );
22 use Crypt::PasswdMD5 1.2;
23 use Digest::SHA1 'sha1_base64';
24 use Digest::MD5 'md5_base64';
27 use Authen::Passphrase;
28 use FS::UID qw( datasrc driver_name );
30 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
31 use FS::Msgcat qw(gettext);
32 use FS::UI::bytecount;
38 use FS::cust_main_invoice;
42 use FS::radius_usergroup;
49 @ISA = qw( FS::svc_Common );
52 $me = '[FS::svc_acct]';
54 #ask FS::UID to run this stuff for us later
55 FS::UID->install_callback( sub {
57 $dir_prefix = $conf->config('home');
58 @shells = $conf->config('shells');
59 $usernamemin = $conf->config('usernamemin') || 2;
60 $usernamemax = $conf->config('usernamemax');
61 $passwordmin = $conf->config('passwordmin'); # || 6;
63 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
66 $passwordmax = $conf->config('passwordmax') || 8;
67 $username_letter = $conf->exists('username-letter');
68 $username_letterfirst = $conf->exists('username-letterfirst');
69 $username_noperiod = $conf->exists('username-noperiod');
70 $username_nounderscore = $conf->exists('username-nounderscore');
71 $username_nodash = $conf->exists('username-nodash');
72 $username_uppercase = $conf->exists('username-uppercase');
73 $username_ampersand = $conf->exists('username-ampersand');
74 $username_percent = $conf->exists('username-percent');
75 $username_colon = $conf->exists('username-colon');
76 $password_noampersand = $conf->exists('password-noexclamation');
77 $password_noexclamation = $conf->exists('password-noexclamation');
78 $dirhash = $conf->config('dirhash') || 0;
79 if ( $conf->exists('warning_email') ) {
80 $warning_template = new Text::Template (
82 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
83 ) or warn "can't create warning email template: $Text::Template::ERROR";
84 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
85 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
86 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
87 $warning_cc = $conf->config('warning_email-cc');
89 $warning_template = '';
91 $warning_subject = '';
92 $warning_mimetype = '';
95 $smtpmachine = $conf->config('smtpmachine');
96 $radius_password = $conf->config('radius-password') || 'Password';
97 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
98 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
102 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
103 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
107 my ( $hashref, $cache ) = @_;
108 if ( $hashref->{'svc_acct_svcnum'} ) {
109 $self->{'_domsvc'} = FS::svc_domain->new( {
110 'svcnum' => $hashref->{'domsvc'},
111 'domain' => $hashref->{'svc_acct_domain'},
112 'catchall' => $hashref->{'svc_acct_catchall'},
119 FS::svc_acct - Object methods for svc_acct records
125 $record = new FS::svc_acct \%hash;
126 $record = new FS::svc_acct { 'column' => 'value' };
128 $error = $record->insert;
130 $error = $new_record->replace($old_record);
132 $error = $record->delete;
134 $error = $record->check;
136 $error = $record->suspend;
138 $error = $record->unsuspend;
140 $error = $record->cancel;
142 %hash = $record->radius;
144 %hash = $record->radius_reply;
146 %hash = $record->radius_check;
148 $domain = $record->domain;
150 $svc_domain = $record->svc_domain;
152 $email = $record->email;
154 $seconds_since = $record->seconds_since($timestamp);
158 An FS::svc_acct object represents an account. FS::svc_acct inherits from
159 FS::svc_Common. The following fields are currently supported:
163 =item svcnum - primary key (assigned automatcially for new accounts)
167 =item _password - generated if blank
169 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
171 =item sec_phrase - security phrase
173 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
181 =item dir - set automatically if blank (and uid is not)
185 =item quota - (unimplementd)
187 =item slipip - IP address
197 =item domsvc - svcnum from svc_domain
199 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
201 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
211 Creates a new account. To add the account to the database, see L<"insert">.
218 'longname_plural' => 'Access accounts and mailboxes',
219 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
220 'display_weight' => 10,
221 'cancel_weight' => 50,
223 'dir' => 'Home directory',
226 def_info => 'set to fixed and blank for no UIDs',
229 'slipip' => 'IP address',
230 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
232 label => 'Access number',
234 select_table => 'svc_acct_pop',
235 select_key => 'popnum',
236 select_label => 'city',
242 disable_default => 1,
249 disable_inventory => 1,
252 '_password' => 'Password',
255 def_info => 'when blank, defaults to UID',
260 def_info => 'set to blank for no shell tracking',
262 #select_list => [ $conf->config('shells') ],
263 select_list => [ $conf ? $conf->config('shells') : () ],
264 disable_inventory => 1,
267 'finger' => 'Real name', # (GECOS)',
271 select_table => 'svc_domain',
272 select_key => 'svcnum',
273 select_label => 'domain',
274 disable_inventory => 1,
278 label => 'RADIUS groups',
279 type => 'radius_usergroup_selector',
280 disable_inventory => 1,
283 'seconds' => { label => 'Seconds',
284 label_sort => 'with Time Remaining',
286 disable_inventory => 1,
288 disable_part_svc_column => 1,
290 'upbytes' => { label => 'Upload',
292 disable_inventory => 1,
294 'format' => \&FS::UI::bytecount::display_bytecount,
295 'parse' => \&FS::UI::bytecount::parse_bytecount,
296 disable_part_svc_column => 1,
298 'downbytes' => { label => 'Download',
300 disable_inventory => 1,
302 'format' => \&FS::UI::bytecount::display_bytecount,
303 'parse' => \&FS::UI::bytecount::parse_bytecount,
304 disable_part_svc_column => 1,
306 'totalbytes'=> { label => 'Total up and download',
308 disable_inventory => 1,
310 'format' => \&FS::UI::bytecount::display_bytecount,
311 'parse' => \&FS::UI::bytecount::parse_bytecount,
312 disable_part_svc_column => 1,
314 'seconds_threshold' => { label => 'Seconds threshold',
316 disable_inventory => 1,
318 disable_part_svc_column => 1,
320 'upbytes_threshold' => { label => 'Upload threshold',
322 disable_inventory => 1,
324 'format' => \&FS::UI::bytecount::display_bytecount,
325 'parse' => \&FS::UI::bytecount::parse_bytecount,
326 disable_part_svc_column => 1,
328 'downbytes_threshold' => { label => 'Download threshold',
330 disable_inventory => 1,
332 'format' => \&FS::UI::bytecount::display_bytecount,
333 'parse' => \&FS::UI::bytecount::parse_bytecount,
334 disable_part_svc_column => 1,
336 'totalbytes_threshold'=> { label => 'Total up and download threshold',
338 disable_inventory => 1,
340 'format' => \&FS::UI::bytecount::display_bytecount,
341 'parse' => \&FS::UI::bytecount::parse_bytecount,
342 disable_part_svc_column => 1,
345 label => 'Last login',
349 label => 'Last logout',
356 sub table { 'svc_acct'; }
358 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
362 #false laziness with edit/svc_acct.cgi
364 my( $self, $groups ) = @_;
365 if ( ref($groups) eq 'ARRAY' ) {
367 } elsif ( length($groups) ) {
368 [ split(/\s*,\s*/, $groups) ];
377 shift->_lastlog('in', @_);
381 shift->_lastlog('out', @_);
385 my( $self, $op, $time ) = @_;
387 if ( defined($time) ) {
388 warn "$me last_log$op called on svcnum ". $self->svcnum.
389 ' ('. $self->email. "): $time\n"
394 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
398 my $sth = $dbh->prepare( $sql )
399 or die "Error preparing $sql: ". $dbh->errstr;
400 my $rv = $sth->execute($time, $self->svcnum);
401 die "Error executing $sql: ". $sth->errstr
403 die "Can't update last_log$op for svcnum". $self->svcnum
406 $self->{'Hash'}->{"last_log$op"} = $time;
408 $self->getfield("last_log$op");
412 =item search_sql STRING
414 Class method which returns an SQL fragment to search for the given string.
419 my( $class, $string ) = @_;
420 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
421 my( $username, $domain ) = ( $1, $2 );
422 my $q_username = dbh->quote($username);
423 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
425 "svc_acct.username = $q_username AND ( ".
426 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
431 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
433 $class->search_sql_field('slipip', $string ).
435 $class->search_sql_field('username', $string ).
439 $class->search_sql_field('username', $string).
441 ? 'OR '. $class->search_sql_field('svcnum', $string)
448 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
450 Returns the "username@domain" string for this account.
452 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
462 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
464 Returns a longer string label for this acccount ("Real Name <username@domain>"
465 if available, or "username@domain").
467 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
474 my $label = $self->label(@_);
475 my $finger = $self->finger;
476 return $label unless $finger =~ /\S/;
477 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
478 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
482 =item insert [ , OPTION => VALUE ... ]
484 Adds this account to the database. If there is an error, returns the error,
485 otherwise returns false.
487 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
488 defined. An FS::cust_svc record will be created and inserted.
490 The additional field I<usergroup> can optionally be defined; if so it should
491 contain an arrayref of group names. See L<FS::radius_usergroup>.
493 The additional field I<child_objects> can optionally be defined; if so it
494 should contain an arrayref of FS::tablename objects. They will have their
495 svcnum fields set and will be inserted after this record, but before any
496 exports are run. Each element of the array can also optionally be a
497 two-element array reference containing the child object and the name of an
498 alternate field to be filled in with the newly-inserted svcnum, for example
499 C<[ $svc_forward, 'srcsvc' ]>
501 Currently available options are: I<depend_jobnum>
503 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
504 jobnums), all provisioning jobs will have a dependancy on the supplied
505 jobnum(s) (they will not run until the specific job(s) complete(s)).
507 (TODOC: L<FS::queue> and L<freeside-queued>)
509 (TODOC: new exports!)
518 warn "[$me] insert called on $self: ". Dumper($self).
519 "\nwith options: ". Dumper(%options);
522 local $SIG{HUP} = 'IGNORE';
523 local $SIG{INT} = 'IGNORE';
524 local $SIG{QUIT} = 'IGNORE';
525 local $SIG{TERM} = 'IGNORE';
526 local $SIG{TSTP} = 'IGNORE';
527 local $SIG{PIPE} = 'IGNORE';
529 my $oldAutoCommit = $FS::UID::AutoCommit;
530 local $FS::UID::AutoCommit = 0;
534 my $error = $self->SUPER::insert(
535 'jobnums' => \@jobnums,
536 'child_objects' => $self->child_objects,
540 $dbh->rollback if $oldAutoCommit;
544 if ( $self->usergroup ) {
545 foreach my $groupname ( @{$self->usergroup} ) {
546 my $radius_usergroup = new FS::radius_usergroup ( {
547 svcnum => $self->svcnum,
548 groupname => $groupname,
550 my $error = $radius_usergroup->insert;
552 $dbh->rollback if $oldAutoCommit;
558 unless ( $skip_fuzzyfiles ) {
559 $error = $self->queue_fuzzyfiles_update;
561 $dbh->rollback if $oldAutoCommit;
562 return "updating fuzzy search cache: $error";
566 my $cust_pkg = $self->cust_svc->cust_pkg;
569 my $cust_main = $cust_pkg->cust_main;
570 my $agentnum = $cust_main->agentnum;
572 if ( $conf->exists('emailinvoiceautoalways')
573 || $conf->exists('emailinvoiceauto')
574 && ! $cust_main->invoicing_list_emailonly
576 my @invoicing_list = $cust_main->invoicing_list;
577 push @invoicing_list, $self->email;
578 $cust_main->invoicing_list(\@invoicing_list);
582 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
583 = ('','','','','','');
585 if ( $conf->exists('welcome_email', $agentnum) ) {
586 $welcome_template = new Text::Template (
588 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
589 ) or warn "can't create welcome email template: $Text::Template::ERROR";
590 $welcome_from = $conf->config('welcome_email-from', $agentnum);
591 # || 'your-isp-is-dum'
592 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
594 $welcome_subject_template = new Text::Template (
596 SOURCE => $welcome_subject,
597 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
598 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
601 if ( $welcome_template && $cust_pkg ) {
602 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
606 'custnum' => $self->custnum,
607 'username' => $self->username,
608 'password' => $self->_password,
609 'first' => $cust_main->first,
610 'last' => $cust_main->getfield('last'),
611 'pkg' => $cust_pkg->part_pkg->pkg,
613 my $wqueue = new FS::queue {
614 'svcnum' => $self->svcnum,
615 'job' => 'FS::svc_acct::send_email'
617 my $error = $wqueue->insert(
619 'from' => $welcome_from,
620 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
621 'mimetype' => $welcome_mimetype,
622 'body' => $welcome_template->fill_in( HASH => \%hash, ),
625 $dbh->rollback if $oldAutoCommit;
626 return "error queuing welcome email: $error";
629 if ( $options{'depend_jobnum'} ) {
630 warn "$me depend_jobnum found; adding to welcome email dependancies"
632 if ( ref($options{'depend_jobnum'}) ) {
633 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
634 "to welcome email dependancies"
636 push @jobnums, @{ $options{'depend_jobnum'} };
638 warn "$me adding job $options{'depend_jobnum'} ".
639 "to welcome email dependancies"
641 push @jobnums, $options{'depend_jobnum'};
645 foreach my $jobnum ( @jobnums ) {
646 my $error = $wqueue->depend_insert($jobnum);
648 $dbh->rollback if $oldAutoCommit;
649 return "error queuing welcome email job dependancy: $error";
659 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
663 # set usage fields and thresholds if unset but set in a package def
664 sub preinsert_hook_first {
667 return '' unless $self->pkgnum;
669 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
670 my $part_pkg = $cust_pkg->part_pkg if $cust_pkg;
671 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
673 my %values = $part_pkg->usage_valuehash;
674 my $multiplier = $conf->exists('svc_acct-usage_threshold')
675 ? 1 - $conf->config('svc_acct-usage_threshold')/100
676 : 0.20; #doesn't matter
678 foreach ( keys %values ) {
679 next if $self->getfield($_);
680 $self->setfield( $_, $values{$_} );
681 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
682 if $conf->exists('svc_acct-usage_threshold');
690 Deletes this account from the database. If there is an error, returns the
691 error, otherwise returns false.
693 The corresponding FS::cust_svc record will be deleted as well.
695 (TODOC: new exports!)
702 return "can't delete system account" if $self->_check_system;
704 return "Can't delete an account which is a (svc_forward) source!"
705 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
707 return "Can't delete an account which is a (svc_forward) destination!"
708 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
710 return "Can't delete an account with (svc_www) web service!"
711 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
713 # what about records in session ? (they should refer to history table)
715 local $SIG{HUP} = 'IGNORE';
716 local $SIG{INT} = 'IGNORE';
717 local $SIG{QUIT} = 'IGNORE';
718 local $SIG{TERM} = 'IGNORE';
719 local $SIG{TSTP} = 'IGNORE';
720 local $SIG{PIPE} = 'IGNORE';
722 my $oldAutoCommit = $FS::UID::AutoCommit;
723 local $FS::UID::AutoCommit = 0;
726 foreach my $cust_main_invoice (
727 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
729 unless ( defined($cust_main_invoice) ) {
730 warn "WARNING: something's wrong with qsearch";
733 my %hash = $cust_main_invoice->hash;
734 $hash{'dest'} = $self->email;
735 my $new = new FS::cust_main_invoice \%hash;
736 my $error = $new->replace($cust_main_invoice);
738 $dbh->rollback if $oldAutoCommit;
743 foreach my $svc_domain (
744 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
746 my %hash = new FS::svc_domain->hash;
747 $hash{'catchall'} = '';
748 my $new = new FS::svc_domain \%hash;
749 my $error = $new->replace($svc_domain);
751 $dbh->rollback if $oldAutoCommit;
756 my $error = $self->SUPER::delete;
758 $dbh->rollback if $oldAutoCommit;
762 foreach my $radius_usergroup (
763 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
765 my $error = $radius_usergroup->delete;
767 $dbh->rollback if $oldAutoCommit;
772 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
776 =item replace OLD_RECORD
778 Replaces OLD_RECORD with this one in the database. If there is an error,
779 returns the error, otherwise returns false.
781 The additional field I<usergroup> can optionally be defined; if so it should
782 contain an arrayref of group names. See L<FS::radius_usergroup>.
790 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
794 warn "$me replacing $old with $new\n" if $DEBUG;
798 return "can't modify system account" if $old->_check_system;
801 #no warnings 'numeric'; #alas, a 5.006-ism
804 foreach my $xid (qw( uid gid )) {
806 return "Can't change $xid!"
807 if ! $conf->exists("svc_acct-edit_$xid")
808 && $old->$xid() != $new->$xid()
809 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
814 #change homdir when we change username
815 $new->setfield('dir', '') if $old->username ne $new->username;
817 local $SIG{HUP} = 'IGNORE';
818 local $SIG{INT} = 'IGNORE';
819 local $SIG{QUIT} = 'IGNORE';
820 local $SIG{TERM} = 'IGNORE';
821 local $SIG{TSTP} = 'IGNORE';
822 local $SIG{PIPE} = 'IGNORE';
824 my $oldAutoCommit = $FS::UID::AutoCommit;
825 local $FS::UID::AutoCommit = 0;
828 # redundant, but so $new->usergroup gets set
829 $error = $new->check;
830 return $error if $error;
832 $old->usergroup( [ $old->radius_groups ] );
834 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
835 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
837 if ( $new->usergroup ) {
838 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
839 my @newgroups = @{$new->usergroup};
840 foreach my $oldgroup ( @{$old->usergroup} ) {
841 if ( grep { $oldgroup eq $_ } @newgroups ) {
842 @newgroups = grep { $oldgroup ne $_ } @newgroups;
845 my $radius_usergroup = qsearchs('radius_usergroup', {
846 svcnum => $old->svcnum,
847 groupname => $oldgroup,
849 my $error = $radius_usergroup->delete;
851 $dbh->rollback if $oldAutoCommit;
852 return "error deleting radius_usergroup $oldgroup: $error";
856 foreach my $newgroup ( @newgroups ) {
857 my $radius_usergroup = new FS::radius_usergroup ( {
858 svcnum => $new->svcnum,
859 groupname => $newgroup,
861 my $error = $radius_usergroup->insert;
863 $dbh->rollback if $oldAutoCommit;
864 return "error adding radius_usergroup $newgroup: $error";
870 $error = $new->SUPER::replace($old, @_);
872 $dbh->rollback if $oldAutoCommit;
873 return $error if $error;
876 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
877 $error = $new->queue_fuzzyfiles_update;
879 $dbh->rollback if $oldAutoCommit;
880 return "updating fuzzy search cache: $error";
884 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
888 =item queue_fuzzyfiles_update
890 Used by insert & replace to update the fuzzy search cache
894 sub queue_fuzzyfiles_update {
897 local $SIG{HUP} = 'IGNORE';
898 local $SIG{INT} = 'IGNORE';
899 local $SIG{QUIT} = 'IGNORE';
900 local $SIG{TERM} = 'IGNORE';
901 local $SIG{TSTP} = 'IGNORE';
902 local $SIG{PIPE} = 'IGNORE';
904 my $oldAutoCommit = $FS::UID::AutoCommit;
905 local $FS::UID::AutoCommit = 0;
908 my $queue = new FS::queue {
909 'svcnum' => $self->svcnum,
910 'job' => 'FS::svc_acct::append_fuzzyfiles'
912 my $error = $queue->insert($self->username);
914 $dbh->rollback if $oldAutoCommit;
915 return "queueing job (transaction rolled back): $error";
918 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
926 Suspends this account by calling export-specific suspend hooks. If there is
927 an error, returns the error, otherwise returns false.
929 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
935 return "can't suspend system account" if $self->_check_system;
936 $self->SUPER::suspend(@_);
941 Unsuspends this account by by calling export-specific suspend hooks. If there
942 is an error, returns the error, otherwise returns false.
944 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
950 my %hash = $self->hash;
951 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
952 $hash{_password} = $1;
953 my $new = new FS::svc_acct ( \%hash );
954 my $error = $new->replace($self);
955 return $error if $error;
958 $self->SUPER::unsuspend(@_);
963 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
965 If the B<auto_unset_catchall> configuration option is set, this method will
966 automatically remove any references to the canceled service in the catchall
967 field of svc_domain. This allows packages that contain both a svc_domain and
968 its catchall svc_acct to be canceled in one step.
973 # Only one thing to do at this level
975 foreach my $svc_domain (
976 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
977 if($conf->exists('auto_unset_catchall')) {
978 my %hash = $svc_domain->hash;
979 $hash{catchall} = '';
980 my $new = new FS::svc_domain ( \%hash );
981 my $error = $new->replace($svc_domain);
982 return $error if $error;
984 return "cannot unprovision svc_acct #".$self->svcnum.
985 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
989 $self->SUPER::cancel(@_);
995 Checks all fields to make sure this is a valid service. If there is an error,
996 returns the error, otherwise returns false. Called by the insert and replace
999 Sets any fixed values; see L<FS::part_svc>.
1006 my($recref) = $self->hashref;
1008 my $x = $self->setfixed( $self->_fieldhandlers );
1009 return $x unless ref($x);
1012 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1014 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1017 my $error = $self->ut_numbern('svcnum')
1018 #|| $self->ut_number('domsvc')
1019 || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
1020 || $self->ut_textn('sec_phrase')
1021 || $self->ut_snumbern('seconds')
1022 || $self->ut_snumbern('upbytes')
1023 || $self->ut_snumbern('downbytes')
1024 || $self->ut_snumbern('totalbytes')
1025 || $self->ut_enum( '_password_encoding',
1026 [ '', qw( plain crypt ldap ) ]
1029 return $error if $error;
1032 local $username_letter = $username_letter;
1033 if ($self->svcnum) {
1034 my $cust_svc = $self->cust_svc
1035 or return "no cust_svc record found for svcnum ". $self->svcnum;
1036 my $cust_pkg = $cust_svc->cust_pkg;
1038 if ($self->pkgnum) {
1039 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1043 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1046 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1047 if ( $username_uppercase ) {
1048 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1049 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1050 $recref->{username} = $1;
1052 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1053 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1054 $recref->{username} = $1;
1057 if ( $username_letterfirst ) {
1058 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1059 } elsif ( $username_letter ) {
1060 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1062 if ( $username_noperiod ) {
1063 $recref->{username} =~ /\./ and return gettext('illegal_username');
1065 if ( $username_nounderscore ) {
1066 $recref->{username} =~ /_/ and return gettext('illegal_username');
1068 if ( $username_nodash ) {
1069 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1071 unless ( $username_ampersand ) {
1072 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1074 unless ( $username_percent ) {
1075 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1077 unless ( $username_colon ) {
1078 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1081 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1082 $recref->{popnum} = $1;
1083 return "Unknown popnum" unless
1084 ! $recref->{popnum} ||
1085 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1087 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1089 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1090 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1092 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1093 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1094 #not all systems use gid=uid
1095 #you can set a fixed gid in part_svc
1097 return "Only root can have uid 0"
1098 if $recref->{uid} == 0
1099 && $recref->{username} !~ /^(root|toor|smtp)$/;
1101 unless ( $recref->{username} eq 'sync' ) {
1102 if ( grep $_ eq $recref->{shell}, @shells ) {
1103 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1105 return "Illegal shell \`". $self->shell. "\'; ".
1106 "shells configuration value contains: @shells";
1109 $recref->{shell} = '/bin/sync';
1113 $recref->{gid} ne '' ?
1114 return "Can't have gid without uid" : ( $recref->{gid}='' );
1115 #$recref->{dir} ne '' ?
1116 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1117 $recref->{shell} ne '' ?
1118 return "Can't have shell without uid" : ( $recref->{shell}='' );
1121 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1123 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1124 or return "Illegal directory: ". $recref->{dir};
1125 $recref->{dir} = $1;
1126 return "Illegal directory"
1127 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1128 return "Illegal directory"
1129 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1130 unless ( $recref->{dir} ) {
1131 $recref->{dir} = $dir_prefix . '/';
1132 if ( $dirhash > 0 ) {
1133 for my $h ( 1 .. $dirhash ) {
1134 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1136 } elsif ( $dirhash < 0 ) {
1137 for my $h ( reverse $dirhash .. -1 ) {
1138 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1141 $recref->{dir} .= $recref->{username};
1147 # $error = $self->ut_textn('finger');
1148 # return $error if $error;
1149 if ( $self->getfield('finger') eq '' ) {
1150 my $cust_pkg = $self->svcnum
1151 ? $self->cust_svc->cust_pkg
1152 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1154 my $cust_main = $cust_pkg->cust_main;
1155 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1158 $self->getfield('finger') =~
1159 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1160 or return "Illegal finger: ". $self->getfield('finger');
1161 $self->setfield('finger', $1);
1163 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1164 $recref->{quota} = $1;
1166 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1167 if ( $recref->{slipip} eq '' ) {
1168 $recref->{slipip} = '';
1169 } elsif ( $recref->{slipip} eq '0e0' ) {
1170 $recref->{slipip} = '0e0';
1172 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1173 or return "Illegal slipip: ". $self->slipip;
1174 $recref->{slipip} = $1;
1179 #arbitrary RADIUS stuff; allow ut_textn for now
1180 foreach ( grep /^radius_/, fields('svc_acct') ) {
1181 $self->ut_textn($_);
1184 # First, if _password is blank, generate one and set default encoding.
1185 if ( ! $recref->{_password} ) {
1186 $self->set_password('');
1188 # But if there's a _password but no encoding, assume it's plaintext and
1189 # set it to default encoding.
1190 elsif ( ! $recref->{_password_encoding} ) {
1191 $self->set_password($recref->{_password});
1194 # Next, check _password to ensure compliance with the encoding.
1195 if ( $recref->{_password_encoding} eq 'ldap' ) {
1197 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1198 $recref->{_password} = uc($1).$2;
1200 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1203 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1205 if ( $recref->{_password} =~
1206 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1207 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1210 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1213 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1216 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1217 # Password randomization is now in set_password.
1218 # Strip whitespace characters, check length requirements, etc.
1219 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1220 $recref->{_password} = $1;
1222 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1223 FS::Msgcat::_gettext('illegal_password_characters').
1224 ": ". $recref->{_password};
1227 if ( $password_noampersand ) {
1228 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1230 if ( $password_noexclamation ) {
1231 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1234 elsif ( $recref->{_password_encoding} eq 'legacy' ) {
1235 # this happens when set_password fails
1236 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1237 FS::Msgcat::_gettext('illegal_password_characters').
1238 ": ". $recref->{_password};
1240 $self->SUPER::check;
1245 sub _password_encryption {
1247 my $encoding = lc($self->_password_encoding);
1248 return if !$encoding;
1249 return 'plain' if $encoding eq 'plain';
1250 if($encoding eq 'crypt') {
1251 my $pass = $self->_password;
1252 $pass =~ s/^\*SUSPENDED\* //;
1254 return 'md5' if $pass =~ /^\$1\$/;
1255 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1256 return 'des' if length($pass) == 13;
1259 if($encoding eq 'ldap') {
1260 uc($self->_password) =~ /^\{([\w-]+)\}/;
1261 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1262 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1263 return 'md5' if $1 eq 'MD5';
1264 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1271 sub get_cleartext_password {
1273 if($self->_password_encryption eq 'plain') {
1274 if($self->_password_encoding eq 'ldap') {
1275 $self->_password =~ /\{\w+\}(.*)$/;
1279 return $self->_password;
1288 Set the cleartext password for the account. If _password_encoding is set, the
1289 new password will be encoded according to the existing method (including
1290 encryption mode, if it can be determined). Otherwise,
1291 config('default-password-encoding') is used.
1293 If no password is supplied (or a zero-length password when minimum password length
1294 is >0), one will be generated randomly.
1301 my ($encoding, $encryption);
1304 if($self->_password_encoding) {
1305 $encoding = $self->_password_encoding;
1306 # identify existing encryption method, try to use it.
1307 $encryption = $self->_password_encryption;
1309 # use the system default
1315 # set encoding to system default
1316 ($encoding, $encryption) = split(/-/, lc($conf->config('default-password-encoding')));
1317 $encoding ||= 'legacy';
1318 $self->_password_encoding($encoding);
1321 if($encoding eq 'legacy') {
1322 # The legacy behavior from check():
1323 # If the password is blank, randomize it and set encoding to 'plain'.
1324 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1325 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1326 $self->_password_encoding('plain');
1329 # Prefix + valid-length password
1330 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1332 $self->_password_encoding('plain');
1334 # Prefix + crypt string
1335 elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1337 $self->_password_encoding('crypt');
1339 # Various disabled crypt passwords
1340 elsif ( $pass eq '*' or
1343 $self->_password_encoding('crypt');
1346 # do nothing; check() will recognize this as an error
1350 elsif($encoding eq 'crypt') {
1351 if($encryption eq 'md5') {
1352 $pass = unix_md5_crypt($pass);
1354 elsif($encryption eq 'des') {
1355 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1358 elsif($encoding eq 'ldap') {
1359 if($encryption eq 'md5') {
1360 $pass = md5_base64($pass);
1362 elsif($encryption eq 'sha1') {
1363 $pass = sha1_base64($pass);
1365 elsif($encryption eq 'crypt') {
1366 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1368 # else $encryption eq 'plain', do nothing
1369 $pass = '{'.uc($encryption).'}'.$pass;
1371 # else encoding eq 'plain'
1373 $self->_password($pass);
1379 Internal function to check the username against the list of system usernames
1380 from the I<system_usernames> configuration value. Returns true if the username
1381 is listed on the system username list.
1387 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1388 $conf->config('system_usernames')
1392 =item _check_duplicate
1394 Internal method to check for duplicates usernames, username@domain pairs and
1397 If the I<global_unique-username> configuration value is set to B<username> or
1398 B<username@domain>, enforces global username or username@domain uniqueness.
1400 In all cases, check for duplicate uids and usernames or username@domain pairs
1401 per export and with identical I<svcpart> values.
1405 sub _check_duplicate {
1408 my $global_unique = $conf->config('global_unique-username') || 'none';
1409 return '' if $global_unique eq 'disabled';
1413 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1414 unless ( $part_svc ) {
1415 return 'unknown svcpart '. $self->svcpart;
1418 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1419 qsearch( 'svc_acct', { 'username' => $self->username } );
1420 return gettext('username_in_use')
1421 if $global_unique eq 'username' && @dup_user;
1423 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1424 qsearch( 'svc_acct', { 'username' => $self->username,
1425 'domsvc' => $self->domsvc } );
1426 return gettext('username_in_use')
1427 if $global_unique eq 'username@domain' && @dup_userdomain;
1430 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1431 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1432 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1433 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1438 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1439 my $exports = FS::part_export::export_info('svc_acct');
1440 my %conflict_user_svcpart;
1441 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1443 foreach my $part_export ( $part_svc->part_export ) {
1445 #this will catch to the same exact export
1446 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1448 #this will catch to exports w/same exporthost+type ???
1449 #my @other_part_export = qsearch('part_export', {
1450 # 'machine' => $part_export->machine,
1451 # 'exporttype' => $part_export->exporttype,
1453 #foreach my $other_part_export ( @other_part_export ) {
1454 # push @svcparts, map { $_->svcpart }
1455 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1458 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1459 #silly kludge to avoid uninitialized value errors
1460 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1461 ? $exports->{$part_export->exporttype}{'nodomain'}
1463 if ( $nodomain =~ /^Y/i ) {
1464 $conflict_user_svcpart{$_} = $part_export->exportnum
1467 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1472 foreach my $dup_user ( @dup_user ) {
1473 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1474 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1475 return "duplicate username ". $self->username.
1476 ": conflicts with svcnum ". $dup_user->svcnum.
1477 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1481 foreach my $dup_userdomain ( @dup_userdomain ) {
1482 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1483 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1484 return "duplicate username\@domain ". $self->email.
1485 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1486 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1490 foreach my $dup_uid ( @dup_uid ) {
1491 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1492 if ( exists($conflict_user_svcpart{$dup_svcpart})
1493 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1494 return "duplicate uid ". $self->uid.
1495 ": conflicts with svcnum ". $dup_uid->svcnum.
1497 ( $conflict_user_svcpart{$dup_svcpart}
1498 || $conflict_userdomain_svcpart{$dup_svcpart} );
1510 Depriciated, use radius_reply instead.
1515 carp "FS::svc_acct::radius depriciated, use radius_reply";
1516 $_[0]->radius_reply;
1521 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1522 reply attributes of this record.
1524 Note that this is now the preferred method for reading RADIUS attributes -
1525 accessing the columns directly is discouraged, as the column names are
1526 expected to change in the future.
1533 return %{ $self->{'radius_reply'} }
1534 if exists $self->{'radius_reply'};
1539 my($column, $attrib) = ($1, $2);
1540 #$attrib =~ s/_/\-/g;
1541 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1542 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1544 if ( $self->slipip && $self->slipip ne '0e0' ) {
1545 $reply{$radius_ip} = $self->slipip;
1548 if ( $self->seconds !~ /^$/ ) {
1549 $reply{'Session-Timeout'} = $self->seconds;
1552 if ( $conf->exists('radius-chillispot-max') ) {
1553 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1555 #hmm. just because sqlradius.pm says so?
1562 foreach my $what (qw( input output total )) {
1563 my $is = $whatis{$what}.'bytes';
1564 if ( $self->$is() =~ /\d/ ) {
1565 my $big = new Math::BigInt $self->$is();
1566 $big = new Math::BigInt '0' if $big->is_neg();
1567 my $att = "Chillispot-Max-\u$what";
1568 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1569 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1580 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1581 check attributes of this record.
1583 Note that this is now the preferred method for reading RADIUS attributes -
1584 accessing the columns directly is discouraged, as the column names are
1585 expected to change in the future.
1592 return %{ $self->{'radius_check'} }
1593 if exists $self->{'radius_check'};
1598 my($column, $attrib) = ($1, $2);
1599 #$attrib =~ s/_/\-/g;
1600 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1601 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1604 my($pw_attrib, $password) = $self->radius_password;
1605 $check{$pw_attrib} = $password;
1607 my $cust_svc = $self->cust_svc;
1609 my $cust_pkg = $cust_svc->cust_pkg;
1610 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1611 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1614 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1615 "; can't set Expiration\n"
1623 =item radius_password
1625 Returns a key/value pair containing the RADIUS attribute name and value
1630 sub radius_password {
1633 my($pw_attrib, $password);
1634 if ( $self->_password_encoding eq 'ldap' ) {
1636 $pw_attrib = 'Password-With-Header';
1637 $password = $self->_password;
1639 } elsif ( $self->_password_encoding eq 'crypt' ) {
1641 $pw_attrib = 'Crypt-Password';
1642 $password = $self->_password;
1644 } elsif ( $self->_password_encoding eq 'plain' ) {
1646 $pw_attrib = $radius_password; #Cleartext-Password? man rlm_pap
1647 $password = $self->_password;
1651 $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';
1652 $password = $self->_password;
1656 ($pw_attrib, $password);
1662 This method instructs the object to "snapshot" or freeze RADIUS check and
1663 reply attributes to the current values.
1667 #bah, my english is too broken this morning
1668 #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
1669 #the FS::cust_pkg's replace method to trigger the correct export updates when
1670 #package dates change)
1675 $self->{$_} = { $self->$_() }
1676 foreach qw( radius_reply radius_check );
1680 =item forget_snapshot
1682 This methos instructs the object to forget any previously snapshotted
1683 RADIUS check and reply attributes.
1687 sub forget_snapshot {
1691 foreach qw( radius_reply radius_check );
1695 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1697 Returns the domain associated with this account.
1699 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1706 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1707 my $svc_domain = $self->svc_domain(@_)
1708 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1709 $svc_domain->domain;
1714 Returns the FS::svc_domain record for this account's domain (see
1719 # FS::h_svc_acct has a history-aware svc_domain override
1724 ? $self->{'_domsvc'}
1725 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1730 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1734 #inherited from svc_Common
1736 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1738 Returns an email address associated with the account.
1740 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1747 $self->username. '@'. $self->domain(@_);
1752 Returns an array of FS::acct_snarf records associated with the account.
1753 If the acct_snarf table does not exist or there are no associated records,
1754 an empty list is returned
1760 return () unless dbdef->table('acct_snarf');
1761 eval "use FS::acct_snarf;";
1763 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1766 =item decrement_upbytes OCTETS
1768 Decrements the I<upbytes> field of this record by the given amount. If there
1769 is an error, returns the error, otherwise returns false.
1773 sub decrement_upbytes {
1774 shift->_op_usage('-', 'upbytes', @_);
1777 =item increment_upbytes OCTETS
1779 Increments the I<upbytes> field of this record by the given amount. If there
1780 is an error, returns the error, otherwise returns false.
1784 sub increment_upbytes {
1785 shift->_op_usage('+', 'upbytes', @_);
1788 =item decrement_downbytes OCTETS
1790 Decrements the I<downbytes> field of this record by the given amount. If there
1791 is an error, returns the error, otherwise returns false.
1795 sub decrement_downbytes {
1796 shift->_op_usage('-', 'downbytes', @_);
1799 =item increment_downbytes OCTETS
1801 Increments the I<downbytes> field of this record by the given amount. If there
1802 is an error, returns the error, otherwise returns false.
1806 sub increment_downbytes {
1807 shift->_op_usage('+', 'downbytes', @_);
1810 =item decrement_totalbytes OCTETS
1812 Decrements the I<totalbytes> field of this record by the given amount. If there
1813 is an error, returns the error, otherwise returns false.
1817 sub decrement_totalbytes {
1818 shift->_op_usage('-', 'totalbytes', @_);
1821 =item increment_totalbytes OCTETS
1823 Increments the I<totalbytes> field of this record by the given amount. If there
1824 is an error, returns the error, otherwise returns false.
1828 sub increment_totalbytes {
1829 shift->_op_usage('+', 'totalbytes', @_);
1832 =item decrement_seconds SECONDS
1834 Decrements the I<seconds> field of this record by the given amount. If there
1835 is an error, returns the error, otherwise returns false.
1839 sub decrement_seconds {
1840 shift->_op_usage('-', 'seconds', @_);
1843 =item increment_seconds SECONDS
1845 Increments the I<seconds> field of this record by the given amount. If there
1846 is an error, returns the error, otherwise returns false.
1850 sub increment_seconds {
1851 shift->_op_usage('+', 'seconds', @_);
1859 my %op2condition = (
1860 '-' => sub { my($self, $column, $amount) = @_;
1861 $self->$column - $amount <= 0;
1863 '+' => sub { my($self, $column, $amount) = @_;
1864 ($self->$column || 0) + $amount > 0;
1867 my %op2warncondition = (
1868 '-' => sub { my($self, $column, $amount) = @_;
1869 my $threshold = $column . '_threshold';
1870 $self->$column - $amount <= $self->$threshold + 0;
1872 '+' => sub { my($self, $column, $amount) = @_;
1873 ($self->$column || 0) + $amount > 0;
1878 my( $self, $op, $column, $amount ) = @_;
1880 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1881 ' ('. $self->email. "): $op $amount\n"
1884 return '' unless $amount;
1886 local $SIG{HUP} = 'IGNORE';
1887 local $SIG{INT} = 'IGNORE';
1888 local $SIG{QUIT} = 'IGNORE';
1889 local $SIG{TERM} = 'IGNORE';
1890 local $SIG{TSTP} = 'IGNORE';
1891 local $SIG{PIPE} = 'IGNORE';
1893 my $oldAutoCommit = $FS::UID::AutoCommit;
1894 local $FS::UID::AutoCommit = 0;
1897 my $sql = "UPDATE svc_acct SET $column = ".
1898 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1899 " $op ? WHERE svcnum = ?";
1903 my $sth = $dbh->prepare( $sql )
1904 or die "Error preparing $sql: ". $dbh->errstr;
1905 my $rv = $sth->execute($amount, $self->svcnum);
1906 die "Error executing $sql: ". $sth->errstr
1907 unless defined($rv);
1908 die "Can't update $column for svcnum". $self->svcnum
1911 #$self->snapshot; #not necessary, we retain the old values
1912 #create an object with the updated usage values
1913 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1915 my $error = $new->replace($self);
1917 $dbh->rollback if $oldAutoCommit;
1918 return "Error replacing: $error";
1921 #overlimit_action eq 'cancel' handling
1922 my $cust_pkg = $self->cust_svc->cust_pkg;
1924 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1925 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1929 my $error = $cust_pkg->cancel; #XXX should have a reason
1931 $dbh->rollback if $oldAutoCommit;
1932 return "Error cancelling: $error";
1935 #nothing else is relevant if we're cancelling, so commit & return success
1936 warn "$me update successful; committing\n"
1938 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1943 my $action = $op2action{$op};
1945 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1946 ( $action eq 'suspend' && !$self->overlimit
1947 || $action eq 'unsuspend' && $self->overlimit )
1949 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1950 if ($part_export->option('overlimit_groups')) {
1952 my $other = new FS::svc_acct $self->hashref;
1953 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1954 ($self, $part_export->option('overlimit_groups'));
1955 $other->usergroup( $groups );
1956 if ($action eq 'suspend'){
1957 $new = $other; $old = $self;
1959 $new = $self; $old = $other;
1961 my $error = $part_export->export_replace($new, $old);
1962 $error ||= $self->overlimit($action);
1964 $dbh->rollback if $oldAutoCommit;
1965 return "Error replacing radius groups in export, ${op}: $error";
1971 if ( $conf->exists("svc_acct-usage_$action")
1972 && &{$op2condition{$op}}($self, $column, $amount) ) {
1973 #my $error = $self->$action();
1974 my $error = $self->cust_svc->cust_pkg->$action();
1975 # $error ||= $self->overlimit($action);
1977 $dbh->rollback if $oldAutoCommit;
1978 return "Error ${action}ing: $error";
1982 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1983 my $wqueue = new FS::queue {
1984 'svcnum' => $self->svcnum,
1985 'job' => 'FS::svc_acct::reached_threshold',
1990 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1994 my $error = $wqueue->insert(
1995 'svcnum' => $self->svcnum,
1997 'column' => $column,
2001 $dbh->rollback if $oldAutoCommit;
2002 return "Error queuing threshold activity: $error";
2006 warn "$me update successful; committing\n"
2008 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2014 my( $self, $valueref, %options ) = @_;
2016 warn "$me set_usage called for svcnum ". $self->svcnum.
2017 ' ('. $self->email. "): ".
2018 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2021 local $SIG{HUP} = 'IGNORE';
2022 local $SIG{INT} = 'IGNORE';
2023 local $SIG{QUIT} = 'IGNORE';
2024 local $SIG{TERM} = 'IGNORE';
2025 local $SIG{TSTP} = 'IGNORE';
2026 local $SIG{PIPE} = 'IGNORE';
2028 local $FS::svc_Common::noexport_hack = 1;
2029 my $oldAutoCommit = $FS::UID::AutoCommit;
2030 local $FS::UID::AutoCommit = 0;
2035 if ( $options{null} ) {
2036 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2037 qw( seconds upbytes downbytes totalbytes )
2040 foreach my $field (keys %$valueref){
2041 $reset = 1 if $valueref->{$field};
2042 $self->setfield($field, $valueref->{$field});
2043 $self->setfield( $field.'_threshold',
2044 int($self->getfield($field)
2045 * ( $conf->exists('svc_acct-usage_threshold')
2046 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2051 $handyhash{$field} = $self->getfield($field);
2052 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2054 #my $error = $self->replace; #NO! we avoid the call to ->check for
2055 #die $error if $error; #services not explicity changed via the UI
2057 my $sql = "UPDATE svc_acct SET " .
2058 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
2059 " WHERE svcnum = ". $self->svcnum;
2064 if (scalar(keys %handyhash)) {
2065 my $sth = $dbh->prepare( $sql )
2066 or die "Error preparing $sql: ". $dbh->errstr;
2067 my $rv = $sth->execute();
2068 die "Error executing $sql: ". $sth->errstr
2069 unless defined($rv);
2070 die "Can't update usage for svcnum ". $self->svcnum
2074 #$self->snapshot; #not necessary, we retain the old values
2075 #create an object with the updated usage values
2076 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2078 my $error = $new->replace($self);
2080 $dbh->rollback if $oldAutoCommit;
2081 return "Error replacing: $error";
2087 if ($self->overlimit) {
2088 $error = $self->overlimit('unsuspend');
2089 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2090 if ($part_export->option('overlimit_groups')) {
2091 my $old = new FS::svc_acct $self->hashref;
2092 my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
2093 ($self, $part_export->option('overlimit_groups'));
2094 $old->usergroup( $groups );
2095 $error ||= $part_export->export_replace($self, $old);
2100 if ( $conf->exists("svc_acct-usage_unsuspend")) {
2101 $error ||= $self->cust_svc->cust_pkg->unsuspend;
2104 $dbh->rollback if $oldAutoCommit;
2105 return "Error unsuspending: $error";
2109 warn "$me update successful; committing\n"
2111 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2117 =item recharge HASHREF
2119 Increments usage columns by the amount specified in HASHREF as
2120 column=>amount pairs.
2125 my ($self, $vhash) = @_;
2128 warn "[$me] recharge called on $self: ". Dumper($self).
2129 "\nwith vhash: ". Dumper($vhash);
2132 my $oldAutoCommit = $FS::UID::AutoCommit;
2133 local $FS::UID::AutoCommit = 0;
2137 foreach my $column (keys %$vhash){
2138 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2142 $dbh->rollback if $oldAutoCommit;
2144 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2149 =item is_rechargeable
2151 Returns true if this svc_account can be "recharged" and false otherwise.
2155 sub is_rechargable {
2157 $self->seconds ne ''
2158 || $self->upbytes ne ''
2159 || $self->downbytes ne ''
2160 || $self->totalbytes ne '';
2163 =item seconds_since TIMESTAMP
2165 Returns the number of seconds this account has been online since TIMESTAMP,
2166 according to the session monitor (see L<FS::Session>).
2168 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2169 L<Time::Local> and L<Date::Parse> for conversion functions.
2173 #note: POD here, implementation in FS::cust_svc
2176 $self->cust_svc->seconds_since(@_);
2179 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2181 Returns the numbers of seconds this account has been online between
2182 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2183 external SQL radacct table, specified via sqlradius export. Sessions which
2184 started in the specified range but are still open are counted from session
2185 start to the end of the range (unless they are over 1 day old, in which case
2186 they are presumed missing their stop record and not counted). Also, sessions
2187 which end in the range but started earlier are counted from the start of the
2188 range to session end. Finally, sessions which start before the range but end
2189 after are counted for the entire range.
2191 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2192 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2197 #note: POD here, implementation in FS::cust_svc
2198 sub seconds_since_sqlradacct {
2200 $self->cust_svc->seconds_since_sqlradacct(@_);
2203 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2205 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2206 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2207 TIMESTAMP_END (exclusive).
2209 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2210 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2215 #note: POD here, implementation in FS::cust_svc
2216 sub attribute_since_sqlradacct {
2218 $self->cust_svc->attribute_since_sqlradacct(@_);
2221 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2223 Returns an array of hash references of this customers login history for the
2224 given time range. (document this better)
2228 sub get_session_history {
2230 $self->cust_svc->get_session_history(@_);
2233 =item last_login_text
2235 Returns text describing the time of last login.
2239 sub last_login_text {
2241 $self->last_login ? ctime($self->last_login) : 'unknown';
2244 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2249 my($self, $start, $end, %opt ) = @_;
2251 my $did = $self->username; #yup
2253 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2255 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2257 #SELECT $for_update * FROM cdr
2258 # WHERE calldate >= $start #need a conversion
2259 # AND calldate < $end #ditto
2260 # AND ( charged_party = "$did"
2261 # OR charged_party = "$prefix$did" #if length($prefix);
2262 # OR ( ( charged_party IS NULL OR charged_party = '' )
2264 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2267 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2270 if ( length($prefix) ) {
2272 " AND ( charged_party = '$did'
2273 OR charged_party = '$prefix$did'
2274 OR ( ( charged_party IS NULL OR charged_party = '' )
2276 ( src = '$did' OR src = '$prefix$did' )
2282 " AND ( charged_party = '$did'
2283 OR ( ( charged_party IS NULL OR charged_party = '' )
2293 'select' => "$for_update *",
2296 #( freesidestatus IS NULL OR freesidestatus = '' )
2297 'freesidestatus' => '',
2299 'extra_sql' => $charged_or_src,
2307 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2313 if ( $self->usergroup ) {
2314 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2315 unless ref($self->usergroup) eq 'ARRAY';
2316 #when provisioning records, export callback runs in svc_Common.pm before
2317 #radius_usergroup records can be inserted...
2318 @{$self->usergroup};
2320 map { $_->groupname }
2321 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2325 =item clone_suspended
2327 Constructor used by FS::part_export::_export_suspend fallback. Document
2332 sub clone_suspended {
2334 my %hash = $self->hash;
2335 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2336 new FS::svc_acct \%hash;
2339 =item clone_kludge_unsuspend
2341 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2346 sub clone_kludge_unsuspend {
2348 my %hash = $self->hash;
2349 $hash{_password} = '';
2350 new FS::svc_acct \%hash;
2353 =item check_password
2355 Checks the supplied password against the (possibly encrypted) password in the
2356 database. Returns true for a successful authentication, false for no match.
2358 Currently supported encryptions are: classic DES crypt() and MD5
2362 sub check_password {
2363 my($self, $check_password) = @_;
2365 #remove old-style SUSPENDED kludge, they should be allowed to login to
2366 #self-service and pay up
2367 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2369 if ( $self->_password_encoding eq 'ldap' ) {
2371 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2372 return $auth->match($check_password);
2374 } elsif ( $self->_password_encoding eq 'crypt' ) {
2376 my $auth = from_crypt Authen::Passphrase $self->_password;
2377 return $auth->match($check_password);
2379 } elsif ( $self->_password_encoding eq 'plain' ) {
2381 return $check_password eq $password;
2385 #XXX this could be replaced with Authen::Passphrase stuff
2387 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2389 } elsif ( length($password) < 13 ) { #plaintext
2390 $check_password eq $password;
2391 } elsif ( length($password) == 13 ) { #traditional DES crypt
2392 crypt($check_password, $password) eq $password;
2393 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2394 unix_md5_crypt($check_password, $password) eq $password;
2395 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2396 warn "Can't check password: Blowfish encryption not yet supported, ".
2397 "svcnum ". $self->svcnum. "\n";
2400 warn "Can't check password: Unrecognized encryption for svcnum ".
2401 $self->svcnum. "\n";
2409 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2411 Returns an encrypted password, either by passing through an encrypted password
2412 in the database or by encrypting a plaintext password from the database.
2414 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2415 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2416 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2417 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2418 encryption type is only used if the password is not already encrypted in the
2423 sub crypt_password {
2426 if ( $self->_password_encoding eq 'ldap' ) {
2428 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2431 #XXX this could be replaced with Authen::Passphrase stuff
2433 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2434 if ( $encryption eq 'crypt' ) {
2437 $saltset[int(rand(64))].$saltset[int(rand(64))]
2439 } elsif ( $encryption eq 'md5' ) {
2440 unix_md5_crypt( $self->_password );
2441 } elsif ( $encryption eq 'blowfish' ) {
2442 croak "unknown encryption method $encryption";
2444 croak "unknown encryption method $encryption";
2447 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2451 } elsif ( $self->_password_encoding eq 'crypt' ) {
2453 return $self->_password;
2455 } elsif ( $self->_password_encoding eq 'plain' ) {
2457 #XXX this could be replaced with Authen::Passphrase stuff
2459 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2460 if ( $encryption eq 'crypt' ) {
2463 $saltset[int(rand(64))].$saltset[int(rand(64))]
2465 } elsif ( $encryption eq 'md5' ) {
2466 unix_md5_crypt( $self->_password );
2467 } elsif ( $encryption eq 'blowfish' ) {
2468 croak "unknown encryption method $encryption";
2470 croak "unknown encryption method $encryption";
2475 if ( length($self->_password) == 13
2476 || $self->_password =~ /^\$(1|2a?)\$/
2477 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2483 #XXX this could be replaced with Authen::Passphrase stuff
2485 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2486 if ( $encryption eq 'crypt' ) {
2489 $saltset[int(rand(64))].$saltset[int(rand(64))]
2491 } elsif ( $encryption eq 'md5' ) {
2492 unix_md5_crypt( $self->_password );
2493 } elsif ( $encryption eq 'blowfish' ) {
2494 croak "unknown encryption method $encryption";
2496 croak "unknown encryption method $encryption";
2505 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2507 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2508 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2509 "{MD5}5426824942db4253f87a1009fd5d2d4".
2511 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2512 to work the same as the B</crypt_password> method.
2518 #eventually should check a "password-encoding" field
2520 if ( $self->_password_encoding eq 'ldap' ) {
2522 return $self->_password;
2524 } elsif ( $self->_password_encoding eq 'crypt' ) {
2526 if ( length($self->_password) == 13 ) { #crypt
2527 return '{CRYPT}'. $self->_password;
2528 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2530 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2531 # die "Blowfish encryption not supported in this context, svcnum ".
2532 # $self->svcnum. "\n";
2534 warn "encryption method not (yet?) supported in LDAP context";
2535 return '{CRYPT}*'; #unsupported, should not auth
2538 } elsif ( $self->_password_encoding eq 'plain' ) {
2540 return '{PLAIN}'. $self->_password;
2542 #return '{CLEARTEXT}'. $self->_password; #?
2546 if ( length($self->_password) == 13 ) { #crypt
2547 return '{CRYPT}'. $self->_password;
2548 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2550 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2551 warn "Blowfish encryption not supported in this context, svcnum ".
2552 $self->svcnum. "\n";
2555 #are these two necessary anymore?
2556 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2557 return '{SSHA}'. $1;
2558 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2559 return '{NS-MTA-MD5}'. $1;
2562 return '{PLAIN}'. $self->_password;
2564 #return '{CLEARTEXT}'. $self->_password; #?
2566 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2567 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2568 #if ( $encryption eq 'crypt' ) {
2569 # return '{CRYPT}'. crypt(
2571 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2573 #} elsif ( $encryption eq 'md5' ) {
2574 # unix_md5_crypt( $self->_password );
2575 #} elsif ( $encryption eq 'blowfish' ) {
2576 # croak "unknown encryption method $encryption";
2578 # croak "unknown encryption method $encryption";
2586 =item domain_slash_username
2588 Returns $domain/$username/
2592 sub domain_slash_username {
2594 $self->domain. '/'. $self->username. '/';
2597 =item virtual_maildir
2599 Returns $domain/maildirs/$username/
2603 sub virtual_maildir {
2605 $self->domain. '/maildirs/'. $self->username. '/';
2616 This is the FS::svc_acct job-queue-able version. It still uses
2617 FS::Misc::send_email under-the-hood.
2624 eval "use FS::Misc qw(send_email)";
2627 $opt{mimetype} ||= 'text/plain';
2628 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2630 my $error = send_email(
2631 'from' => $opt{from},
2633 'subject' => $opt{subject},
2634 'content-type' => $opt{mimetype},
2635 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2637 die $error if $error;
2640 =item check_and_rebuild_fuzzyfiles
2644 sub check_and_rebuild_fuzzyfiles {
2645 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2646 -e "$dir/svc_acct.username"
2647 or &rebuild_fuzzyfiles;
2650 =item rebuild_fuzzyfiles
2654 sub rebuild_fuzzyfiles {
2656 use Fcntl qw(:flock);
2658 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2662 open(USERNAMELOCK,">>$dir/svc_acct.username")
2663 or die "can't open $dir/svc_acct.username: $!";
2664 flock(USERNAMELOCK,LOCK_EX)
2665 or die "can't lock $dir/svc_acct.username: $!";
2667 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2669 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2670 or die "can't open $dir/svc_acct.username.tmp: $!";
2671 print USERNAMECACHE join("\n", @all_username), "\n";
2672 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2674 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2684 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2685 open(USERNAMECACHE,"<$dir/svc_acct.username")
2686 or die "can't open $dir/svc_acct.username: $!";
2687 my @array = map { chomp; $_; } <USERNAMECACHE>;
2688 close USERNAMECACHE;
2692 =item append_fuzzyfiles USERNAME
2696 sub append_fuzzyfiles {
2697 my $username = shift;
2699 &check_and_rebuild_fuzzyfiles;
2701 use Fcntl qw(:flock);
2703 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2705 open(USERNAME,">>$dir/svc_acct.username")
2706 or die "can't open $dir/svc_acct.username: $!";
2707 flock(USERNAME,LOCK_EX)
2708 or die "can't lock $dir/svc_acct.username: $!";
2710 print USERNAME "$username\n";
2712 flock(USERNAME,LOCK_UN)
2713 or die "can't unlock $dir/svc_acct.username: $!";
2721 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2725 sub radius_usergroup_selector {
2726 my $sel_groups = shift;
2727 my %sel_groups = map { $_=>1 } @$sel_groups;
2729 my $selectname = shift || 'radius_usergroup';
2732 my $sth = $dbh->prepare(
2733 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2734 ) or die $dbh->errstr;
2735 $sth->execute() or die $sth->errstr;
2736 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2740 function ${selectname}_doadd(object) {
2741 var myvalue = object.${selectname}_add.value;
2742 var optionName = new Option(myvalue,myvalue,false,true);
2743 var length = object.$selectname.length;
2744 object.$selectname.options[length] = optionName;
2745 object.${selectname}_add.value = "";
2748 <SELECT MULTIPLE NAME="$selectname">
2751 foreach my $group ( @all_groups ) {
2752 $html .= qq(<OPTION VALUE="$group");
2753 if ( $sel_groups{$group} ) {
2754 $html .= ' SELECTED';
2755 $sel_groups{$group} = 0;
2757 $html .= ">$group</OPTION>\n";
2759 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2760 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2762 $html .= '</SELECT>';
2764 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2765 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2770 =item reached_threshold
2772 Performs some activities when svc_acct thresholds (such as number of seconds
2773 remaining) are reached.
2777 sub reached_threshold {
2780 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2781 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2783 if ( $opt{'op'} eq '+' ){
2784 $svc_acct->setfield( $opt{'column'}.'_threshold',
2785 int($svc_acct->getfield($opt{'column'})
2786 * ( $conf->exists('svc_acct-usage_threshold')
2787 ? $conf->config('svc_acct-usage_threshold')/100
2792 my $error = $svc_acct->replace;
2793 die $error if $error;
2794 }elsif ( $opt{'op'} eq '-' ){
2796 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2797 return '' if ($threshold eq '' );
2799 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2800 my $error = $svc_acct->replace;
2801 die $error if $error; # email next time, i guess
2803 if ( $warning_template ) {
2804 eval "use FS::Misc qw(send_email)";
2807 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
2808 my $cust_main = $cust_pkg->cust_main;
2810 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2811 $cust_main->invoicing_list,
2812 ($opt{'to'} ? $opt{'to'} : ())
2815 my $mimetype = $warning_mimetype;
2816 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2818 my $body = $warning_template->fill_in( HASH => {
2819 'custnum' => $cust_main->custnum,
2820 'username' => $svc_acct->username,
2821 'password' => $svc_acct->_password,
2822 'first' => $cust_main->first,
2823 'last' => $cust_main->getfield('last'),
2824 'pkg' => $cust_pkg->part_pkg->pkg,
2825 'column' => $opt{'column'},
2826 'amount' => $opt{'column'} =~/bytes/
2827 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2828 : $svc_acct->getfield($opt{'column'}),
2829 'threshold' => $opt{'column'} =~/bytes/
2830 ? FS::UI::bytecount::display_bytecount($threshold)
2835 my $error = send_email(
2836 'from' => $warning_from,
2838 'subject' => $warning_subject,
2839 'content-type' => $mimetype,
2840 'body' => [ map "$_\n", split("\n", $body) ],
2842 die $error if $error;
2845 die "unknown op: " . $opt{'op'};
2853 The $recref stuff in sub check should be cleaned up.
2855 The suspend, unsuspend and cancel methods update the database, but not the
2856 current object. This is probably a bug as it's unexpected and
2859 radius_usergroup_selector? putting web ui components in here? they should
2860 probably live somewhere else...
2862 insertion of RADIUS group stuff in insert could be done with child_objects now
2863 (would probably clean up export of them too)
2865 _op_usage and set_usage bypass the history... maybe they shouldn't
2869 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2870 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2871 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2872 L<freeside-queued>), L<FS::svc_acct_pop>,
2873 schema.html from the base documentation.
2877 =item domain_select_hash %OPTIONS
2879 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
2880 may at present purchase.
2882 Currently available options are: I<pkgnum> I<svcpart>
2886 sub domain_select_hash {
2887 my ($self, %options) = @_;
2893 $part_svc = $self->part_svc;
2894 $cust_pkg = $self->cust_svc->cust_pkg
2898 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
2899 if $options{'svcpart'};
2901 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
2902 if $options{'pkgnum'};
2904 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
2905 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
2906 %domains = map { $_->svcnum => $_->domain }
2907 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
2908 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
2909 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
2910 %domains = map { $_->svcnum => $_->domain }
2911 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
2912 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
2913 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
2915 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
2918 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
2919 my $svc_domain = qsearchs('svc_domain',
2920 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
2921 if ( $svc_domain ) {
2922 $domains{$svc_domain->svcnum} = $svc_domain->domain;
2924 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
2925 $part_svc->part_svc_column('domsvc')->columnvalue;