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;
39 use FS::cust_main_invoice;
44 use FS::radius_usergroup;
51 @ISA = qw( FS::svc_Common );
54 $me = '[FS::svc_acct]';
56 #ask FS::UID to run this stuff for us later
57 FS::UID->install_callback( sub {
59 $dir_prefix = $conf->config('home');
60 @shells = $conf->config('shells');
61 $usernamemin = $conf->config('usernamemin') || 2;
62 $usernamemax = $conf->config('usernamemax');
63 $passwordmin = $conf->config('passwordmin'); # || 6;
65 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
68 $passwordmax = $conf->config('passwordmax') || 8;
69 $username_letter = $conf->exists('username-letter');
70 $username_letterfirst = $conf->exists('username-letterfirst');
71 $username_noperiod = $conf->exists('username-noperiod');
72 $username_nounderscore = $conf->exists('username-nounderscore');
73 $username_nodash = $conf->exists('username-nodash');
74 $username_uppercase = $conf->exists('username-uppercase');
75 $username_ampersand = $conf->exists('username-ampersand');
76 $username_percent = $conf->exists('username-percent');
77 $username_colon = $conf->exists('username-colon');
78 $password_noampersand = $conf->exists('password-noexclamation');
79 $password_noexclamation = $conf->exists('password-noexclamation');
80 $dirhash = $conf->config('dirhash') || 0;
81 if ( $conf->exists('warning_email') ) {
82 $warning_template = new Text::Template (
84 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
85 ) or warn "can't create warning email template: $Text::Template::ERROR";
86 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
87 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
88 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
89 $warning_cc = $conf->config('warning_email-cc');
91 $warning_template = '';
93 $warning_subject = '';
94 $warning_mimetype = '';
97 $smtpmachine = $conf->config('smtpmachine');
98 $radius_password = $conf->config('radius-password') || 'Password';
99 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
100 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
104 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
105 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
109 my ( $hashref, $cache ) = @_;
110 if ( $hashref->{'svc_acct_svcnum'} ) {
111 $self->{'_domsvc'} = FS::svc_domain->new( {
112 'svcnum' => $hashref->{'domsvc'},
113 'domain' => $hashref->{'svc_acct_domain'},
114 'catchall' => $hashref->{'svc_acct_catchall'},
121 FS::svc_acct - Object methods for svc_acct records
127 $record = new FS::svc_acct \%hash;
128 $record = new FS::svc_acct { 'column' => 'value' };
130 $error = $record->insert;
132 $error = $new_record->replace($old_record);
134 $error = $record->delete;
136 $error = $record->check;
138 $error = $record->suspend;
140 $error = $record->unsuspend;
142 $error = $record->cancel;
144 %hash = $record->radius;
146 %hash = $record->radius_reply;
148 %hash = $record->radius_check;
150 $domain = $record->domain;
152 $svc_domain = $record->svc_domain;
154 $email = $record->email;
156 $seconds_since = $record->seconds_since($timestamp);
160 An FS::svc_acct object represents an account. FS::svc_acct inherits from
161 FS::svc_Common. The following fields are currently supported:
167 Primary key (assigned automatcially for new accounts)
175 =item _password_encoding
177 plain, crypt, ldap (or empty for autodetection)
185 Point of presence (see L<FS::svc_acct_pop>)
197 set automatically if blank (and uid is not)
217 svcnum from svc_domain
221 Optional svcnum from svc_pbx
223 =item radius_I<Radius_Attribute>
225 I<Radius-Attribute> (reply)
227 =item rc_I<Radius_Attribute>
229 I<Radius-Attribute> (check)
239 Creates a new account. To add the account to the database, see L<"insert">.
246 'longname_plural' => 'Access accounts and mailboxes',
247 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
248 'display_weight' => 10,
249 'cancel_weight' => 50,
251 'dir' => 'Home directory',
254 def_info => 'set to fixed and blank for no UIDs',
257 'slipip' => 'IP address',
258 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
260 label => 'Access number',
262 select_table => 'svc_acct_pop',
263 select_key => 'popnum',
264 select_label => 'city',
270 disable_default => 1,
277 disable_inventory => 1,
280 '_password' => 'Password',
283 def_info => 'when blank, defaults to UID',
288 def_info => 'set to blank for no shell tracking',
290 #select_list => [ $conf->config('shells') ],
291 select_list => [ $conf ? $conf->config('shells') : () ],
292 disable_inventory => 1,
295 'finger' => 'Real name', # (GECOS)',
299 select_table => 'svc_domain',
300 select_key => 'svcnum',
301 select_label => 'domain',
302 disable_inventory => 1,
308 select_table => 'svc_domain',
309 select_key => 'svcnum',
310 select_label => 'domain',
311 disable_inventory => 1,
314 'pbxsvc' => { label => 'PBX',
315 type => 'select-svc_pbx.html',
316 disable_inventory => 1,
317 disable_select => 1, #UI wonky, pry works otherwise
320 label => 'RADIUS groups',
321 type => 'radius_usergroup_selector',
322 disable_inventory => 1,
325 'seconds' => { label => 'Seconds',
326 label_sort => 'with Time Remaining',
328 disable_inventory => 1,
330 disable_part_svc_column => 1,
332 'upbytes' => { label => 'Upload',
334 disable_inventory => 1,
336 'format' => \&FS::UI::bytecount::display_bytecount,
337 'parse' => \&FS::UI::bytecount::parse_bytecount,
338 disable_part_svc_column => 1,
340 'downbytes' => { label => 'Download',
342 disable_inventory => 1,
344 'format' => \&FS::UI::bytecount::display_bytecount,
345 'parse' => \&FS::UI::bytecount::parse_bytecount,
346 disable_part_svc_column => 1,
348 'totalbytes'=> { label => 'Total up and download',
350 disable_inventory => 1,
352 'format' => \&FS::UI::bytecount::display_bytecount,
353 'parse' => \&FS::UI::bytecount::parse_bytecount,
354 disable_part_svc_column => 1,
356 'seconds_threshold' => { label => 'Seconds threshold',
358 disable_inventory => 1,
360 disable_part_svc_column => 1,
362 'upbytes_threshold' => { label => 'Upload threshold',
364 disable_inventory => 1,
366 'format' => \&FS::UI::bytecount::display_bytecount,
367 'parse' => \&FS::UI::bytecount::parse_bytecount,
368 disable_part_svc_column => 1,
370 'downbytes_threshold' => { label => 'Download threshold',
372 disable_inventory => 1,
374 'format' => \&FS::UI::bytecount::display_bytecount,
375 'parse' => \&FS::UI::bytecount::parse_bytecount,
376 disable_part_svc_column => 1,
378 'totalbytes_threshold'=> { label => 'Total up and download threshold',
380 disable_inventory => 1,
382 'format' => \&FS::UI::bytecount::display_bytecount,
383 'parse' => \&FS::UI::bytecount::parse_bytecount,
384 disable_part_svc_column => 1,
387 label => 'Last login',
391 label => 'Last logout',
398 sub table { 'svc_acct'; }
400 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
404 #false laziness with edit/svc_acct.cgi
406 my( $self, $groups ) = @_;
407 if ( ref($groups) eq 'ARRAY' ) {
409 } elsif ( length($groups) ) {
410 [ split(/\s*,\s*/, $groups) ];
419 shift->_lastlog('in', @_);
423 shift->_lastlog('out', @_);
427 my( $self, $op, $time ) = @_;
429 if ( defined($time) ) {
430 warn "$me last_log$op called on svcnum ". $self->svcnum.
431 ' ('. $self->email. "): $time\n"
436 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
440 my $sth = $dbh->prepare( $sql )
441 or die "Error preparing $sql: ". $dbh->errstr;
442 my $rv = $sth->execute($time, $self->svcnum);
443 die "Error executing $sql: ". $sth->errstr
445 die "Can't update last_log$op for svcnum". $self->svcnum
448 $self->{'Hash'}->{"last_log$op"} = $time;
450 $self->getfield("last_log$op");
454 =item search_sql STRING
456 Class method which returns an SQL fragment to search for the given string.
461 my( $class, $string ) = @_;
462 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
463 my( $username, $domain ) = ( $1, $2 );
464 my $q_username = dbh->quote($username);
465 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
467 "svc_acct.username = $q_username AND ( ".
468 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
473 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
475 $class->search_sql_field('slipip', $string ).
477 $class->search_sql_field('username', $string ).
480 $class->search_sql_field('username', $string);
484 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
486 Returns the "username@domain" string for this account.
488 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
498 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
500 Returns a longer string label for this acccount ("Real Name <username@domain>"
501 if available, or "username@domain").
503 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
510 my $label = $self->label(@_);
511 my $finger = $self->finger;
512 return $label unless $finger =~ /\S/;
513 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
514 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
518 =item insert [ , OPTION => VALUE ... ]
520 Adds this account to the database. If there is an error, returns the error,
521 otherwise returns false.
523 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
524 defined. An FS::cust_svc record will be created and inserted.
526 The additional field I<usergroup> can optionally be defined; if so it should
527 contain an arrayref of group names. See L<FS::radius_usergroup>.
529 The additional field I<child_objects> can optionally be defined; if so it
530 should contain an arrayref of FS::tablename objects. They will have their
531 svcnum fields set and will be inserted after this record, but before any
532 exports are run. Each element of the array can also optionally be a
533 two-element array reference containing the child object and the name of an
534 alternate field to be filled in with the newly-inserted svcnum, for example
535 C<[ $svc_forward, 'srcsvc' ]>
537 Currently available options are: I<depend_jobnum>
539 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
540 jobnums), all provisioning jobs will have a dependancy on the supplied
541 jobnum(s) (they will not run until the specific job(s) complete(s)).
543 (TODOC: L<FS::queue> and L<freeside-queued>)
545 (TODOC: new exports!)
554 warn "[$me] insert called on $self: ". Dumper($self).
555 "\nwith options: ". Dumper(%options);
558 local $SIG{HUP} = 'IGNORE';
559 local $SIG{INT} = 'IGNORE';
560 local $SIG{QUIT} = 'IGNORE';
561 local $SIG{TERM} = 'IGNORE';
562 local $SIG{TSTP} = 'IGNORE';
563 local $SIG{PIPE} = 'IGNORE';
565 my $oldAutoCommit = $FS::UID::AutoCommit;
566 local $FS::UID::AutoCommit = 0;
570 my $error = $self->SUPER::insert(
571 'jobnums' => \@jobnums,
572 'child_objects' => $self->child_objects,
576 $dbh->rollback if $oldAutoCommit;
580 if ( $self->usergroup ) {
581 foreach my $groupname ( @{$self->usergroup} ) {
582 my $radius_usergroup = new FS::radius_usergroup ( {
583 svcnum => $self->svcnum,
584 groupname => $groupname,
586 my $error = $radius_usergroup->insert;
588 $dbh->rollback if $oldAutoCommit;
594 unless ( $skip_fuzzyfiles ) {
595 $error = $self->queue_fuzzyfiles_update;
597 $dbh->rollback if $oldAutoCommit;
598 return "updating fuzzy search cache: $error";
602 my $cust_pkg = $self->cust_svc->cust_pkg;
605 my $cust_main = $cust_pkg->cust_main;
606 my $agentnum = $cust_main->agentnum;
608 if ( $conf->exists('emailinvoiceautoalways')
609 || $conf->exists('emailinvoiceauto')
610 && ! $cust_main->invoicing_list_emailonly
612 my @invoicing_list = $cust_main->invoicing_list;
613 push @invoicing_list, $self->email;
614 $cust_main->invoicing_list(\@invoicing_list);
618 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
619 = ('','','','','','');
621 if ( $conf->exists('welcome_email', $agentnum) ) {
622 $welcome_template = new Text::Template (
624 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
625 ) or warn "can't create welcome email template: $Text::Template::ERROR";
626 $welcome_from = $conf->config('welcome_email-from', $agentnum);
627 # || 'your-isp-is-dum'
628 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
630 $welcome_subject_template = new Text::Template (
632 SOURCE => $welcome_subject,
633 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
634 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
637 if ( $welcome_template && $cust_pkg ) {
638 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
642 'custnum' => $self->custnum,
643 'username' => $self->username,
644 'password' => $self->_password,
645 'first' => $cust_main->first,
646 'last' => $cust_main->getfield('last'),
647 'pkg' => $cust_pkg->part_pkg->pkg,
649 my $wqueue = new FS::queue {
650 'svcnum' => $self->svcnum,
651 'job' => 'FS::svc_acct::send_email'
653 my $error = $wqueue->insert(
655 'from' => $welcome_from,
656 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
657 'mimetype' => $welcome_mimetype,
658 'body' => $welcome_template->fill_in( HASH => \%hash, ),
661 $dbh->rollback if $oldAutoCommit;
662 return "error queuing welcome email: $error";
665 if ( $options{'depend_jobnum'} ) {
666 warn "$me depend_jobnum found; adding to welcome email dependancies"
668 if ( ref($options{'depend_jobnum'}) ) {
669 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
670 "to welcome email dependancies"
672 push @jobnums, @{ $options{'depend_jobnum'} };
674 warn "$me adding job $options{'depend_jobnum'} ".
675 "to welcome email dependancies"
677 push @jobnums, $options{'depend_jobnum'};
681 foreach my $jobnum ( @jobnums ) {
682 my $error = $wqueue->depend_insert($jobnum);
684 $dbh->rollback if $oldAutoCommit;
685 return "error queuing welcome email job dependancy: $error";
695 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
699 # set usage fields and thresholds if unset but set in a package def
700 # AND the package already has a last bill date (otherwise they get double added)
701 sub preinsert_hook_first {
704 return '' unless $self->pkgnum;
706 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
707 return '' unless $cust_pkg && $cust_pkg->last_bill;
709 my $part_pkg = $cust_pkg->part_pkg;
710 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
712 my %values = $part_pkg->usage_valuehash;
713 my $multiplier = $conf->exists('svc_acct-usage_threshold')
714 ? 1 - $conf->config('svc_acct-usage_threshold')/100
715 : 0.20; #doesn't matter
717 foreach ( keys %values ) {
718 next if $self->getfield($_);
719 $self->setfield( $_, $values{$_} );
720 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
721 if $conf->exists('svc_acct-usage_threshold');
729 Deletes this account from the database. If there is an error, returns the
730 error, otherwise returns false.
732 The corresponding FS::cust_svc record will be deleted as well.
734 (TODOC: new exports!)
741 return "can't delete system account" if $self->_check_system;
743 return "Can't delete an account which is a (svc_forward) source!"
744 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
746 return "Can't delete an account which is a (svc_forward) destination!"
747 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
749 return "Can't delete an account with (svc_www) web service!"
750 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
752 # what about records in session ? (they should refer to history table)
754 local $SIG{HUP} = 'IGNORE';
755 local $SIG{INT} = 'IGNORE';
756 local $SIG{QUIT} = 'IGNORE';
757 local $SIG{TERM} = 'IGNORE';
758 local $SIG{TSTP} = 'IGNORE';
759 local $SIG{PIPE} = 'IGNORE';
761 my $oldAutoCommit = $FS::UID::AutoCommit;
762 local $FS::UID::AutoCommit = 0;
765 foreach my $cust_main_invoice (
766 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
768 unless ( defined($cust_main_invoice) ) {
769 warn "WARNING: something's wrong with qsearch";
772 my %hash = $cust_main_invoice->hash;
773 $hash{'dest'} = $self->email;
774 my $new = new FS::cust_main_invoice \%hash;
775 my $error = $new->replace($cust_main_invoice);
777 $dbh->rollback if $oldAutoCommit;
782 foreach my $svc_domain (
783 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
785 my %hash = new FS::svc_domain->hash;
786 $hash{'catchall'} = '';
787 my $new = new FS::svc_domain \%hash;
788 my $error = $new->replace($svc_domain);
790 $dbh->rollback if $oldAutoCommit;
795 my $error = $self->SUPER::delete;
797 $dbh->rollback if $oldAutoCommit;
801 foreach my $radius_usergroup (
802 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
804 my $error = $radius_usergroup->delete;
806 $dbh->rollback if $oldAutoCommit;
811 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
815 =item replace OLD_RECORD
817 Replaces OLD_RECORD with this one in the database. If there is an error,
818 returns the error, otherwise returns false.
820 The additional field I<usergroup> can optionally be defined; if so it should
821 contain an arrayref of group names. See L<FS::radius_usergroup>.
829 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
833 warn "$me replacing $old with $new\n" if $DEBUG;
837 return "can't modify system account" if $old->_check_system;
840 #no warnings 'numeric'; #alas, a 5.006-ism
843 foreach my $xid (qw( uid gid )) {
845 return "Can't change $xid!"
846 if ! $conf->exists("svc_acct-edit_$xid")
847 && $old->$xid() != $new->$xid()
848 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
853 #change homdir when we change username
854 $new->setfield('dir', '') if $old->username ne $new->username;
856 local $SIG{HUP} = 'IGNORE';
857 local $SIG{INT} = 'IGNORE';
858 local $SIG{QUIT} = 'IGNORE';
859 local $SIG{TERM} = 'IGNORE';
860 local $SIG{TSTP} = 'IGNORE';
861 local $SIG{PIPE} = 'IGNORE';
863 my $oldAutoCommit = $FS::UID::AutoCommit;
864 local $FS::UID::AutoCommit = 0;
867 # redundant, but so $new->usergroup gets set
868 $error = $new->check;
869 return $error if $error;
871 $old->usergroup( [ $old->radius_groups ] );
873 warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
874 warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
876 if ( $new->usergroup ) {
877 #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
878 my @newgroups = @{$new->usergroup};
879 foreach my $oldgroup ( @{$old->usergroup} ) {
880 if ( grep { $oldgroup eq $_ } @newgroups ) {
881 @newgroups = grep { $oldgroup ne $_ } @newgroups;
884 my $radius_usergroup = qsearchs('radius_usergroup', {
885 svcnum => $old->svcnum,
886 groupname => $oldgroup,
888 my $error = $radius_usergroup->delete;
890 $dbh->rollback if $oldAutoCommit;
891 return "error deleting radius_usergroup $oldgroup: $error";
895 foreach my $newgroup ( @newgroups ) {
896 my $radius_usergroup = new FS::radius_usergroup ( {
897 svcnum => $new->svcnum,
898 groupname => $newgroup,
900 my $error = $radius_usergroup->insert;
902 $dbh->rollback if $oldAutoCommit;
903 return "error adding radius_usergroup $newgroup: $error";
909 $error = $new->SUPER::replace($old, @_);
911 $dbh->rollback if $oldAutoCommit;
912 return $error if $error;
915 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
916 $error = $new->queue_fuzzyfiles_update;
918 $dbh->rollback if $oldAutoCommit;
919 return "updating fuzzy search cache: $error";
923 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
927 =item queue_fuzzyfiles_update
929 Used by insert & replace to update the fuzzy search cache
933 sub queue_fuzzyfiles_update {
936 local $SIG{HUP} = 'IGNORE';
937 local $SIG{INT} = 'IGNORE';
938 local $SIG{QUIT} = 'IGNORE';
939 local $SIG{TERM} = 'IGNORE';
940 local $SIG{TSTP} = 'IGNORE';
941 local $SIG{PIPE} = 'IGNORE';
943 my $oldAutoCommit = $FS::UID::AutoCommit;
944 local $FS::UID::AutoCommit = 0;
947 my $queue = new FS::queue {
948 'svcnum' => $self->svcnum,
949 'job' => 'FS::svc_acct::append_fuzzyfiles'
951 my $error = $queue->insert($self->username);
953 $dbh->rollback if $oldAutoCommit;
954 return "queueing job (transaction rolled back): $error";
957 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
965 Suspends this account by calling export-specific suspend hooks. If there is
966 an error, returns the error, otherwise returns false.
968 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
974 return "can't suspend system account" if $self->_check_system;
975 $self->SUPER::suspend(@_);
980 Unsuspends this account by by calling export-specific suspend hooks. If there
981 is an error, returns the error, otherwise returns false.
983 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
989 my %hash = $self->hash;
990 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
991 $hash{_password} = $1;
992 my $new = new FS::svc_acct ( \%hash );
993 my $error = $new->replace($self);
994 return $error if $error;
997 $self->SUPER::unsuspend(@_);
1002 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1004 If the B<auto_unset_catchall> configuration option is set, this method will
1005 automatically remove any references to the canceled service in the catchall
1006 field of svc_domain. This allows packages that contain both a svc_domain and
1007 its catchall svc_acct to be canceled in one step.
1012 # Only one thing to do at this level
1014 foreach my $svc_domain (
1015 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1016 if($conf->exists('auto_unset_catchall')) {
1017 my %hash = $svc_domain->hash;
1018 $hash{catchall} = '';
1019 my $new = new FS::svc_domain ( \%hash );
1020 my $error = $new->replace($svc_domain);
1021 return $error if $error;
1023 return "cannot unprovision svc_acct #".$self->svcnum.
1024 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1028 $self->SUPER::cancel(@_);
1034 Checks all fields to make sure this is a valid service. If there is an error,
1035 returns the error, otherwise returns false. Called by the insert and replace
1038 Sets any fixed values; see L<FS::part_svc>.
1045 my($recref) = $self->hashref;
1047 my $x = $self->setfixed( $self->_fieldhandlers );
1048 return $x unless ref($x);
1051 if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
1053 [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
1056 my $error = $self->ut_numbern('svcnum')
1057 #|| $self->ut_number('domsvc')
1058 || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1059 || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' )
1060 || $self->ut_textn('sec_phrase')
1061 || $self->ut_snumbern('seconds')
1062 || $self->ut_snumbern('upbytes')
1063 || $self->ut_snumbern('downbytes')
1064 || $self->ut_snumbern('totalbytes')
1065 || $self->ut_enum( '_password_encoding',
1066 [ '', qw( plain crypt ldap ) ]
1069 return $error if $error;
1072 local $username_letter = $username_letter;
1073 if ($self->svcnum) {
1074 my $cust_svc = $self->cust_svc
1075 or return "no cust_svc record found for svcnum ". $self->svcnum;
1076 my $cust_pkg = $cust_svc->cust_pkg;
1078 if ($self->pkgnum) {
1079 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1083 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1086 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1087 if ( $username_uppercase ) {
1088 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/i
1089 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1090 $recref->{username} = $1;
1092 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:]{$usernamemin,$ulen})$/
1093 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1094 $recref->{username} = $1;
1097 if ( $username_letterfirst ) {
1098 $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
1099 } elsif ( $username_letter ) {
1100 $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
1102 if ( $username_noperiod ) {
1103 $recref->{username} =~ /\./ and return gettext('illegal_username');
1105 if ( $username_nounderscore ) {
1106 $recref->{username} =~ /_/ and return gettext('illegal_username');
1108 if ( $username_nodash ) {
1109 $recref->{username} =~ /\-/ and return gettext('illegal_username');
1111 unless ( $username_ampersand ) {
1112 $recref->{username} =~ /\&/ and return gettext('illegal_username');
1114 unless ( $username_percent ) {
1115 $recref->{username} =~ /\%/ and return gettext('illegal_username');
1117 unless ( $username_colon ) {
1118 $recref->{username} =~ /\:/ and return gettext('illegal_username');
1121 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1122 $recref->{popnum} = $1;
1123 return "Unknown popnum" unless
1124 ! $recref->{popnum} ||
1125 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1127 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1129 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1130 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1132 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1133 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1134 #not all systems use gid=uid
1135 #you can set a fixed gid in part_svc
1137 return "Only root can have uid 0"
1138 if $recref->{uid} == 0
1139 && $recref->{username} !~ /^(root|toor|smtp)$/;
1141 unless ( $recref->{username} eq 'sync' ) {
1142 if ( grep $_ eq $recref->{shell}, @shells ) {
1143 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1145 return "Illegal shell \`". $self->shell. "\'; ".
1146 "shells configuration value contains: @shells";
1149 $recref->{shell} = '/bin/sync';
1153 $recref->{gid} ne '' ?
1154 return "Can't have gid without uid" : ( $recref->{gid}='' );
1155 #$recref->{dir} ne '' ?
1156 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1157 $recref->{shell} ne '' ?
1158 return "Can't have shell without uid" : ( $recref->{shell}='' );
1161 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1163 $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1164 or return "Illegal directory: ". $recref->{dir};
1165 $recref->{dir} = $1;
1166 return "Illegal directory"
1167 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1168 return "Illegal directory"
1169 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1170 unless ( $recref->{dir} ) {
1171 $recref->{dir} = $dir_prefix . '/';
1172 if ( $dirhash > 0 ) {
1173 for my $h ( 1 .. $dirhash ) {
1174 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1176 } elsif ( $dirhash < 0 ) {
1177 for my $h ( reverse $dirhash .. -1 ) {
1178 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1181 $recref->{dir} .= $recref->{username};
1187 # $error = $self->ut_textn('finger');
1188 # return $error if $error;
1189 if ( $self->getfield('finger') eq '' ) {
1190 my $cust_pkg = $self->svcnum
1191 ? $self->cust_svc->cust_pkg
1192 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1194 my $cust_main = $cust_pkg->cust_main;
1195 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1198 $self->getfield('finger') =~
1199 /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1200 or return "Illegal finger: ". $self->getfield('finger');
1201 $self->setfield('finger', $1);
1203 $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1204 $recref->{quota} = $1;
1206 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1207 if ( $recref->{slipip} eq '' ) {
1208 $recref->{slipip} = '';
1209 } elsif ( $recref->{slipip} eq '0e0' ) {
1210 $recref->{slipip} = '0e0';
1212 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1213 or return "Illegal slipip: ". $self->slipip;
1214 $recref->{slipip} = $1;
1219 #arbitrary RADIUS stuff; allow ut_textn for now
1220 foreach ( grep /^radius_/, fields('svc_acct') ) {
1221 $self->ut_textn($_);
1224 # First, if _password is blank, generate one and set default encoding.
1225 if ( ! $recref->{_password} ) {
1226 $error = $self->set_password('');
1228 # But if there's a _password but no encoding, assume it's plaintext and
1229 # set it to default encoding.
1230 elsif ( ! $recref->{_password_encoding} ) {
1231 $error = $self->set_password($recref->{_password});
1233 return $error if $error;
1235 # Next, check _password to ensure compliance with the encoding.
1236 if ( $recref->{_password_encoding} eq 'ldap' ) {
1238 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1239 $recref->{_password} = uc($1).$2;
1241 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1244 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1246 if ( $recref->{_password} =~
1247 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1248 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1251 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1254 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1257 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1258 # Password randomization is now in set_password.
1259 # Strip whitespace characters, check length requirements, etc.
1260 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1261 $recref->{_password} = $1;
1263 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1264 FS::Msgcat::_gettext('illegal_password_characters').
1265 ": ". $recref->{_password};
1268 if ( $password_noampersand ) {
1269 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1271 if ( $password_noexclamation ) {
1272 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1276 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1278 $self->SUPER::check;
1283 sub _password_encryption {
1285 my $encoding = lc($self->_password_encoding);
1286 return if !$encoding;
1287 return 'plain' if $encoding eq 'plain';
1288 if($encoding eq 'crypt') {
1289 my $pass = $self->_password;
1290 $pass =~ s/^\*SUSPENDED\* //;
1292 return 'md5' if $pass =~ /^\$1\$/;
1293 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1294 return 'des' if length($pass) == 13;
1297 if($encoding eq 'ldap') {
1298 uc($self->_password) =~ /^\{([\w-]+)\}/;
1299 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1300 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1301 return 'md5' if $1 eq 'MD5';
1302 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1309 sub get_cleartext_password {
1311 if($self->_password_encryption eq 'plain') {
1312 if($self->_password_encoding eq 'ldap') {
1313 $self->_password =~ /\{\w+\}(.*)$/;
1317 return $self->_password;
1326 Set the cleartext password for the account. If _password_encoding is set, the
1327 new password will be encoded according to the existing method (including
1328 encryption mode, if it can be determined). Otherwise,
1329 config('default-password-encoding') is used.
1331 If no password is supplied (or a zero-length password when minimum password length
1332 is >0), one will be generated randomly.
1337 my( $self, $pass ) = ( shift, shift );
1339 warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1342 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1343 FS::Msgcat::_gettext('illegal_password_characters').
1346 my( $encoding, $encryption ) = ('', '');
1348 if ( $self->_password_encoding ) {
1349 $encoding = $self->_password_encoding;
1350 # identify existing encryption method, try to use it.
1351 $encryption = $self->_password_encryption;
1353 # use the system default
1359 # set encoding to system default
1360 ($encoding, $encryption) =
1361 split(/-/, lc($conf->config('default-password-encoding')));
1362 $encoding ||= 'legacy';
1363 $self->_password_encoding($encoding);
1366 if ( $encoding eq 'legacy' ) {
1368 # The legacy behavior from check():
1369 # If the password is blank, randomize it and set encoding to 'plain'.
1370 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1371 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1372 $self->_password_encoding('plain');
1374 # Prefix + valid-length password
1375 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1377 $self->_password_encoding('plain');
1378 # Prefix + crypt string
1379 } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1381 $self->_password_encoding('crypt');
1382 # Various disabled crypt passwords
1383 } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1384 $self->_password_encoding('crypt');
1390 $self->_password($pass);
1396 if $passwordmin && length($pass) < $passwordmin
1397 or $passwordmax && length($pass) > $passwordmax;
1399 if ( $encoding eq 'crypt' ) {
1400 if ($encryption eq 'md5') {
1401 $pass = unix_md5_crypt($pass);
1402 } elsif ($encryption eq 'des') {
1403 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1406 } elsif ( $encoding eq 'ldap' ) {
1407 if ($encryption eq 'md5') {
1408 $pass = md5_base64($pass);
1409 } elsif ($encryption eq 'sha1') {
1410 $pass = sha1_base64($pass);
1411 } elsif ($encryption eq 'crypt') {
1412 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1414 # else $encryption eq 'plain', do nothing
1415 $pass = '{'.uc($encryption).'}'.$pass;
1417 # else encoding eq 'plain'
1419 $self->_password($pass);
1425 Internal function to check the username against the list of system usernames
1426 from the I<system_usernames> configuration value. Returns true if the username
1427 is listed on the system username list.
1433 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1434 $conf->config('system_usernames')
1438 =item _check_duplicate
1440 Internal method to check for duplicates usernames, username@domain pairs and
1443 If the I<global_unique-username> configuration value is set to B<username> or
1444 B<username@domain>, enforces global username or username@domain uniqueness.
1446 In all cases, check for duplicate uids and usernames or username@domain pairs
1447 per export and with identical I<svcpart> values.
1451 sub _check_duplicate {
1454 my $global_unique = $conf->config('global_unique-username') || 'none';
1455 return '' if $global_unique eq 'disabled';
1459 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1460 unless ( $part_svc ) {
1461 return 'unknown svcpart '. $self->svcpart;
1464 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1465 qsearch( 'svc_acct', { 'username' => $self->username } );
1466 return gettext('username_in_use')
1467 if $global_unique eq 'username' && @dup_user;
1469 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1470 qsearch( 'svc_acct', { 'username' => $self->username,
1471 'domsvc' => $self->domsvc } );
1472 return gettext('username_in_use')
1473 if $global_unique eq 'username@domain' && @dup_userdomain;
1476 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1477 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1478 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1479 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1484 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1485 my $exports = FS::part_export::export_info('svc_acct');
1486 my %conflict_user_svcpart;
1487 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1489 foreach my $part_export ( $part_svc->part_export ) {
1491 #this will catch to the same exact export
1492 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1494 #this will catch to exports w/same exporthost+type ???
1495 #my @other_part_export = qsearch('part_export', {
1496 # 'machine' => $part_export->machine,
1497 # 'exporttype' => $part_export->exporttype,
1499 #foreach my $other_part_export ( @other_part_export ) {
1500 # push @svcparts, map { $_->svcpart }
1501 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1504 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1505 #silly kludge to avoid uninitialized value errors
1506 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1507 ? $exports->{$part_export->exporttype}{'nodomain'}
1509 if ( $nodomain =~ /^Y/i ) {
1510 $conflict_user_svcpart{$_} = $part_export->exportnum
1513 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1518 foreach my $dup_user ( @dup_user ) {
1519 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1520 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1521 return "duplicate username ". $self->username.
1522 ": conflicts with svcnum ". $dup_user->svcnum.
1523 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1527 foreach my $dup_userdomain ( @dup_userdomain ) {
1528 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1529 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1530 return "duplicate username\@domain ". $self->email.
1531 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1532 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1536 foreach my $dup_uid ( @dup_uid ) {
1537 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1538 if ( exists($conflict_user_svcpart{$dup_svcpart})
1539 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1540 return "duplicate uid ". $self->uid.
1541 ": conflicts with svcnum ". $dup_uid->svcnum.
1543 ( $conflict_user_svcpart{$dup_svcpart}
1544 || $conflict_userdomain_svcpart{$dup_svcpart} );
1556 Depriciated, use radius_reply instead.
1561 carp "FS::svc_acct::radius depriciated, use radius_reply";
1562 $_[0]->radius_reply;
1567 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1568 reply attributes of this record.
1570 Note that this is now the preferred method for reading RADIUS attributes -
1571 accessing the columns directly is discouraged, as the column names are
1572 expected to change in the future.
1579 return %{ $self->{'radius_reply'} }
1580 if exists $self->{'radius_reply'};
1585 my($column, $attrib) = ($1, $2);
1586 #$attrib =~ s/_/\-/g;
1587 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1588 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1590 if ( $self->slipip && $self->slipip ne '0e0' ) {
1591 $reply{$radius_ip} = $self->slipip;
1594 if ( $self->seconds !~ /^$/ ) {
1595 $reply{'Session-Timeout'} = $self->seconds;
1598 if ( $conf->exists('radius-chillispot-max') ) {
1599 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1601 #hmm. just because sqlradius.pm says so?
1608 foreach my $what (qw( input output total )) {
1609 my $is = $whatis{$what}.'bytes';
1610 if ( $self->$is() =~ /\d/ ) {
1611 my $big = new Math::BigInt $self->$is();
1612 $big = new Math::BigInt '0' if $big->is_neg();
1613 my $att = "Chillispot-Max-\u$what";
1614 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1615 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1626 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1627 check attributes of this record.
1629 Note that this is now the preferred method for reading RADIUS attributes -
1630 accessing the columns directly is discouraged, as the column names are
1631 expected to change in the future.
1638 return %{ $self->{'radius_check'} }
1639 if exists $self->{'radius_check'};
1644 my($column, $attrib) = ($1, $2);
1645 #$attrib =~ s/_/\-/g;
1646 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1647 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1650 my($pw_attrib, $password) = $self->radius_password;
1651 $check{$pw_attrib} = $password;
1653 my $cust_svc = $self->cust_svc;
1655 my $cust_pkg = $cust_svc->cust_pkg;
1656 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1657 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1660 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1661 "; can't set Expiration\n"
1669 =item radius_password
1671 Returns a key/value pair containing the RADIUS attribute name and value
1676 sub radius_password {
1680 if ( $self->_password_encoding eq 'ldap' ) {
1681 $pw_attrib = 'Password-With-Header';
1682 } elsif ( $self->_password_encoding eq 'crypt' ) {
1683 $pw_attrib = 'Crypt-Password';
1684 } elsif ( $self->_password_encoding eq 'plain' ) {
1685 $pw_attrib = $radius_password;
1687 $pw_attrib = length($self->_password) <= 12
1692 ($pw_attrib, $self->_password);
1698 This method instructs the object to "snapshot" or freeze RADIUS check and
1699 reply attributes to the current values.
1703 #bah, my english is too broken this morning
1704 #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
1705 #the FS::cust_pkg's replace method to trigger the correct export updates when
1706 #package dates change)
1711 $self->{$_} = { $self->$_() }
1712 foreach qw( radius_reply radius_check );
1716 =item forget_snapshot
1718 This methos instructs the object to forget any previously snapshotted
1719 RADIUS check and reply attributes.
1723 sub forget_snapshot {
1727 foreach qw( radius_reply radius_check );
1731 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1733 Returns the domain associated with this account.
1735 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1742 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1743 my $svc_domain = $self->svc_domain(@_)
1744 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1745 $svc_domain->domain;
1750 Returns the FS::svc_domain record for this account's domain (see
1755 # FS::h_svc_acct has a history-aware svc_domain override
1760 ? $self->{'_domsvc'}
1761 : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1766 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1770 #inherited from svc_Common
1772 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1774 Returns an email address associated with the account.
1776 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1783 $self->username. '@'. $self->domain(@_);
1788 Returns an array of FS::acct_snarf records associated with the account.
1789 If the acct_snarf table does not exist or there are no associated records,
1790 an empty list is returned
1796 return () unless dbdef->table('acct_snarf');
1797 eval "use FS::acct_snarf;";
1799 qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1802 =item decrement_upbytes OCTETS
1804 Decrements the I<upbytes> field of this record by the given amount. If there
1805 is an error, returns the error, otherwise returns false.
1809 sub decrement_upbytes {
1810 shift->_op_usage('-', 'upbytes', @_);
1813 =item increment_upbytes OCTETS
1815 Increments the I<upbytes> field of this record by the given amount. If there
1816 is an error, returns the error, otherwise returns false.
1820 sub increment_upbytes {
1821 shift->_op_usage('+', 'upbytes', @_);
1824 =item decrement_downbytes OCTETS
1826 Decrements the I<downbytes> field of this record by the given amount. If there
1827 is an error, returns the error, otherwise returns false.
1831 sub decrement_downbytes {
1832 shift->_op_usage('-', 'downbytes', @_);
1835 =item increment_downbytes OCTETS
1837 Increments the I<downbytes> field of this record by the given amount. If there
1838 is an error, returns the error, otherwise returns false.
1842 sub increment_downbytes {
1843 shift->_op_usage('+', 'downbytes', @_);
1846 =item decrement_totalbytes OCTETS
1848 Decrements the I<totalbytes> field of this record by the given amount. If there
1849 is an error, returns the error, otherwise returns false.
1853 sub decrement_totalbytes {
1854 shift->_op_usage('-', 'totalbytes', @_);
1857 =item increment_totalbytes OCTETS
1859 Increments the I<totalbytes> field of this record by the given amount. If there
1860 is an error, returns the error, otherwise returns false.
1864 sub increment_totalbytes {
1865 shift->_op_usage('+', 'totalbytes', @_);
1868 =item decrement_seconds SECONDS
1870 Decrements the I<seconds> field of this record by the given amount. If there
1871 is an error, returns the error, otherwise returns false.
1875 sub decrement_seconds {
1876 shift->_op_usage('-', 'seconds', @_);
1879 =item increment_seconds SECONDS
1881 Increments the I<seconds> field of this record by the given amount. If there
1882 is an error, returns the error, otherwise returns false.
1886 sub increment_seconds {
1887 shift->_op_usage('+', 'seconds', @_);
1895 my %op2condition = (
1896 '-' => sub { my($self, $column, $amount) = @_;
1897 $self->$column - $amount <= 0;
1899 '+' => sub { my($self, $column, $amount) = @_;
1900 ($self->$column || 0) + $amount > 0;
1903 my %op2warncondition = (
1904 '-' => sub { my($self, $column, $amount) = @_;
1905 my $threshold = $column . '_threshold';
1906 $self->$column - $amount <= $self->$threshold + 0;
1908 '+' => sub { my($self, $column, $amount) = @_;
1909 ($self->$column || 0) + $amount > 0;
1914 my( $self, $op, $column, $amount ) = @_;
1916 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1917 ' ('. $self->email. "): $op $amount\n"
1920 return '' unless $amount;
1922 local $SIG{HUP} = 'IGNORE';
1923 local $SIG{INT} = 'IGNORE';
1924 local $SIG{QUIT} = 'IGNORE';
1925 local $SIG{TERM} = 'IGNORE';
1926 local $SIG{TSTP} = 'IGNORE';
1927 local $SIG{PIPE} = 'IGNORE';
1929 my $oldAutoCommit = $FS::UID::AutoCommit;
1930 local $FS::UID::AutoCommit = 0;
1933 my $sql = "UPDATE svc_acct SET $column = ".
1934 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1935 " $op ? WHERE svcnum = ?";
1939 my $sth = $dbh->prepare( $sql )
1940 or die "Error preparing $sql: ". $dbh->errstr;
1941 my $rv = $sth->execute($amount, $self->svcnum);
1942 die "Error executing $sql: ". $sth->errstr
1943 unless defined($rv);
1944 die "Can't update $column for svcnum". $self->svcnum
1947 #$self->snapshot; #not necessary, we retain the old values
1948 #create an object with the updated usage values
1949 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
1951 my $error = $new->replace($self);
1953 $dbh->rollback if $oldAutoCommit;
1954 return "Error replacing: $error";
1957 #overlimit_action eq 'cancel' handling
1958 my $cust_pkg = $self->cust_svc->cust_pkg;
1960 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
1961 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
1965 my $error = $cust_pkg->cancel; #XXX should have a reason
1967 $dbh->rollback if $oldAutoCommit;
1968 return "Error cancelling: $error";
1971 #nothing else is relevant if we're cancelling, so commit & return success
1972 warn "$me update successful; committing\n"
1974 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1979 my $action = $op2action{$op};
1981 if ( &{$op2condition{$op}}($self, $column, $amount) &&
1982 ( $action eq 'suspend' && !$self->overlimit
1983 || $action eq 'unsuspend' && $self->overlimit )
1986 my $error = $self->_op_overlimit($action);
1988 $dbh->rollback if $oldAutoCommit;
1994 if ( $conf->exists("svc_acct-usage_$action")
1995 && &{$op2condition{$op}}($self, $column, $amount) ) {
1996 #my $error = $self->$action();
1997 my $error = $self->cust_svc->cust_pkg->$action();
1998 # $error ||= $self->overlimit($action);
2000 $dbh->rollback if $oldAutoCommit;
2001 return "Error ${action}ing: $error";
2005 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2006 my $wqueue = new FS::queue {
2007 'svcnum' => $self->svcnum,
2008 'job' => 'FS::svc_acct::reached_threshold',
2013 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2017 my $error = $wqueue->insert(
2018 'svcnum' => $self->svcnum,
2020 'column' => $column,
2024 $dbh->rollback if $oldAutoCommit;
2025 return "Error queuing threshold activity: $error";
2029 warn "$me update successful; committing\n"
2031 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2037 my( $self, $action ) = @_;
2039 local $SIG{HUP} = 'IGNORE';
2040 local $SIG{INT} = 'IGNORE';
2041 local $SIG{QUIT} = 'IGNORE';
2042 local $SIG{TERM} = 'IGNORE';
2043 local $SIG{TSTP} = 'IGNORE';
2044 local $SIG{PIPE} = 'IGNORE';
2046 my $oldAutoCommit = $FS::UID::AutoCommit;
2047 local $FS::UID::AutoCommit = 0;
2050 my $cust_pkg = $self->cust_svc->cust_pkg;
2052 my $conf_overlimit =
2054 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2055 : $conf->config('overlimit_groups');
2057 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2059 my $groups = $conf_overlimit || $part_export->option('overlimit_groups');
2060 next unless $groups;
2062 my $gref = &{ $self->_fieldhandlers->{'usergroup'} }( $self, $groups );
2064 my $other = new FS::svc_acct $self->hashref;
2065 $other->usergroup( $gref );
2068 if ($action eq 'suspend') {
2071 } else { # $action eq 'unsuspend'
2076 my $error = $part_export->export_replace($new, $old)
2077 || $self->overlimit($action);
2080 $dbh->rollback if $oldAutoCommit;
2081 return "Error replacing radius groups: $error";
2086 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2092 my( $self, $valueref, %options ) = @_;
2094 warn "$me set_usage called for svcnum ". $self->svcnum.
2095 ' ('. $self->email. "): ".
2096 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2099 local $SIG{HUP} = 'IGNORE';
2100 local $SIG{INT} = 'IGNORE';
2101 local $SIG{QUIT} = 'IGNORE';
2102 local $SIG{TERM} = 'IGNORE';
2103 local $SIG{TSTP} = 'IGNORE';
2104 local $SIG{PIPE} = 'IGNORE';
2106 local $FS::svc_Common::noexport_hack = 1;
2107 my $oldAutoCommit = $FS::UID::AutoCommit;
2108 local $FS::UID::AutoCommit = 0;
2113 if ( $options{null} ) {
2114 %handyhash = ( map { ( $_ => 'NULL', $_."_threshold" => 'NULL' ) }
2115 qw( seconds upbytes downbytes totalbytes )
2118 foreach my $field (keys %$valueref){
2119 $reset = 1 if $valueref->{$field};
2120 $self->setfield($field, $valueref->{$field});
2121 $self->setfield( $field.'_threshold',
2122 int($self->getfield($field)
2123 * ( $conf->exists('svc_acct-usage_threshold')
2124 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2129 $handyhash{$field} = $self->getfield($field);
2130 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2132 #my $error = $self->replace; #NO! we avoid the call to ->check for
2133 #die $error if $error; #services not explicity changed via the UI
2135 my $sql = "UPDATE svc_acct SET " .
2136 join (',', map { "$_ = $handyhash{$_}" } (keys %handyhash) ).
2137 " WHERE svcnum = ". $self->svcnum;
2142 if (scalar(keys %handyhash)) {
2143 my $sth = $dbh->prepare( $sql )
2144 or die "Error preparing $sql: ". $dbh->errstr;
2145 my $rv = $sth->execute();
2146 die "Error executing $sql: ". $sth->errstr
2147 unless defined($rv);
2148 die "Can't update usage for svcnum ". $self->svcnum
2152 #$self->snapshot; #not necessary, we retain the old values
2153 #create an object with the updated usage values
2154 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2155 local($FS::Record::nowarn_identical) = 1;
2156 my $error = $new->replace($self); #call exports
2158 $dbh->rollback if $oldAutoCommit;
2159 return "Error replacing: $error";
2166 $error = $self->_op_overlimit('unsuspend')
2167 if $self->overlimit;;
2169 $error ||= $self->cust_svc->cust_pkg->unsuspend
2170 if $conf->exists("svc_acct-usage_unsuspend");
2173 $dbh->rollback if $oldAutoCommit;
2174 return "Error unsuspending: $error";
2179 warn "$me update successful; committing\n"
2181 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2187 =item recharge HASHREF
2189 Increments usage columns by the amount specified in HASHREF as
2190 column=>amount pairs.
2195 my ($self, $vhash) = @_;
2198 warn "[$me] recharge called on $self: ". Dumper($self).
2199 "\nwith vhash: ". Dumper($vhash);
2202 my $oldAutoCommit = $FS::UID::AutoCommit;
2203 local $FS::UID::AutoCommit = 0;
2207 foreach my $column (keys %$vhash){
2208 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2212 $dbh->rollback if $oldAutoCommit;
2214 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2219 =item is_rechargeable
2221 Returns true if this svc_account can be "recharged" and false otherwise.
2225 sub is_rechargable {
2227 $self->seconds ne ''
2228 || $self->upbytes ne ''
2229 || $self->downbytes ne ''
2230 || $self->totalbytes ne '';
2233 =item seconds_since TIMESTAMP
2235 Returns the number of seconds this account has been online since TIMESTAMP,
2236 according to the session monitor (see L<FS::Session>).
2238 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2239 L<Time::Local> and L<Date::Parse> for conversion functions.
2243 #note: POD here, implementation in FS::cust_svc
2246 $self->cust_svc->seconds_since(@_);
2249 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2251 Returns the numbers of seconds this account has been online between
2252 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2253 external SQL radacct table, specified via sqlradius export. Sessions which
2254 started in the specified range but are still open are counted from session
2255 start to the end of the range (unless they are over 1 day old, in which case
2256 they are presumed missing their stop record and not counted). Also, sessions
2257 which end in the range but started earlier are counted from the start of the
2258 range to session end. Finally, sessions which start before the range but end
2259 after are counted for the entire range.
2261 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2262 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2267 #note: POD here, implementation in FS::cust_svc
2268 sub seconds_since_sqlradacct {
2270 $self->cust_svc->seconds_since_sqlradacct(@_);
2273 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2275 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2276 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2277 TIMESTAMP_END (exclusive).
2279 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2280 L<perlfunc/"time">. Also see L<Time::Local> and L<Date::Parse> for conversion
2285 #note: POD here, implementation in FS::cust_svc
2286 sub attribute_since_sqlradacct {
2288 $self->cust_svc->attribute_since_sqlradacct(@_);
2291 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2293 Returns an array of hash references of this customers login history for the
2294 given time range. (document this better)
2298 sub get_session_history {
2300 $self->cust_svc->get_session_history(@_);
2303 =item last_login_text
2305 Returns text describing the time of last login.
2309 sub last_login_text {
2311 $self->last_login ? ctime($self->last_login) : 'unknown';
2314 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2319 my($self, $start, $end, %opt ) = @_;
2321 my $did = $self->username; #yup
2323 my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2325 my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2327 #SELECT $for_update * FROM cdr
2328 # WHERE calldate >= $start #need a conversion
2329 # AND calldate < $end #ditto
2330 # AND ( charged_party = "$did"
2331 # OR charged_party = "$prefix$did" #if length($prefix);
2332 # OR ( ( charged_party IS NULL OR charged_party = '' )
2334 # ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2337 # AND ( freesidestatus IS NULL OR freesidestatus = '' )
2340 if ( length($prefix) ) {
2342 " AND ( charged_party = '$did'
2343 OR charged_party = '$prefix$did'
2344 OR ( ( charged_party IS NULL OR charged_party = '' )
2346 ( src = '$did' OR src = '$prefix$did' )
2352 " AND ( charged_party = '$did'
2353 OR ( ( charged_party IS NULL OR charged_party = '' )
2363 'select' => "$for_update *",
2366 #( freesidestatus IS NULL OR freesidestatus = '' )
2367 'freesidestatus' => '',
2369 'extra_sql' => $charged_or_src,
2377 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
2383 if ( $self->usergroup ) {
2384 confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
2385 unless ref($self->usergroup) eq 'ARRAY';
2386 #when provisioning records, export callback runs in svc_Common.pm before
2387 #radius_usergroup records can be inserted...
2388 @{$self->usergroup};
2390 map { $_->groupname }
2391 qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
2395 =item clone_suspended
2397 Constructor used by FS::part_export::_export_suspend fallback. Document
2402 sub clone_suspended {
2404 my %hash = $self->hash;
2405 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2406 new FS::svc_acct \%hash;
2409 =item clone_kludge_unsuspend
2411 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2416 sub clone_kludge_unsuspend {
2418 my %hash = $self->hash;
2419 $hash{_password} = '';
2420 new FS::svc_acct \%hash;
2423 =item check_password
2425 Checks the supplied password against the (possibly encrypted) password in the
2426 database. Returns true for a successful authentication, false for no match.
2428 Currently supported encryptions are: classic DES crypt() and MD5
2432 sub check_password {
2433 my($self, $check_password) = @_;
2435 #remove old-style SUSPENDED kludge, they should be allowed to login to
2436 #self-service and pay up
2437 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2439 if ( $self->_password_encoding eq 'ldap' ) {
2441 my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2442 return $auth->match($check_password);
2444 } elsif ( $self->_password_encoding eq 'crypt' ) {
2446 my $auth = from_crypt Authen::Passphrase $self->_password;
2447 return $auth->match($check_password);
2449 } elsif ( $self->_password_encoding eq 'plain' ) {
2451 return $check_password eq $password;
2455 #XXX this could be replaced with Authen::Passphrase stuff
2457 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2459 } elsif ( length($password) < 13 ) { #plaintext
2460 $check_password eq $password;
2461 } elsif ( length($password) == 13 ) { #traditional DES crypt
2462 crypt($check_password, $password) eq $password;
2463 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2464 unix_md5_crypt($check_password, $password) eq $password;
2465 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2466 warn "Can't check password: Blowfish encryption not yet supported, ".
2467 "svcnum ". $self->svcnum. "\n";
2470 warn "Can't check password: Unrecognized encryption for svcnum ".
2471 $self->svcnum. "\n";
2479 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2481 Returns an encrypted password, either by passing through an encrypted password
2482 in the database or by encrypting a plaintext password from the database.
2484 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2485 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2486 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2487 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2488 encryption type is only used if the password is not already encrypted in the
2493 sub crypt_password {
2496 if ( $self->_password_encoding eq 'ldap' ) {
2498 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2501 #XXX this could be replaced with Authen::Passphrase stuff
2503 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2504 if ( $encryption eq 'crypt' ) {
2507 $saltset[int(rand(64))].$saltset[int(rand(64))]
2509 } elsif ( $encryption eq 'md5' ) {
2510 unix_md5_crypt( $self->_password );
2511 } elsif ( $encryption eq 'blowfish' ) {
2512 croak "unknown encryption method $encryption";
2514 croak "unknown encryption method $encryption";
2517 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2521 } elsif ( $self->_password_encoding eq 'crypt' ) {
2523 return $self->_password;
2525 } elsif ( $self->_password_encoding eq 'plain' ) {
2527 #XXX this could be replaced with Authen::Passphrase stuff
2529 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2530 if ( $encryption eq 'crypt' ) {
2533 $saltset[int(rand(64))].$saltset[int(rand(64))]
2535 } elsif ( $encryption eq 'md5' ) {
2536 unix_md5_crypt( $self->_password );
2537 } elsif ( $encryption eq 'blowfish' ) {
2538 croak "unknown encryption method $encryption";
2540 croak "unknown encryption method $encryption";
2545 if ( length($self->_password) == 13
2546 || $self->_password =~ /^\$(1|2a?)\$/
2547 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2553 #XXX this could be replaced with Authen::Passphrase stuff
2555 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2556 if ( $encryption eq 'crypt' ) {
2559 $saltset[int(rand(64))].$saltset[int(rand(64))]
2561 } elsif ( $encryption eq 'md5' ) {
2562 unix_md5_crypt( $self->_password );
2563 } elsif ( $encryption eq 'blowfish' ) {
2564 croak "unknown encryption method $encryption";
2566 croak "unknown encryption method $encryption";
2575 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2577 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2578 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2579 "{MD5}5426824942db4253f87a1009fd5d2d4".
2581 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2582 to work the same as the B</crypt_password> method.
2588 #eventually should check a "password-encoding" field
2590 if ( $self->_password_encoding eq 'ldap' ) {
2592 return $self->_password;
2594 } elsif ( $self->_password_encoding eq 'crypt' ) {
2596 if ( length($self->_password) == 13 ) { #crypt
2597 return '{CRYPT}'. $self->_password;
2598 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2600 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2601 # die "Blowfish encryption not supported in this context, svcnum ".
2602 # $self->svcnum. "\n";
2604 warn "encryption method not (yet?) supported in LDAP context";
2605 return '{CRYPT}*'; #unsupported, should not auth
2608 } elsif ( $self->_password_encoding eq 'plain' ) {
2610 return '{PLAIN}'. $self->_password;
2612 #return '{CLEARTEXT}'. $self->_password; #?
2616 if ( length($self->_password) == 13 ) { #crypt
2617 return '{CRYPT}'. $self->_password;
2618 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2620 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2621 warn "Blowfish encryption not supported in this context, svcnum ".
2622 $self->svcnum. "\n";
2625 #are these two necessary anymore?
2626 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2627 return '{SSHA}'. $1;
2628 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2629 return '{NS-MTA-MD5}'. $1;
2632 return '{PLAIN}'. $self->_password;
2634 #return '{CLEARTEXT}'. $self->_password; #?
2636 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2637 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2638 #if ( $encryption eq 'crypt' ) {
2639 # return '{CRYPT}'. crypt(
2641 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2643 #} elsif ( $encryption eq 'md5' ) {
2644 # unix_md5_crypt( $self->_password );
2645 #} elsif ( $encryption eq 'blowfish' ) {
2646 # croak "unknown encryption method $encryption";
2648 # croak "unknown encryption method $encryption";
2656 =item domain_slash_username
2658 Returns $domain/$username/
2662 sub domain_slash_username {
2664 $self->domain. '/'. $self->username. '/';
2667 =item virtual_maildir
2669 Returns $domain/maildirs/$username/
2673 sub virtual_maildir {
2675 $self->domain. '/maildirs/'. $self->username. '/';
2680 =head1 CLASS METHODS
2684 =item search HASHREF
2686 Class method which returns a qsearch hash expression to search for parameters
2687 specified in HASHREF. Valid parameters are
2701 Arrayref of pkgparts
2707 Arrayref of additional WHERE clauses, will be ANDed together.
2718 my ($class, $params) = @_;
2723 if ( $params->{'domain'} ) {
2724 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2725 #preserve previous behavior & bubble up an error if $svc_domain not found?
2726 push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2730 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2731 push @where, "domsvc = $1";
2735 push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2738 if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2739 push @where, "agentnum = $1";
2743 if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2744 push @where, "custnum = $1";
2748 if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2749 #XXX untaint or sql quote
2751 'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2755 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2756 push @where, "popnum = $1";
2760 if ( $params->{'svcpart'} =~ /^(\d+)$/ ) {
2761 push @where, "svcpart = $1";
2765 # here is the agent virtualization
2766 #if ($params->{CurrentUser}) {
2768 # qsearchs('access_user', { username => $params->{CurrentUser} });
2770 # if ($access_user) {
2771 # push @where, $access_user->agentnums_sql('table'=>'cust_main');
2773 # push @where, "1=0";
2776 push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2777 'table' => 'cust_main',
2778 'null_right' => 'View/link unlinked services',
2782 push @where, @{ $params->{'where'} } if $params->{'where'};
2784 my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2786 my $addl_from = ' LEFT JOIN cust_svc USING ( svcnum ) '.
2787 ' LEFT JOIN part_svc USING ( svcpart ) '.
2788 ' LEFT JOIN cust_pkg USING ( pkgnum ) '.
2789 ' LEFT JOIN cust_main USING ( custnum ) ';
2791 my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2792 #if ( keys %svc_acct ) {
2793 # $count_query .= ' WHERE '.
2794 # join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2800 'table' => 'svc_acct',
2801 'hashref' => {}, # \%svc_acct,
2802 'select' => join(', ',
2805 'cust_main.custnum',
2806 FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2808 'addl_from' => $addl_from,
2809 'extra_sql' => $extra_sql,
2810 'order_by' => $params->{'order_by'},
2811 'count_query' => $count_query,
2824 This is the FS::svc_acct job-queue-able version. It still uses
2825 FS::Misc::send_email under-the-hood.
2832 eval "use FS::Misc qw(send_email)";
2835 $opt{mimetype} ||= 'text/plain';
2836 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2838 my $error = send_email(
2839 'from' => $opt{from},
2841 'subject' => $opt{subject},
2842 'content-type' => $opt{mimetype},
2843 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2845 die $error if $error;
2848 =item check_and_rebuild_fuzzyfiles
2852 sub check_and_rebuild_fuzzyfiles {
2853 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2854 -e "$dir/svc_acct.username"
2855 or &rebuild_fuzzyfiles;
2858 =item rebuild_fuzzyfiles
2862 sub rebuild_fuzzyfiles {
2864 use Fcntl qw(:flock);
2866 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2870 open(USERNAMELOCK,">>$dir/svc_acct.username")
2871 or die "can't open $dir/svc_acct.username: $!";
2872 flock(USERNAMELOCK,LOCK_EX)
2873 or die "can't lock $dir/svc_acct.username: $!";
2875 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2877 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2878 or die "can't open $dir/svc_acct.username.tmp: $!";
2879 print USERNAMECACHE join("\n", @all_username), "\n";
2880 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2882 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2892 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2893 open(USERNAMECACHE,"<$dir/svc_acct.username")
2894 or die "can't open $dir/svc_acct.username: $!";
2895 my @array = map { chomp; $_; } <USERNAMECACHE>;
2896 close USERNAMECACHE;
2900 =item append_fuzzyfiles USERNAME
2904 sub append_fuzzyfiles {
2905 my $username = shift;
2907 &check_and_rebuild_fuzzyfiles;
2909 use Fcntl qw(:flock);
2911 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2913 open(USERNAME,">>$dir/svc_acct.username")
2914 or die "can't open $dir/svc_acct.username: $!";
2915 flock(USERNAME,LOCK_EX)
2916 or die "can't lock $dir/svc_acct.username: $!";
2918 print USERNAME "$username\n";
2920 flock(USERNAME,LOCK_UN)
2921 or die "can't unlock $dir/svc_acct.username: $!";
2929 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2933 sub radius_usergroup_selector {
2934 my $sel_groups = shift;
2935 my %sel_groups = map { $_=>1 } @$sel_groups;
2937 my $selectname = shift || 'radius_usergroup';
2940 my $sth = $dbh->prepare(
2941 'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2942 ) or die $dbh->errstr;
2943 $sth->execute() or die $sth->errstr;
2944 my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2948 function ${selectname}_doadd(object) {
2949 var myvalue = object.${selectname}_add.value;
2950 var optionName = new Option(myvalue,myvalue,false,true);
2951 var length = object.$selectname.length;
2952 object.$selectname.options[length] = optionName;
2953 object.${selectname}_add.value = "";
2956 <SELECT MULTIPLE NAME="$selectname">
2959 foreach my $group ( @all_groups ) {
2960 $html .= qq(<OPTION VALUE="$group");
2961 if ( $sel_groups{$group} ) {
2962 $html .= ' SELECTED';
2963 $sel_groups{$group} = 0;
2965 $html .= ">$group</OPTION>\n";
2967 foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2968 $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2970 $html .= '</SELECT>';
2972 $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2973 qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2978 =item reached_threshold
2980 Performs some activities when svc_acct thresholds (such as number of seconds
2981 remaining) are reached.
2985 sub reached_threshold {
2988 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2989 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2991 if ( $opt{'op'} eq '+' ){
2992 $svc_acct->setfield( $opt{'column'}.'_threshold',
2993 int($svc_acct->getfield($opt{'column'})
2994 * ( $conf->exists('svc_acct-usage_threshold')
2995 ? $conf->config('svc_acct-usage_threshold')/100
3000 my $error = $svc_acct->replace;
3001 die $error if $error;
3002 }elsif ( $opt{'op'} eq '-' ){
3004 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3005 return '' if ($threshold eq '' );
3007 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3008 my $error = $svc_acct->replace;
3009 die $error if $error; # email next time, i guess
3011 if ( $warning_template ) {
3012 eval "use FS::Misc qw(send_email)";
3015 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
3016 my $cust_main = $cust_pkg->cust_main;
3018 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3019 $cust_main->invoicing_list,
3020 ($opt{'to'} ? $opt{'to'} : ())
3023 my $mimetype = $warning_mimetype;
3024 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3026 my $body = $warning_template->fill_in( HASH => {
3027 'custnum' => $cust_main->custnum,
3028 'username' => $svc_acct->username,
3029 'password' => $svc_acct->_password,
3030 'first' => $cust_main->first,
3031 'last' => $cust_main->getfield('last'),
3032 'pkg' => $cust_pkg->part_pkg->pkg,
3033 'column' => $opt{'column'},
3034 'amount' => $opt{'column'} =~/bytes/
3035 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3036 : $svc_acct->getfield($opt{'column'}),
3037 'threshold' => $opt{'column'} =~/bytes/
3038 ? FS::UI::bytecount::display_bytecount($threshold)
3043 my $error = send_email(
3044 'from' => $warning_from,
3046 'subject' => $warning_subject,
3047 'content-type' => $mimetype,
3048 'body' => [ map "$_\n", split("\n", $body) ],
3050 die $error if $error;
3053 die "unknown op: " . $opt{'op'};
3061 The $recref stuff in sub check should be cleaned up.
3063 The suspend, unsuspend and cancel methods update the database, but not the
3064 current object. This is probably a bug as it's unexpected and
3067 radius_usergroup_selector? putting web ui components in here? they should
3068 probably live somewhere else...
3070 insertion of RADIUS group stuff in insert could be done with child_objects now
3071 (would probably clean up export of them too)
3073 _op_usage and set_usage bypass the history... maybe they shouldn't
3077 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3078 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3079 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3080 L<freeside-queued>), L<FS::svc_acct_pop>,
3081 schema.html from the base documentation.
3085 =item domain_select_hash %OPTIONS
3087 Returns a hash SVCNUM => DOMAIN ... representing the domains this customer
3088 may at present purchase.
3090 Currently available options are: I<pkgnum> I<svcpart>
3094 sub domain_select_hash {
3095 my ($self, %options) = @_;
3101 $part_svc = $self->part_svc;
3102 $cust_pkg = $self->cust_svc->cust_pkg
3106 $part_svc = qsearchs('part_svc', { 'svcpart' => $options{svcpart} })
3107 if $options{'svcpart'};
3109 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $options{pkgnum} })
3110 if $options{'pkgnum'};
3112 if ($part_svc && ( $part_svc->part_svc_column('domsvc')->columnflag eq 'S'
3113 || $part_svc->part_svc_column('domsvc')->columnflag eq 'F')) {
3114 %domains = map { $_->svcnum => $_->domain }
3115 map { qsearchs('svc_domain', { 'svcnum' => $_ }) }
3116 split(',', $part_svc->part_svc_column('domsvc')->columnvalue);
3117 }elsif ($cust_pkg && !$conf->exists('svc_acct-alldomains') ) {
3118 %domains = map { $_->svcnum => $_->domain }
3119 map { qsearchs('svc_domain', { 'svcnum' => $_->svcnum }) }
3120 map { qsearch('cust_svc', { 'pkgnum' => $_->pkgnum } ) }
3121 qsearch('cust_pkg', { 'custnum' => $cust_pkg->custnum });
3123 %domains = map { $_->svcnum => $_->domain } qsearch('svc_domain', {} );
3126 if ($part_svc && $part_svc->part_svc_column('domsvc')->columnflag eq 'D') {
3127 my $svc_domain = qsearchs('svc_domain',
3128 { 'svcnum' => $part_svc->part_svc_column('domsvc')->columnvalue } );
3129 if ( $svc_domain ) {
3130 $domains{$svc_domain->svcnum} = $svc_domain->domain;
3132 warn "unknown svc_domain.svcnum for part_svc_column domsvc: ".
3133 $part_svc->part_svc_column('domsvc')->columnvalue;