4 use base qw( FS::svc_Domain_Mixin
15 use vars qw( $DEBUG $me $conf $skip_fuzzyfiles
16 $dir_prefix @shells $usernamemin
17 $usernamemax $passwordmin $passwordmax
18 $username_ampersand $username_letter $username_letterfirst
19 $username_noperiod $username_nounderscore $username_nodash
20 $username_uppercase $username_percent $username_colon
21 $username_slash $username_equals $username_pound
23 $password_noampersand $password_noexclamation
24 $warning_template $warning_from $warning_subject $warning_mimetype
27 $radius_password $radius_ip
30 use Scalar::Util qw( blessed );
35 use Crypt::PasswdMD5 1.2;
36 use Digest::SHA 'sha1_base64';
37 use Digest::MD5 'md5_base64';
40 use Authen::Passphrase;
41 use FS::UID qw( datasrc driver_name );
43 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
44 use FS::Msgcat qw(gettext);
45 use FS::UI::bytecount;
47 use FS::PagedSearch qw( psearch ); # XXX in v4, replace with FS::Cursor
51 use FS::cust_main_invoice;
56 use FS::radius_usergroup;
67 $me = '[FS::svc_acct]';
69 #ask FS::UID to run this stuff for us later
70 FS::UID->install_callback( sub {
72 $dir_prefix = $conf->config('home');
73 @shells = $conf->config('shells');
74 $usernamemin = $conf->config('usernamemin') || 2;
75 $usernamemax = $conf->config('usernamemax');
76 $passwordmin = $conf->config('passwordmin'); # || 6;
78 $passwordmin = ( defined($passwordmin) && $passwordmin =~ /\d+/ )
81 $passwordmax = $conf->config('passwordmax') || 8;
82 $username_letter = $conf->exists('username-letter');
83 $username_letterfirst = $conf->exists('username-letterfirst');
84 $username_noperiod = $conf->exists('username-noperiod');
85 $username_nounderscore = $conf->exists('username-nounderscore');
86 $username_nodash = $conf->exists('username-nodash');
87 $username_uppercase = $conf->exists('username-uppercase');
88 $username_ampersand = $conf->exists('username-ampersand');
89 $username_percent = $conf->exists('username-percent');
90 $username_colon = $conf->exists('username-colon');
91 $username_slash = $conf->exists('username-slash');
92 $username_equals = $conf->exists('username-equals');
93 $username_pound = $conf->exists('username-pound');
94 $username_exclamation = $conf->exists('username-exclamation');
95 $password_noampersand = $conf->exists('password-noexclamation');
96 $password_noexclamation = $conf->exists('password-noexclamation');
97 $dirhash = $conf->config('dirhash') || 0;
98 if ( $conf->exists('warning_email') ) {
99 $warning_template = new Text::Template (
101 SOURCE => [ map "$_\n", $conf->config('warning_email') ]
102 ) or warn "can't create warning email template: $Text::Template::ERROR";
103 $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
104 $warning_subject = $conf->config('warning_email-subject') || 'Warning';
105 $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
106 $warning_cc = $conf->config('warning_email-cc');
108 $warning_template = '';
110 $warning_subject = '';
111 $warning_mimetype = '';
114 $smtpmachine = $conf->config('smtpmachine');
115 $radius_password = $conf->config('radius-password') || 'Password';
116 $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
117 @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
121 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
122 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '.', ',' );
126 my ( $hashref, $cache ) = @_;
127 if ( $hashref->{'svc_acct_svcnum'} ) {
128 $self->{'_domsvc'} = FS::svc_domain->new( {
129 'svcnum' => $hashref->{'domsvc'},
130 'domain' => $hashref->{'svc_acct_domain'},
131 'catchall' => $hashref->{'svc_acct_catchall'},
138 FS::svc_acct - Object methods for svc_acct records
144 $record = new FS::svc_acct \%hash;
145 $record = new FS::svc_acct { 'column' => 'value' };
147 $error = $record->insert;
149 $error = $new_record->replace($old_record);
151 $error = $record->delete;
153 $error = $record->check;
155 $error = $record->suspend;
157 $error = $record->unsuspend;
159 $error = $record->cancel;
161 %hash = $record->radius;
163 %hash = $record->radius_reply;
165 %hash = $record->radius_check;
167 $domain = $record->domain;
169 $svc_domain = $record->svc_domain;
171 $email = $record->email;
173 $seconds_since = $record->seconds_since($timestamp);
177 An FS::svc_acct object represents an account. FS::svc_acct inherits from
178 FS::svc_Common. The following fields are currently supported:
184 Primary key (assigned automatcially for new accounts)
192 =item _password_encoding
194 plain, crypt, ldap (or empty for autodetection)
202 Point of presence (see L<FS::svc_acct_pop>)
214 set automatically if blank (and uid is not)
234 svcnum from svc_domain
238 Optional svcnum from svc_pbx
240 =item radius_I<Radius_Attribute>
242 I<Radius-Attribute> (reply)
244 =item rc_I<Radius_Attribute>
246 I<Radius-Attribute> (check)
256 Creates a new account. To add the account to the database, see L<"insert">.
263 'longname_plural' => 'Access accounts and mailboxes',
264 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
265 'display_weight' => 10,
266 'cancel_weight' => 50,
267 'ip_field' => 'slipip',
268 'manual_require' => 1,
270 'dir' => 'Home directory',
273 def_info => 'set to fixed and blank for no UIDs',
276 'slipip' => 'IP address',
277 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
279 label => 'Access number',
281 select_table => 'svc_acct_pop',
282 select_key => 'popnum',
283 select_label => 'city',
289 disable_default => 1,
294 'password_selfchange' => { label => 'Password modification',
297 'password_recover' => { label => 'Password recovery',
301 label => 'Quota', #Mail storage limit
303 disable_inventory => 1,
306 label => 'File storage limit',
308 disable_inventory => 1,
311 label => 'Number of files limit',
313 disable_inventory => 1,
316 label => 'File size limit',
318 disable_inventory => 1,
320 '_password' => { label => 'Password',
325 def_info => 'when blank, defaults to UID',
330 def_info => 'set to blank for no shell tracking',
332 #select_list => [ $conf->config('shells') ],
333 select_list => [ $conf ? $conf->config('shells') : () ],
334 disable_inventory => 1,
337 'finger' => 'Real name', # (GECOS)',
341 select_table => 'svc_domain',
342 select_key => 'svcnum',
343 select_label => 'domain',
344 disable_inventory => 1,
347 'pbxsvc' => { label => 'PBX',
348 type => 'select-svc_pbx.html',
349 disable_inventory => 1,
350 disable_select => 1, #UI wonky, pry works otherwise
352 'sectornum' => 'Tower sector',
354 label => 'RADIUS groups',
355 type => 'select-radius_group.html',
356 disable_inventory => 1,
360 'seconds' => { label => 'Seconds',
361 label_sort => 'with Time Remaining',
363 disable_inventory => 1,
365 disable_part_svc_column => 1,
367 'upbytes' => { label => 'Upload',
369 disable_inventory => 1,
371 'format' => \&FS::UI::bytecount::display_bytecount,
372 'parse' => \&FS::UI::bytecount::parse_bytecount,
373 disable_part_svc_column => 1,
375 'downbytes' => { label => 'Download',
377 disable_inventory => 1,
379 'format' => \&FS::UI::bytecount::display_bytecount,
380 'parse' => \&FS::UI::bytecount::parse_bytecount,
381 disable_part_svc_column => 1,
383 'totalbytes'=> { label => 'Total up and download',
385 disable_inventory => 1,
387 'format' => \&FS::UI::bytecount::display_bytecount,
388 'parse' => \&FS::UI::bytecount::parse_bytecount,
389 disable_part_svc_column => 1,
391 'seconds_threshold' => { label => 'Seconds threshold',
393 disable_inventory => 1,
395 disable_part_svc_column => 1,
397 'upbytes_threshold' => { label => 'Upload threshold',
399 disable_inventory => 1,
401 'format' => \&FS::UI::bytecount::display_bytecount,
402 'parse' => \&FS::UI::bytecount::parse_bytecount,
403 disable_part_svc_column => 1,
405 'downbytes_threshold' => { label => 'Download threshold',
407 disable_inventory => 1,
409 'format' => \&FS::UI::bytecount::display_bytecount,
410 'parse' => \&FS::UI::bytecount::parse_bytecount,
411 disable_part_svc_column => 1,
413 'totalbytes_threshold'=> { label => 'Total up and download threshold',
415 disable_inventory => 1,
417 'format' => \&FS::UI::bytecount::display_bytecount,
418 'parse' => \&FS::UI::bytecount::parse_bytecount,
419 disable_part_svc_column => 1,
422 label => 'Last login',
426 label => 'Last logout',
431 label => 'Communigate aliases',
433 disable_inventory => 1,
438 label => 'Communigate account type',
440 select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
441 disable_inventory => 1,
444 'cgp_accessmodes' => {
445 label => 'Communigate enabled services',
446 type => 'communigate_pro-accessmodes',
447 disable_inventory => 1,
450 'cgp_rulesallowed' => {
451 label => 'Allowed mail rules',
453 select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
454 disable_inventory => 1,
457 'cgp_rpopallowed' => { label => 'RPOP modifications',
460 'cgp_mailtoall' => { label => 'Accepts mail to "all"',
463 'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
466 'cgp_archiveafter' => {
467 label => 'Archive messages after',
470 -2 => 'default(730 days)',
477 1209600 => '2 weeks',
478 2592000 => '30 days',
479 7776000 => '90 days',
480 15552000 => '180 days',
481 31536000 => '365 days',
482 63072000 => '730 days',
484 disable_inventory => 1,
490 'cgp_deletemode' => {
491 label => 'Communigate message delete method',
493 select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
494 disable_inventory => 1,
497 'cgp_emptytrash' => {
498 label => 'Communigate on logout remove trash',
500 select_list => __PACKAGE__->cgp_emptytrash_values,
501 disable_inventory => 1,
505 label => 'Communigate language',
507 select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
508 disable_inventory => 1,
512 label => 'Communigate time zone',
514 select_list => __PACKAGE__->cgp_timezone_values,
515 disable_inventory => 1,
519 label => 'Communigate layout',
521 select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
522 disable_inventory => 1,
525 'cgp_prontoskinname' => {
526 label => 'Communigate Pronto style',
528 select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ],
529 disable_inventory => 1,
532 'cgp_sendmdnmode' => {
533 label => 'Communigate send read receipts',
535 select_list => [ '', 'Never', 'Manually', 'Automatically' ],
536 disable_inventory => 1,
547 sub table { 'svc_acct'; }
549 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
552 shift->_lastlog('in', @_);
556 shift->_lastlog('out', @_);
560 my( $self, $op, $time ) = @_;
562 if ( defined($time) ) {
563 warn "$me last_log$op called on svcnum ". $self->svcnum.
564 ' ('. $self->email. "): $time\n"
569 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
573 my $sth = $dbh->prepare( $sql )
574 or die "Error preparing $sql: ". $dbh->errstr;
575 my $rv = $sth->execute($time, $self->svcnum);
576 die "Error executing $sql: ". $sth->errstr
578 die "Can't update last_log$op for svcnum". $self->svcnum
581 $self->{'Hash'}->{"last_log$op"} = $time;
583 $self->getfield("last_log$op");
587 =item search_sql STRING
589 Class method which returns an SQL fragment to search for the given string.
594 my( $class, $string ) = @_;
595 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
596 my( $username, $domain ) = ( $1, $2 );
597 my $q_username = dbh->quote($username);
598 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
600 "svc_acct.username = $q_username AND ( ".
601 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
606 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
608 $class->search_sql_field('slipip', $string ).
610 $class->search_sql_field('username', $string ).
613 $class->search_sql_field('username', $string);
617 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
619 Returns the "username@domain" string for this account.
621 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
631 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
633 Returns a longer string label for this acccount ("Real Name <username@domain>"
634 if available, or "username@domain").
636 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
643 my $label = $self->label(@_);
644 my $finger = $self->finger;
645 return $label unless $finger =~ /\S/;
646 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
647 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
651 =item insert [ , OPTION => VALUE ... ]
653 Adds this account to the database. If there is an error, returns the error,
654 otherwise returns false.
656 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
657 defined. An FS::cust_svc record will be created and inserted.
659 The additional field I<usergroup> can optionally be defined; if so it should
660 contain an arrayref of group names. See L<FS::radius_usergroup>.
662 The additional field I<child_objects> can optionally be defined; if so it
663 should contain an arrayref of FS::tablename objects. They will have their
664 svcnum fields set and will be inserted after this record, but before any
665 exports are run. Each element of the array can also optionally be a
666 two-element array reference containing the child object and the name of an
667 alternate field to be filled in with the newly-inserted svcnum, for example
668 C<[ $svc_forward, 'srcsvc' ]>
670 Currently available options are: I<depend_jobnum>
672 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
673 jobnums), all provisioning jobs will have a dependancy on the supplied
674 jobnum(s) (they will not run until the specific job(s) complete(s)).
676 (TODOC: L<FS::queue> and L<freeside-queued>)
678 (TODOC: new exports!)
687 warn "[$me] insert called on $self: ". Dumper($self).
688 "\nwith options: ". Dumper(%options);
691 local $SIG{HUP} = 'IGNORE';
692 local $SIG{INT} = 'IGNORE';
693 local $SIG{QUIT} = 'IGNORE';
694 local $SIG{TERM} = 'IGNORE';
695 local $SIG{TSTP} = 'IGNORE';
696 local $SIG{PIPE} = 'IGNORE';
698 my $oldAutoCommit = $FS::UID::AutoCommit;
699 local $FS::UID::AutoCommit = 0;
703 my $error = $self->SUPER::insert( # usergroup is here
704 'jobnums' => \@jobnums,
705 'child_objects' => $self->child_objects,
709 $error ||= $self->insert_password_history;
712 $dbh->rollback if $oldAutoCommit;
716 unless ( $skip_fuzzyfiles ) {
717 $error = $self->queue_fuzzyfiles_update;
719 $dbh->rollback if $oldAutoCommit;
720 return "updating fuzzy search cache: $error";
724 my $cust_pkg = $self->cust_svc->cust_pkg;
727 my $cust_main = $cust_pkg->cust_main;
728 my $agentnum = $cust_main->agentnum;
730 if ( $conf->exists('emailinvoiceautoalways')
731 || $conf->exists('emailinvoiceauto')
732 && ! $cust_main->invoicing_list_emailonly
734 my @invoicing_list = $cust_main->invoicing_list;
735 push @invoicing_list, $self->email;
736 $cust_main->invoicing_list(\@invoicing_list);
740 my @welcome_exclude_svcparts = $conf->config('svc_acct_welcome_exclude');
741 unless ( grep { $_ eq $self->svcpart } @welcome_exclude_svcparts ) {
743 my $msgnum = $conf->config('welcome_msgnum', $agentnum);
745 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
746 $error = $msg_template->send('cust_main' => $cust_main,
750 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
751 = ('','','','','','');
753 if ( $conf->exists('welcome_email', $agentnum) ) {
754 $welcome_template = new Text::Template (
756 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
757 ) or warn "can't create welcome email template: $Text::Template::ERROR";
758 $welcome_from = $conf->config('welcome_email-from', $agentnum);
759 # || 'your-isp-is-dum'
760 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
762 $welcome_subject_template = new Text::Template (
764 SOURCE => $welcome_subject,
765 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
766 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
769 if ( $welcome_template ) {
770 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
774 'custnum' => $self->custnum,
775 'username' => $self->username,
776 'password' => $self->_password,
777 'first' => $cust_main->first,
778 'last' => $cust_main->getfield('last'),
779 'pkg' => $cust_pkg->part_pkg->pkg,
781 my $wqueue = new FS::queue {
782 'svcnum' => $self->svcnum,
783 'job' => 'FS::svc_acct::send_email'
785 my $error = $wqueue->insert(
787 'from' => $welcome_from,
788 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
789 'mimetype' => $welcome_mimetype,
790 'body' => $welcome_template->fill_in( HASH => \%hash, ),
793 $dbh->rollback if $oldAutoCommit;
794 return "error queuing welcome email: $error";
797 if ( $options{'depend_jobnum'} ) {
798 warn "$me depend_jobnum found; adding to welcome email dependancies"
800 if ( ref($options{'depend_jobnum'}) ) {
801 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
802 "to welcome email dependancies"
804 push @jobnums, @{ $options{'depend_jobnum'} };
806 warn "$me adding job $options{'depend_jobnum'} ".
807 "to welcome email dependancies"
809 push @jobnums, $options{'depend_jobnum'};
813 foreach my $jobnum ( @jobnums ) {
814 my $error = $wqueue->depend_insert($jobnum);
816 $dbh->rollback if $oldAutoCommit;
817 return "error queuing welcome email job dependancy: $error";
823 } # if $welcome_template
828 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
832 # set usage fields and thresholds if unset but set in a package def
833 # AND the package already has a last bill date (otherwise they get double added)
834 sub preinsert_hook_first {
837 return '' unless $self->pkgnum;
839 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
840 return '' unless $cust_pkg && $cust_pkg->last_bill;
842 my $part_pkg = $cust_pkg->part_pkg;
843 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
845 my %values = $part_pkg->usage_valuehash;
846 my $multiplier = $conf->exists('svc_acct-usage_threshold')
847 ? 1 - $conf->config('svc_acct-usage_threshold')/100
848 : 0.20; #doesn't matter
850 foreach ( keys %values ) {
851 next if $self->getfield($_);
852 $self->setfield( $_, $values{$_} );
853 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
854 if $conf->exists('svc_acct-usage_threshold');
862 Deletes this account from the database. If there is an error, returns the
863 error, otherwise returns false.
865 The corresponding FS::cust_svc record will be deleted as well.
867 (TODOC: new exports!)
874 return "can't delete system account" if $self->_check_system;
876 return "Can't delete an account which is a (svc_forward) source!"
877 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
879 return "Can't delete an account which is a (svc_forward) destination!"
880 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
882 return "Can't delete an account with (svc_www) web service!"
883 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
885 # what about records in session ? (they should refer to history table)
887 local $SIG{HUP} = 'IGNORE';
888 local $SIG{INT} = 'IGNORE';
889 local $SIG{QUIT} = 'IGNORE';
890 local $SIG{TERM} = 'IGNORE';
891 local $SIG{TSTP} = 'IGNORE';
892 local $SIG{PIPE} = 'IGNORE';
894 my $oldAutoCommit = $FS::UID::AutoCommit;
895 local $FS::UID::AutoCommit = 0;
898 foreach my $cust_main_invoice (
899 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
901 unless ( defined($cust_main_invoice) ) {
902 warn "WARNING: something's wrong with qsearch";
905 my %hash = $cust_main_invoice->hash;
906 $hash{'dest'} = $self->email;
907 my $new = new FS::cust_main_invoice \%hash;
908 my $error = $new->replace($cust_main_invoice);
910 $dbh->rollback if $oldAutoCommit;
915 foreach my $svc_domain (
916 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
918 my %hash = new FS::svc_domain->hash;
919 $hash{'catchall'} = '';
920 my $new = new FS::svc_domain \%hash;
921 my $error = $new->replace($svc_domain);
923 $dbh->rollback if $oldAutoCommit;
928 my $error = $self->SUPER::delete; # usergroup here
930 $dbh->rollback if $oldAutoCommit;
934 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
938 =item replace OLD_RECORD
940 Replaces OLD_RECORD with this one in the database. If there is an error,
941 returns the error, otherwise returns false.
943 The additional field I<usergroup> can optionally be defined; if so it should
944 contain an arrayref of group names. See L<FS::radius_usergroup>.
952 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
956 warn "$me replacing $old with $new\n" if $DEBUG;
960 return "can't modify system account" if $old->_check_system;
963 #no warnings 'numeric'; #alas, a 5.006-ism
966 foreach my $xid (qw( uid gid )) {
968 return "Can't change $xid!"
969 if ! $conf->exists("svc_acct-edit_$xid")
970 && $old->$xid() != $new->$xid()
971 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
976 return "can't change username"
977 if $old->username ne $new->username
978 && $conf->exists('svc_acct-no_edit_username');
980 #change homdir when we change username
981 $new->setfield('dir', '') if $old->username ne $new->username;
983 local $SIG{HUP} = 'IGNORE';
984 local $SIG{INT} = 'IGNORE';
985 local $SIG{QUIT} = 'IGNORE';
986 local $SIG{TERM} = 'IGNORE';
987 local $SIG{TSTP} = 'IGNORE';
988 local $SIG{PIPE} = 'IGNORE';
990 my $oldAutoCommit = $FS::UID::AutoCommit;
991 local $FS::UID::AutoCommit = 0;
994 $error = $new->SUPER::replace($old, @_); # usergroup here
996 # don't need to record this unless the password was changed
997 if ( $old->_password ne $new->_password ) {
998 $error ||= $new->insert_password_history;
1002 $dbh->rollback if $oldAutoCommit;
1003 return $error if $error;
1006 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1007 $error = $new->queue_fuzzyfiles_update;
1009 $dbh->rollback if $oldAutoCommit;
1010 return "updating fuzzy search cache: $error";
1014 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1018 =item queue_fuzzyfiles_update
1020 Used by insert & replace to update the fuzzy search cache
1024 sub queue_fuzzyfiles_update {
1027 local $SIG{HUP} = 'IGNORE';
1028 local $SIG{INT} = 'IGNORE';
1029 local $SIG{QUIT} = 'IGNORE';
1030 local $SIG{TERM} = 'IGNORE';
1031 local $SIG{TSTP} = 'IGNORE';
1032 local $SIG{PIPE} = 'IGNORE';
1034 my $oldAutoCommit = $FS::UID::AutoCommit;
1035 local $FS::UID::AutoCommit = 0;
1038 my $queue = new FS::queue {
1039 'svcnum' => $self->svcnum,
1040 'job' => 'FS::svc_acct::append_fuzzyfiles'
1042 my $error = $queue->insert($self->username);
1044 $dbh->rollback if $oldAutoCommit;
1045 return "queueing job (transaction rolled back): $error";
1048 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1056 Suspends this account by calling export-specific suspend hooks. If there is
1057 an error, returns the error, otherwise returns false.
1059 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1065 return "can't suspend system account" if $self->_check_system;
1066 $self->SUPER::suspend(@_);
1071 Unsuspends this account by by calling export-specific suspend hooks. If there
1072 is an error, returns the error, otherwise returns false.
1074 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1080 my %hash = $self->hash;
1081 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1082 $hash{_password} = $1;
1083 my $new = new FS::svc_acct ( \%hash );
1084 my $error = $new->replace($self);
1085 return $error if $error;
1088 $self->SUPER::unsuspend(@_);
1093 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1095 If the B<auto_unset_catchall> configuration option is set, this method will
1096 automatically remove any references to the canceled service in the catchall
1097 field of svc_domain. This allows packages that contain both a svc_domain and
1098 its catchall svc_acct to be canceled in one step.
1103 # Only one thing to do at this level
1105 foreach my $svc_domain (
1106 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1107 if($conf->exists('auto_unset_catchall')) {
1108 my %hash = $svc_domain->hash;
1109 $hash{catchall} = '';
1110 my $new = new FS::svc_domain ( \%hash );
1111 my $error = $new->replace($svc_domain);
1112 return $error if $error;
1114 return "cannot unprovision svc_acct #".$self->svcnum.
1115 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1119 $self->SUPER::cancel(@_);
1125 Checks all fields to make sure this is a valid service. If there is an error,
1126 returns the error, otherwise returns false. Called by the insert and replace
1129 Sets any fixed values; see L<FS::part_svc>.
1136 my($recref) = $self->hashref;
1138 my $x = $self->setfixed;
1139 return $x unless ref($x);
1142 my $error = $self->ut_numbern('svcnum')
1143 #|| $self->ut_number('domsvc')
1144 || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1145 || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' )
1146 || $self->ut_foreign_keyn('sectornum','tower_sector','sectornum')
1147 || $self->ut_foreign_keyn('routernum','router','routernum')
1148 || $self->ut_foreign_keyn('blocknum','addr_block','blocknum')
1149 || $self->ut_textn('sec_phrase')
1150 || $self->ut_snumbern('seconds')
1151 || $self->ut_snumbern('upbytes')
1152 || $self->ut_snumbern('downbytes')
1153 || $self->ut_snumbern('totalbytes')
1154 || $self->ut_snumbern('seconds_threshold')
1155 || $self->ut_snumbern('upbytes_threshold')
1156 || $self->ut_snumbern('downbytes_threshold')
1157 || $self->ut_snumbern('totalbytes_threshold')
1158 || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1159 || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1160 || $self->ut_enum('password_recover', [ '', 'Y' ])
1162 || $self->ut_anything('cf_privatekey')
1164 || $self->ut_textn('cgp_accessmodes')
1165 || $self->ut_alphan('cgp_type')
1166 || $self->ut_textn('cgp_aliases' ) #well
1168 || $self->ut_alphasn('cgp_rulesallowed')
1169 || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1170 || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1171 || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1172 || $self->ut_snumbern('cgp_archiveafter')
1174 || $self->ut_alphasn('cgp_deletemode')
1175 || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1176 || $self->ut_alphan('cgp_language')
1177 || $self->ut_textn('cgp_timezone')
1178 || $self->ut_textn('cgp_skinname')
1179 || $self->ut_textn('cgp_prontoskinname')
1180 || $self->ut_alphan('cgp_sendmdnmode')
1182 return $error if $error;
1184 # assign IP address, etc.
1185 if ( $conf->exists('svc_acct-ip_addr') ) {
1186 my $error = $self->svc_ip_check;
1187 return $error if $error;
1188 } else { # I think this is correct
1189 $self->routernum('');
1190 $self->blocknum('');
1194 local $username_letter = $username_letter;
1195 local $username_uppercase = $username_uppercase;
1196 if ($self->svcnum) {
1197 my $cust_svc = $self->cust_svc
1198 or return "no cust_svc record found for svcnum ". $self->svcnum;
1199 my $cust_pkg = $cust_svc->cust_pkg;
1201 if ($self->pkgnum) {
1202 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1206 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1207 $username_uppercase =
1208 $conf->exists('username-uppercase', $cust_pkg->cust_main->agentnum);
1211 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1213 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#\!]{$usernamemin,$ulen})$/i
1214 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1215 $recref->{username} = $1;
1217 my $uerror = gettext('illegal_username'). ': '. $recref->{username};
1219 unless ( $username_uppercase ) {
1220 $recref->{username} =~ /[A-Z]/ and return $uerror;
1222 if ( $username_letterfirst ) {
1223 $recref->{username} =~ /^[a-z]/ or return $uerror;
1224 } elsif ( $username_letter ) {
1225 $recref->{username} =~ /[a-z]/ or return $uerror;
1227 if ( $username_noperiod ) {
1228 $recref->{username} =~ /\./ and return $uerror;
1230 if ( $username_nounderscore ) {
1231 $recref->{username} =~ /_/ and return $uerror;
1233 if ( $username_nodash ) {
1234 $recref->{username} =~ /\-/ and return $uerror;
1236 unless ( $username_ampersand ) {
1237 $recref->{username} =~ /\&/ and return $uerror;
1239 unless ( $username_percent ) {
1240 $recref->{username} =~ /\%/ and return $uerror;
1242 unless ( $username_colon ) {
1243 $recref->{username} =~ /\:/ and return $uerror;
1245 unless ( $username_slash ) {
1246 $recref->{username} =~ /\// and return $uerror;
1248 unless ( $username_equals ) {
1249 $recref->{username} =~ /\=/ and return $uerror;
1251 unless ( $username_pound ) {
1252 $recref->{username} =~ /\#/ and return $uerror;
1254 unless ( $username_exclamation ) {
1255 $recref->{username} =~ /\!/ and return $uerror;
1259 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1260 $recref->{popnum} = $1;
1261 return "Unknown popnum" unless
1262 ! $recref->{popnum} ||
1263 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1265 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1267 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1268 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1270 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1271 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1272 #not all systems use gid=uid
1273 #you can set a fixed gid in part_svc
1275 return "Only root can have uid 0"
1276 if $recref->{uid} == 0
1277 && $recref->{username} !~ /^(root|toor|smtp)$/;
1279 unless ( $recref->{username} eq 'sync' ) {
1280 if ( grep $_ eq $recref->{shell}, @shells ) {
1281 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1283 return "Illegal shell \`". $self->shell. "\'; ".
1284 "shells configuration value contains: @shells";
1287 $recref->{shell} = '/bin/sync';
1291 $recref->{gid} ne '' ?
1292 return "Can't have gid without uid" : ( $recref->{gid}='' );
1293 #$recref->{dir} ne '' ?
1294 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1295 $recref->{shell} ne '' ?
1296 return "Can't have shell without uid" : ( $recref->{shell}='' );
1299 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1301 $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1302 or return "Illegal directory: ". $recref->{dir};
1303 $recref->{dir} = $1;
1304 return "Illegal directory"
1305 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1306 return "Illegal directory"
1307 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1308 unless ( $recref->{dir} ) {
1309 $recref->{dir} = $dir_prefix . '/';
1310 if ( $dirhash > 0 ) {
1311 for my $h ( 1 .. $dirhash ) {
1312 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1314 } elsif ( $dirhash < 0 ) {
1315 for my $h ( reverse $dirhash .. -1 ) {
1316 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1319 $recref->{dir} .= $recref->{username};
1325 if ( $self->getfield('finger') eq '' ) {
1326 my $cust_pkg = $self->svcnum
1327 ? $self->cust_svc->cust_pkg
1328 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1330 my $cust_main = $cust_pkg->cust_main;
1331 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1334 # $error = $self->ut_textn('finger');
1335 # return $error if $error;
1336 $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]*)$/
1337 or return "Illegal finger: ". $self->getfield('finger');
1338 $self->setfield('finger', $1);
1340 for (qw( quota file_quota file_maxsize )) {
1341 $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1344 $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1345 $recref->{file_maxnum} = $1;
1347 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1348 if ( $recref->{slipip} eq '' ) {
1349 $recref->{slipip} = ''; # eh?
1350 } elsif ( $recref->{slipip} eq '0e0' ) {
1351 $recref->{slipip} = '0e0';
1353 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1354 or return "Illegal slipip: ". $self->slipip;
1355 $recref->{slipip} = $1;
1359 #arbitrary RADIUS stuff; allow ut_textn for now
1360 foreach ( grep /^radius_/, fields('svc_acct') ) {
1361 $self->ut_textn($_);
1364 # First, if _password is blank, generate one and set default encoding.
1365 if ( ! $recref->{_password} ) {
1366 $error = $self->set_password('');
1368 # But if there's a _password but no encoding, assume it's plaintext and
1369 # set it to default encoding.
1370 elsif ( ! $recref->{_password_encoding} ) {
1371 $error = $self->set_password($recref->{_password});
1373 return $error if $error;
1375 # Next, check _password to ensure compliance with the encoding.
1376 if ( $recref->{_password_encoding} eq 'ldap' ) {
1378 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1379 $recref->{_password} = uc($1).$2;
1381 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1384 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1386 if ( $recref->{_password} =~
1387 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1388 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1391 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1394 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1397 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1398 # Password randomization is now in set_password.
1399 # Strip whitespace characters, check length requirements, etc.
1400 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1401 $recref->{_password} = $1;
1403 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1404 FS::Msgcat::_gettext('illegal_password_characters').
1405 ": ". $recref->{_password};
1408 if ( $password_noampersand ) {
1409 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1411 if ( $password_noexclamation ) {
1412 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1416 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1419 $self->SUPER::check;
1424 sub _password_encryption {
1426 my $encoding = lc($self->_password_encoding);
1427 return if !$encoding;
1428 return 'plain' if $encoding eq 'plain';
1429 if($encoding eq 'crypt') {
1430 my $pass = $self->_password;
1431 $pass =~ s/^\*SUSPENDED\* //;
1433 return 'md5' if $pass =~ /^\$1\$/;
1434 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1435 return 'des' if length($pass) == 13;
1438 if($encoding eq 'ldap') {
1439 uc($self->_password) =~ /^\{([\w-]+)\}/;
1440 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1441 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1442 return 'md5' if $1 eq 'MD5';
1443 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1450 sub get_cleartext_password {
1452 if($self->_password_encryption eq 'plain') {
1453 if($self->_password_encoding eq 'ldap') {
1454 $self->_password =~ /\{\w+\}(.*)$/;
1458 return $self->_password;
1467 Set the cleartext password for the account. If _password_encoding is set, the
1468 new password will be encoded according to the existing method (including
1469 encryption mode, if it can be determined). Otherwise,
1470 config('default-password-encoding') is used.
1472 If no password is supplied (or a zero-length password when minimum password length
1473 is >0), one will be generated randomly.
1478 my( $self, $pass ) = ( shift, shift );
1480 warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1483 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1484 FS::Msgcat::_gettext('illegal_password_characters').
1487 my( $encoding, $encryption ) = ('', '');
1489 if ( $self->_password_encoding ) {
1490 $encoding = $self->_password_encoding;
1491 # identify existing encryption method, try to use it.
1492 $encryption = $self->_password_encryption;
1494 # use the system default
1500 # set encoding to system default
1501 ($encoding, $encryption) =
1502 split(/-/, lc($conf->config('default-password-encoding') || ''));
1503 $encoding ||= 'legacy';
1504 $self->_password_encoding($encoding);
1507 if ( $encoding eq 'legacy' ) {
1509 # The legacy behavior from check():
1510 # If the password is blank, randomize it and set encoding to 'plain'.
1511 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1512 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1513 $self->_password_encoding('plain');
1515 # Prefix + valid-length password
1516 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1518 $self->_password_encoding('plain');
1519 # Prefix + crypt string
1520 } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1522 $self->_password_encoding('crypt');
1523 # Various disabled crypt passwords
1524 } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1525 $self->_password_encoding('crypt');
1531 $self->_password($pass);
1537 if $passwordmin && length($pass) < $passwordmin
1538 or $passwordmax && length($pass) > $passwordmax;
1540 if ( $encoding eq 'crypt' ) {
1541 if ($encryption eq 'md5') {
1542 $pass = unix_md5_crypt($pass);
1543 } elsif ($encryption eq 'des') {
1544 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1547 } elsif ( $encoding eq 'ldap' ) {
1548 if ($encryption eq 'md5') {
1549 $pass = md5_base64($pass);
1550 } elsif ($encryption eq 'sha1') {
1551 $pass = sha1_base64($pass);
1552 } elsif ($encryption eq 'crypt') {
1553 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1555 # else $encryption eq 'plain', do nothing
1556 $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1557 if $encryption eq 'md5' || $encryption eq 'sha1';
1558 $pass = '{'.uc($encryption).'}'.$pass;
1560 # else encoding eq 'plain'
1562 $self->_password($pass);
1568 Internal function to check the username against the list of system usernames
1569 from the I<system_usernames> configuration value. Returns true if the username
1570 is listed on the system username list.
1576 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1577 $conf->config('system_usernames')
1581 =item _check_duplicate
1583 Internal method to check for duplicates usernames, username@domain pairs and
1586 If the I<global_unique-username> configuration value is set to B<username> or
1587 B<username@domain>, enforces global username or username@domain uniqueness.
1589 In all cases, check for duplicate uids and usernames or username@domain pairs
1590 per export and with identical I<svcpart> values.
1594 sub _check_duplicate {
1597 my $global_unique = $conf->config('global_unique-username') || 'none';
1598 return '' if $global_unique eq 'disabled';
1602 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1603 unless ( $part_svc ) {
1604 return 'unknown svcpart '. $self->svcpart;
1607 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1608 qsearch( 'svc_acct', { 'username' => $self->username } );
1609 return gettext('username_in_use')
1610 if $global_unique eq 'username' && @dup_user;
1612 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1613 qsearch( 'svc_acct', { 'username' => $self->username,
1614 'domsvc' => $self->domsvc } );
1615 return gettext('username_in_use')
1616 if $global_unique eq 'username@domain' && @dup_userdomain;
1619 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1620 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1621 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1622 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1627 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1628 my $exports = FS::part_export::export_info('svc_acct');
1629 my %conflict_user_svcpart;
1630 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1632 foreach my $part_export ( $part_svc->part_export ) {
1634 #this will catch to the same exact export
1635 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1637 #this will catch to exports w/same exporthost+type ???
1638 #my @other_part_export = qsearch('part_export', {
1639 # 'machine' => $part_export->machine,
1640 # 'exporttype' => $part_export->exporttype,
1642 #foreach my $other_part_export ( @other_part_export ) {
1643 # push @svcparts, map { $_->svcpart }
1644 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1647 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1648 #silly kludge to avoid uninitialized value errors
1649 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1650 ? $exports->{$part_export->exporttype}{'nodomain'}
1652 if ( $nodomain =~ /^Y/i ) {
1653 $conflict_user_svcpart{$_} = $part_export->exportnum
1656 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1661 foreach my $dup_user ( @dup_user ) {
1662 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1663 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1664 return "duplicate username ". $self->username.
1665 ": conflicts with svcnum ". $dup_user->svcnum.
1666 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1670 foreach my $dup_userdomain ( @dup_userdomain ) {
1671 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1672 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1673 return "duplicate username\@domain ". $self->email.
1674 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1675 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1679 foreach my $dup_uid ( @dup_uid ) {
1680 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1681 if ( exists($conflict_user_svcpart{$dup_svcpart})
1682 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1683 return "duplicate uid ". $self->uid.
1684 ": conflicts with svcnum ". $dup_uid->svcnum.
1686 ( $conflict_user_svcpart{$dup_svcpart}
1687 || $conflict_userdomain_svcpart{$dup_svcpart} );
1699 Depriciated, use radius_reply instead.
1704 carp "FS::svc_acct::radius depriciated, use radius_reply";
1705 $_[0]->radius_reply;
1710 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1711 reply attributes of this record.
1713 Note that this is now the preferred method for reading RADIUS attributes -
1714 accessing the columns directly is discouraged, as the column names are
1715 expected to change in the future.
1722 return %{ $self->{'radius_reply'} }
1723 if exists $self->{'radius_reply'};
1728 my($column, $attrib) = ($1, $2);
1729 #$attrib =~ s/_/\-/g;
1730 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1731 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1733 if ( $self->slipip && $self->slipip ne '0e0' ) {
1734 $reply{$radius_ip} = $self->slipip;
1737 if ( $self->seconds !~ /^$/ ) {
1738 $reply{'Session-Timeout'} = $self->seconds;
1741 if ( $conf->exists('radius-chillispot-max') ) {
1742 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1744 #hmm. just because sqlradius.pm says so?
1751 foreach my $what (qw( input output total )) {
1752 my $is = $whatis{$what}.'bytes';
1753 if ( $self->$is() =~ /\d/ ) {
1754 my $big = new Math::BigInt $self->$is();
1755 $big = new Math::BigInt '0' if $big->is_neg();
1756 my $att = "Chillispot-Max-\u$what";
1757 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1758 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1769 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1770 check attributes of this record.
1772 Note that this is now the preferred method for reading RADIUS attributes -
1773 accessing the columns directly is discouraged, as the column names are
1774 expected to change in the future.
1781 return %{ $self->{'radius_check'} }
1782 if exists $self->{'radius_check'};
1787 my($column, $attrib) = ($1, $2);
1788 #$attrib =~ s/_/\-/g;
1789 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1790 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1793 my($pw_attrib, $password) = $self->radius_password;
1794 $check{$pw_attrib} = $password;
1796 my $cust_svc = $self->cust_svc;
1798 my $cust_pkg = $cust_svc->cust_pkg;
1799 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1800 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1803 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1804 "; can't set Expiration\n"
1812 =item radius_password
1814 Returns a key/value pair containing the RADIUS attribute name and value
1819 sub radius_password {
1823 if ( $self->_password_encoding eq 'ldap' ) {
1824 $pw_attrib = 'Password-With-Header';
1825 } elsif ( $self->_password_encoding eq 'crypt' ) {
1826 $pw_attrib = 'Crypt-Password';
1827 } elsif ( $self->_password_encoding eq 'plain' ) {
1828 $pw_attrib = $radius_password;
1830 $pw_attrib = length($self->_password) <= 12
1835 ($pw_attrib, $self->_password);
1841 This method instructs the object to "snapshot" or freeze RADIUS check and
1842 reply attributes to the current values.
1846 #bah, my english is too broken this morning
1847 #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
1848 #the FS::cust_pkg's replace method to trigger the correct export updates when
1849 #package dates change)
1854 $self->{$_} = { $self->$_() }
1855 foreach qw( radius_reply radius_check );
1859 =item forget_snapshot
1861 This methos instructs the object to forget any previously snapshotted
1862 RADIUS check and reply attributes.
1866 sub forget_snapshot {
1870 foreach qw( radius_reply radius_check );
1874 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1876 Returns the domain associated with this account.
1878 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1885 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1886 my $svc_domain = $self->svc_domain(@_)
1887 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1888 $svc_domain->domain;
1893 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1897 #inherited from svc_Common
1899 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1901 Returns an email address associated with the account.
1903 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1910 $self->username. '@'. $self->domain(@_);
1916 Returns an array of FS::acct_snarf records associated with the account.
1920 # unused as originally intended, but now by Communigate Pro "RPOP"
1924 'table' => 'acct_snarf',
1925 'hashref' => { 'svcnum' => $self->svcnum },
1926 #'order_by' => 'ORDER BY priority ASC',
1930 =item cgp_rpop_hashref
1932 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1936 sub cgp_rpop_hashref {
1938 { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1941 =item decrement_upbytes OCTETS
1943 Decrements the I<upbytes> field of this record by the given amount. If there
1944 is an error, returns the error, otherwise returns false.
1948 sub decrement_upbytes {
1949 shift->_op_usage('-', 'upbytes', @_);
1952 =item increment_upbytes OCTETS
1954 Increments the I<upbytes> field of this record by the given amount. If there
1955 is an error, returns the error, otherwise returns false.
1959 sub increment_upbytes {
1960 shift->_op_usage('+', 'upbytes', @_);
1963 =item decrement_downbytes OCTETS
1965 Decrements the I<downbytes> field of this record by the given amount. If there
1966 is an error, returns the error, otherwise returns false.
1970 sub decrement_downbytes {
1971 shift->_op_usage('-', 'downbytes', @_);
1974 =item increment_downbytes OCTETS
1976 Increments the I<downbytes> field of this record by the given amount. If there
1977 is an error, returns the error, otherwise returns false.
1981 sub increment_downbytes {
1982 shift->_op_usage('+', 'downbytes', @_);
1985 =item decrement_totalbytes OCTETS
1987 Decrements the I<totalbytes> field of this record by the given amount. If there
1988 is an error, returns the error, otherwise returns false.
1992 sub decrement_totalbytes {
1993 shift->_op_usage('-', 'totalbytes', @_);
1996 =item increment_totalbytes OCTETS
1998 Increments the I<totalbytes> field of this record by the given amount. If there
1999 is an error, returns the error, otherwise returns false.
2003 sub increment_totalbytes {
2004 shift->_op_usage('+', 'totalbytes', @_);
2007 =item decrement_seconds SECONDS
2009 Decrements the I<seconds> field of this record by the given amount. If there
2010 is an error, returns the error, otherwise returns false.
2014 sub decrement_seconds {
2015 shift->_op_usage('-', 'seconds', @_);
2018 =item increment_seconds SECONDS
2020 Increments the I<seconds> field of this record by the given amount. If there
2021 is an error, returns the error, otherwise returns false.
2025 sub increment_seconds {
2026 shift->_op_usage('+', 'seconds', @_);
2034 my %op2condition = (
2035 '-' => sub { my($self, $column, $amount) = @_;
2036 $self->$column - $amount <= 0;
2038 '+' => sub { my($self, $column, $amount) = @_;
2039 ($self->$column || 0) + $amount > 0;
2042 my %op2warncondition = (
2043 '-' => sub { my($self, $column, $amount) = @_;
2044 my $threshold = $column . '_threshold';
2045 $self->$column - $amount <= $self->$threshold + 0;
2047 '+' => sub { my($self, $column, $amount) = @_;
2048 ($self->$column || 0) + $amount > 0;
2053 my( $self, $op, $column, $amount ) = @_;
2055 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2056 ' ('. $self->email. "): $op $amount\n"
2059 return '' unless $amount;
2061 local $SIG{HUP} = 'IGNORE';
2062 local $SIG{INT} = 'IGNORE';
2063 local $SIG{QUIT} = 'IGNORE';
2064 local $SIG{TERM} = 'IGNORE';
2065 local $SIG{TSTP} = 'IGNORE';
2066 local $SIG{PIPE} = 'IGNORE';
2068 my $oldAutoCommit = $FS::UID::AutoCommit;
2069 local $FS::UID::AutoCommit = 0;
2072 my $sql = "UPDATE svc_acct SET $column = ".
2073 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2074 " $op ? WHERE svcnum = ?";
2078 my $sth = $dbh->prepare( $sql )
2079 or die "Error preparing $sql: ". $dbh->errstr;
2080 my $rv = $sth->execute($amount, $self->svcnum);
2081 die "Error executing $sql: ". $sth->errstr
2082 unless defined($rv);
2083 die "Can't update $column for svcnum". $self->svcnum
2086 #$self->snapshot; #not necessary, we retain the old values
2087 #create an object with the updated usage values
2088 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2090 my $error = $new->replace($self);
2092 $dbh->rollback if $oldAutoCommit;
2093 return "Error replacing: $error";
2096 #overlimit_action eq 'cancel' handling
2097 my $cust_pkg = $self->cust_svc->cust_pkg;
2099 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2100 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2104 my $error = $cust_pkg->cancel; #XXX should have a reason
2106 $dbh->rollback if $oldAutoCommit;
2107 return "Error cancelling: $error";
2110 #nothing else is relevant if we're cancelling, so commit & return success
2111 warn "$me update successful; committing\n"
2113 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2118 my $action = $op2action{$op};
2120 if ( &{$op2condition{$op}}($self, $column, $amount) &&
2121 ( $action eq 'suspend' && !$self->overlimit
2122 || $action eq 'unsuspend' && $self->overlimit )
2125 my $error = $self->_op_overlimit($action);
2127 $dbh->rollback if $oldAutoCommit;
2133 if ( $conf->exists("svc_acct-usage_$action")
2134 && &{$op2condition{$op}}($self, $column, $amount) ) {
2135 #my $error = $self->$action();
2136 my $error = $self->cust_svc->cust_pkg->$action();
2137 # $error ||= $self->overlimit($action);
2139 $dbh->rollback if $oldAutoCommit;
2140 return "Error ${action}ing: $error";
2144 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2145 my $wqueue = new FS::queue {
2146 'svcnum' => $self->svcnum,
2147 'job' => 'FS::svc_acct::reached_threshold',
2152 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2156 my $error = $wqueue->insert(
2157 'svcnum' => $self->svcnum,
2159 'column' => $column,
2163 $dbh->rollback if $oldAutoCommit;
2164 return "Error queuing threshold activity: $error";
2168 warn "$me update successful; committing\n"
2170 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2176 my( $self, $action ) = @_;
2178 local $SIG{HUP} = 'IGNORE';
2179 local $SIG{INT} = 'IGNORE';
2180 local $SIG{QUIT} = 'IGNORE';
2181 local $SIG{TERM} = 'IGNORE';
2182 local $SIG{TSTP} = 'IGNORE';
2183 local $SIG{PIPE} = 'IGNORE';
2185 my $oldAutoCommit = $FS::UID::AutoCommit;
2186 local $FS::UID::AutoCommit = 0;
2189 my $cust_pkg = $self->cust_svc->cust_pkg;
2191 my @conf_overlimit =
2193 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2194 : $conf->config('overlimit_groups');
2196 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2198 my @groups = scalar(@conf_overlimit) ? @conf_overlimit
2199 : split(' ',$part_export->option('overlimit_groups'));
2200 next unless scalar(@groups);
2202 my $other = new FS::svc_acct $self->hashref;
2203 $other->usergroup(\@groups);
2206 if ($action eq 'suspend') {
2209 } else { # $action eq 'unsuspend'
2214 my $error = $part_export->export_replace($new, $old)
2215 || $self->overlimit($action);
2218 $dbh->rollback if $oldAutoCommit;
2219 return "Error replacing radius groups: $error";
2224 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2230 my( $self, $valueref, %options ) = @_;
2232 warn "$me set_usage called for svcnum ". $self->svcnum.
2233 ' ('. $self->email. "): ".
2234 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2237 local $SIG{HUP} = 'IGNORE';
2238 local $SIG{INT} = 'IGNORE';
2239 local $SIG{QUIT} = 'IGNORE';
2240 local $SIG{TERM} = 'IGNORE';
2241 local $SIG{TSTP} = 'IGNORE';
2242 local $SIG{PIPE} = 'IGNORE';
2244 local $FS::svc_Common::noexport_hack = 1;
2245 my $oldAutoCommit = $FS::UID::AutoCommit;
2246 local $FS::UID::AutoCommit = 0;
2251 if ( $options{null} ) {
2252 %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2253 qw( seconds upbytes downbytes totalbytes )
2256 foreach my $field (keys %$valueref){
2257 $reset = 1 if $valueref->{$field};
2258 $self->setfield($field, $valueref->{$field});
2259 $self->setfield( $field.'_threshold',
2260 int($self->getfield($field)
2261 * ( $conf->exists('svc_acct-usage_threshold')
2262 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2267 $handyhash{$field} = $self->getfield($field);
2268 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2270 #my $error = $self->replace; #NO! we avoid the call to ->check for
2271 #die $error if $error; #services not explicity changed via the UI
2273 my $sql = "UPDATE svc_acct SET " .
2274 join (',', map { "$_ = ?" } (keys %handyhash) ).
2275 " WHERE svcnum = ". $self->svcnum;
2280 if (scalar(keys %handyhash)) {
2281 my $sth = $dbh->prepare( $sql )
2282 or die "Error preparing $sql: ". $dbh->errstr;
2283 my $rv = $sth->execute(values %handyhash);
2284 die "Error executing $sql: ". $sth->errstr
2285 unless defined($rv);
2286 die "Can't update usage for svcnum ". $self->svcnum
2290 #$self->snapshot; #not necessary, we retain the old values
2291 #create an object with the updated usage values
2292 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2293 local($FS::Record::nowarn_identical) = 1;
2294 my $error = $new->replace($self); #call exports
2296 $dbh->rollback if $oldAutoCommit;
2297 return "Error replacing: $error";
2304 $error = $self->_op_overlimit('unsuspend')
2305 if $self->overlimit;;
2307 $error ||= $self->cust_svc->cust_pkg->unsuspend
2308 if $conf->exists("svc_acct-usage_unsuspend");
2311 $dbh->rollback if $oldAutoCommit;
2312 return "Error unsuspending: $error";
2317 warn "$me update successful; committing\n"
2319 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2325 =item recharge HASHREF
2327 Increments usage columns by the amount specified in HASHREF as
2328 column=>amount pairs.
2333 my ($self, $vhash) = @_;
2336 warn "[$me] recharge called on $self: ". Dumper($self).
2337 "\nwith vhash: ". Dumper($vhash);
2340 my $oldAutoCommit = $FS::UID::AutoCommit;
2341 local $FS::UID::AutoCommit = 0;
2345 foreach my $column (keys %$vhash){
2346 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2350 $dbh->rollback if $oldAutoCommit;
2352 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2357 =item is_rechargeable
2359 Returns true if this svc_account can be "recharged" and false otherwise.
2363 sub is_rechargable {
2365 $self->seconds ne ''
2366 || $self->upbytes ne ''
2367 || $self->downbytes ne ''
2368 || $self->totalbytes ne '';
2371 =item seconds_since TIMESTAMP
2373 Returns the number of seconds this account has been online since TIMESTAMP,
2374 according to the session monitor (see L<FS::Session>).
2376 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2377 L<Time::Local> and L<Date::Parse> for conversion functions.
2381 #note: POD here, implementation in FS::cust_svc
2384 $self->cust_svc->seconds_since(@_);
2387 =item last_login_text
2389 Returns text describing the time of last login.
2393 sub last_login_text {
2395 $self->last_login ? ctime($self->last_login) : 'unknown';
2398 =item psearch_cdrs OPTIONS
2400 Returns a paged search (L<FS::PagedSearch>) for Call Detail Records
2401 associated with this service. For svc_acct, "associated with" means that
2402 either the "src" or the "charged_party" field of the CDR matches the
2403 "username" field of the service.
2408 my($self, %options) = @_;
2413 my $did = dbh->quote($self->username);
2415 my $prefix = $options{'default_prefix'} || ''; #convergent.au '+61'
2416 my $prefixdid = dbh->quote($prefix . $self->username);
2418 my $for_update = $options{'for_update'} ? 'FOR UPDATE' : '';
2420 if ( $options{inbound} ) {
2421 # these will be selected under their DIDs
2422 push @where, "FALSE";
2426 if (!$options{'disable_charged_party'}) {
2428 "charged_party = $did",
2429 "charged_party = $prefixdid";
2431 if (!$options{'disable_src'}) {
2433 "src = $did AND charged_party IS NULL",
2434 "src = $prefixdid AND charged_party IS NULL";
2436 push @where, '(' . join(' OR ', @orwhere) . ')';
2438 # $options{'status'} = '' is meaningful; for the rest of them it's not
2439 if ( exists $options{'status'} ) {
2440 $hash{'freesidestatus'} = $options{'status'};
2442 if ( $options{'cdrtypenum'} ) {
2443 $hash{'cdrtypenum'} = $options{'cdrtypenum'};
2445 if ( $options{'calltypenum'} ) {
2446 $hash{'calltypenum'} = $options{'calltypenum'};
2448 if ( $options{'begin'} ) {
2449 push @where, 'startdate >= '. $options{'begin'};
2451 if ( $options{'end'} ) {
2452 push @where, 'startdate < '. $options{'end'};
2454 if ( $options{'nonzero'} ) {
2455 push @where, 'duration > 0';
2458 my $extra_sql = join(' AND ', @where);
2461 $extra_sql = " AND ".$extra_sql;
2463 $extra_sql = " WHERE ".$extra_sql;
2469 'hashref' => \%hash,
2470 'extra_sql' => $extra_sql,
2471 'order_by' => "ORDER BY startdate $for_update",
2475 =item get_cdrs (DEPRECATED)
2477 Like psearch_cdrs, but returns all the L<FS::cdr> objects at once, in a
2478 single list. Arguments are the same as for psearch_cdrs.
2484 my $psearch = $self->psearch_cdrs(@_);
2485 qsearch ( $psearch->{query} )
2488 # sub radius_groups has moved to svc_Radius_Mixin
2490 =item clone_suspended
2492 Constructor used by FS::part_export::_export_suspend fallback. Document
2497 sub clone_suspended {
2499 my %hash = $self->hash;
2500 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2501 new FS::svc_acct \%hash;
2504 =item clone_kludge_unsuspend
2506 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2511 sub clone_kludge_unsuspend {
2513 my %hash = $self->hash;
2514 $hash{_password} = '';
2515 new FS::svc_acct \%hash;
2518 =item check_password
2520 Checks the supplied password against the (possibly encrypted) password in the
2521 database. Returns true for a successful authentication, false for no match.
2523 Currently supported encryptions are: classic DES crypt() and MD5
2527 sub check_password {
2528 my($self, $check_password) = @_;
2530 #remove old-style SUSPENDED kludge, they should be allowed to login to
2531 #self-service and pay up
2532 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2534 if ( $self->_password_encoding eq 'ldap' ) {
2536 $password =~ s/^{PLAIN}/{CLEARTEXT}/;
2537 my $auth = from_rfc2307 Authen::Passphrase $password;
2538 return $auth->match($check_password);
2540 } elsif ( $self->_password_encoding eq 'crypt' ) {
2542 my $auth = from_crypt Authen::Passphrase $self->_password;
2543 return $auth->match($check_password);
2545 } elsif ( $self->_password_encoding eq 'plain' ) {
2547 return $check_password eq $password;
2551 #XXX this could be replaced with Authen::Passphrase stuff
2553 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2555 } elsif ( length($password) < 13 ) { #plaintext
2556 $check_password eq $password;
2557 } elsif ( length($password) == 13 ) { #traditional DES crypt
2558 crypt($check_password, $password) eq $password;
2559 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2560 unix_md5_crypt($check_password, $password) eq $password;
2561 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2562 warn "Can't check password: Blowfish encryption not yet supported, ".
2563 "svcnum ". $self->svcnum. "\n";
2566 warn "Can't check password: Unrecognized encryption for svcnum ".
2567 $self->svcnum. "\n";
2575 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2577 Returns an encrypted password, either by passing through an encrypted password
2578 in the database or by encrypting a plaintext password from the database.
2580 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2581 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2582 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2583 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2584 encryption type is only used if the password is not already encrypted in the
2589 sub crypt_password {
2592 if ( $self->_password_encoding eq 'ldap' ) {
2594 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2597 #XXX this could be replaced with Authen::Passphrase stuff
2599 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2600 if ( $encryption eq 'crypt' ) {
2603 $saltset[int(rand(64))].$saltset[int(rand(64))]
2605 } elsif ( $encryption eq 'md5' ) {
2606 return unix_md5_crypt( $self->_password );
2607 } elsif ( $encryption eq 'blowfish' ) {
2608 croak "unknown encryption method $encryption";
2610 croak "unknown encryption method $encryption";
2613 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2617 } elsif ( $self->_password_encoding eq 'crypt' ) {
2619 return $self->_password;
2621 } elsif ( $self->_password_encoding eq 'plain' ) {
2623 #XXX this could be replaced with Authen::Passphrase stuff
2625 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2626 if ( $encryption eq 'crypt' ) {
2629 $saltset[int(rand(64))].$saltset[int(rand(64))]
2631 } elsif ( $encryption eq 'md5' ) {
2632 return unix_md5_crypt( $self->_password );
2633 } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2634 my $pass = sha1_base64( $self->_password );
2635 $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2637 } elsif ( $encryption eq 'blowfish' ) {
2638 croak "unknown encryption method $encryption";
2640 croak "unknown encryption method $encryption";
2645 if ( length($self->_password) == 13
2646 || $self->_password =~ /^\$(1|2a?)\$/
2647 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2653 #XXX this could be replaced with Authen::Passphrase stuff
2655 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2656 if ( $encryption eq 'crypt' ) {
2659 $saltset[int(rand(64))].$saltset[int(rand(64))]
2661 } elsif ( $encryption eq 'md5' ) {
2662 return unix_md5_crypt( $self->_password );
2663 } elsif ( $encryption eq 'blowfish' ) {
2664 croak "unknown encryption method $encryption";
2666 croak "unknown encryption method $encryption";
2675 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2677 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2678 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2679 "{MD5}5426824942db4253f87a1009fd5d2d4".
2681 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2682 to work the same as the B</crypt_password> method.
2688 #eventually should check a "password-encoding" field
2690 if ( $self->_password_encoding eq 'ldap' ) {
2692 return $self->_password;
2694 } elsif ( $self->_password_encoding eq 'crypt' ) {
2696 if ( length($self->_password) == 13 ) { #crypt
2697 return '{CRYPT}'. $self->_password;
2698 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2700 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2701 # die "Blowfish encryption not supported in this context, svcnum ".
2702 # $self->svcnum. "\n";
2704 warn "encryption method not (yet?) supported in LDAP context";
2705 return '{CRYPT}*'; #unsupported, should not auth
2708 } elsif ( $self->_password_encoding eq 'plain' ) {
2710 return '{PLAIN}'. $self->_password;
2712 #return '{CLEARTEXT}'. $self->_password; #?
2716 if ( length($self->_password) == 13 ) { #crypt
2717 return '{CRYPT}'. $self->_password;
2718 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2720 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2721 warn "Blowfish encryption not supported in this context, svcnum ".
2722 $self->svcnum. "\n";
2725 #are these two necessary anymore?
2726 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2727 return '{SSHA}'. $1;
2728 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2729 return '{NS-MTA-MD5}'. $1;
2732 return '{PLAIN}'. $self->_password;
2734 #return '{CLEARTEXT}'. $self->_password; #?
2736 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2737 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2738 #if ( $encryption eq 'crypt' ) {
2739 # return '{CRYPT}'. crypt(
2741 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2743 #} elsif ( $encryption eq 'md5' ) {
2744 # unix_md5_crypt( $self->_password );
2745 #} elsif ( $encryption eq 'blowfish' ) {
2746 # croak "unknown encryption method $encryption";
2748 # croak "unknown encryption method $encryption";
2756 =item domain_slash_username
2758 Returns $domain/$username/
2762 sub domain_slash_username {
2764 $self->domain. '/'. $self->username. '/';
2767 =item virtual_maildir
2769 Returns $domain/maildirs/$username/
2773 sub virtual_maildir {
2775 $self->domain. '/maildirs/'. $self->username. '/';
2778 =item password_svc_check
2780 Override, for L<FS::Password_Mixin>. Not really intended for other use.
2784 sub password_svc_check {
2785 my ($self, $password) = @_;
2786 foreach my $field ( qw(username finger) ) {
2787 foreach my $word (split(/\W+/,$self->get($field))) {
2788 next unless length($word) > 2;
2789 if ($password =~ /$word/i) {
2790 return qq(Password contains account information '$word');
2799 =head1 CLASS METHODS
2803 =item search HASHREF
2805 Class method which returns a qsearch hash expression to search for parameters
2806 specified in HASHREF. Valid parameters are
2820 Arrayref of pkgparts
2826 Arrayref of additional WHERE clauses, will be ANDed together.
2837 my( $class, $params, $from, $where ) = @_;
2839 #these two should probably move to svc_Domain_Mixin ?
2842 if ( $params->{'domain'} ) {
2843 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2844 #preserve previous behavior & bubble up an error if $svc_domain not found?
2845 push @$where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2849 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2850 push @$where, "domsvc = $1";
2855 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2856 push @$where, "popnum = $1";
2860 #and these in svc_Tower_Mixin, or maybe we never should have done svc_acct
2861 # towers (or, as mark thought, never should have done svc_broadband)
2864 my @where_sector = $class->tower_sector_sql($params);
2865 if ( @where_sector ) {
2866 push @$where, @where_sector;
2867 push @$from, ' LEFT JOIN tower_sector USING ( sectornum )';
2880 This is the FS::svc_acct job-queue-able version. It still uses
2881 FS::Misc::send_email under-the-hood.
2888 eval "use FS::Misc qw(send_email)";
2891 $opt{mimetype} ||= 'text/plain';
2892 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2894 my $error = send_email(
2895 'from' => $opt{from},
2897 'subject' => $opt{subject},
2898 'content-type' => $opt{mimetype},
2899 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2901 die $error if $error;
2904 =item check_and_rebuild_fuzzyfiles
2908 sub check_and_rebuild_fuzzyfiles {
2909 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2910 -e "$dir/svc_acct.username"
2911 or &rebuild_fuzzyfiles;
2914 =item rebuild_fuzzyfiles
2918 sub rebuild_fuzzyfiles {
2920 use Fcntl qw(:flock);
2922 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2926 open(USERNAMELOCK,">>$dir/svc_acct.username")
2927 or die "can't open $dir/svc_acct.username: $!";
2928 flock(USERNAMELOCK,LOCK_EX)
2929 or die "can't lock $dir/svc_acct.username: $!";
2931 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2933 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2934 or die "can't open $dir/svc_acct.username.tmp: $!";
2935 print USERNAMECACHE join("\n", @all_username), "\n";
2936 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2938 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2948 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2949 open(USERNAMECACHE,"<$dir/svc_acct.username")
2950 or die "can't open $dir/svc_acct.username: $!";
2951 my @array = map { chomp; $_; } <USERNAMECACHE>;
2952 close USERNAMECACHE;
2956 =item append_fuzzyfiles USERNAME
2960 sub append_fuzzyfiles {
2961 my $username = shift;
2963 &check_and_rebuild_fuzzyfiles;
2965 use Fcntl qw(:flock);
2967 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2969 open(USERNAME,">>$dir/svc_acct.username")
2970 or die "can't open $dir/svc_acct.username: $!";
2971 flock(USERNAME,LOCK_EX)
2972 or die "can't lock $dir/svc_acct.username: $!";
2974 print USERNAME "$username\n";
2976 flock(USERNAME,LOCK_UN)
2977 or die "can't unlock $dir/svc_acct.username: $!";
2984 =item reached_threshold
2986 Performs some activities when svc_acct thresholds (such as number of seconds
2987 remaining) are reached.
2991 sub reached_threshold {
2994 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2995 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2997 if ( $opt{'op'} eq '+' ){
2998 $svc_acct->setfield( $opt{'column'}.'_threshold',
2999 int($svc_acct->getfield($opt{'column'})
3000 * ( $conf->exists('svc_acct-usage_threshold')
3001 ? $conf->config('svc_acct-usage_threshold')/100
3006 my $error = $svc_acct->replace;
3007 die $error if $error;
3008 }elsif ( $opt{'op'} eq '-' ){
3010 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3011 return '' if ($threshold eq '' );
3013 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3014 my $error = $svc_acct->replace;
3015 die $error if $error; # email next time, i guess
3017 if ( $warning_template ) {
3018 eval "use FS::Misc qw(send_email)";
3021 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
3022 my $cust_main = $cust_pkg->cust_main;
3024 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3025 $cust_main->invoicing_list,
3026 ($opt{'to'} ? $opt{'to'} : ())
3029 my $mimetype = $warning_mimetype;
3030 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3032 my $body = $warning_template->fill_in( HASH => {
3033 'custnum' => $cust_main->custnum,
3034 'username' => $svc_acct->username,
3035 'password' => $svc_acct->_password,
3036 'first' => $cust_main->first,
3037 'last' => $cust_main->getfield('last'),
3038 'pkg' => $cust_pkg->part_pkg->pkg,
3039 'column' => $opt{'column'},
3040 'amount' => $opt{'column'} =~/bytes/
3041 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3042 : $svc_acct->getfield($opt{'column'}),
3043 'threshold' => $opt{'column'} =~/bytes/
3044 ? FS::UI::bytecount::display_bytecount($threshold)
3049 my $error = send_email(
3050 'from' => $warning_from,
3052 'subject' => $warning_subject,
3053 'content-type' => $mimetype,
3054 'body' => [ map "$_\n", split("\n", $body) ],
3056 die $error if $error;
3059 die "unknown op: " . $opt{'op'};
3067 The $recref stuff in sub check should be cleaned up.
3069 The suspend, unsuspend and cancel methods update the database, but not the
3070 current object. This is probably a bug as it's unexpected and
3073 insertion of RADIUS group stuff in insert could be done with child_objects now
3074 (would probably clean up export of them too)
3076 _op_usage and set_usage bypass the history... maybe they shouldn't
3080 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3081 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3082 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3083 L<freeside-queued>), L<FS::svc_acct_pop>,
3084 schema.html from the base documentation.