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 = FS::svc_acct->pw_set;
121 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
125 my ( $hashref, $cache ) = @_;
126 if ( $hashref->{'svc_acct_svcnum'} ) {
127 $self->{'_domsvc'} = FS::svc_domain->new( {
128 'svcnum' => $hashref->{'domsvc'},
129 'domain' => $hashref->{'svc_acct_domain'},
130 'catchall' => $hashref->{'svc_acct_catchall'},
137 FS::svc_acct - Object methods for svc_acct records
143 $record = new FS::svc_acct \%hash;
144 $record = new FS::svc_acct { 'column' => 'value' };
146 $error = $record->insert;
148 $error = $new_record->replace($old_record);
150 $error = $record->delete;
152 $error = $record->check;
154 $error = $record->suspend;
156 $error = $record->unsuspend;
158 $error = $record->cancel;
160 %hash = $record->radius;
162 %hash = $record->radius_reply;
164 %hash = $record->radius_check;
166 $domain = $record->domain;
168 $svc_domain = $record->svc_domain;
170 $email = $record->email;
172 $seconds_since = $record->seconds_since($timestamp);
176 An FS::svc_acct object represents an account. FS::svc_acct inherits from
177 FS::svc_Common. The following fields are currently supported:
183 Primary key (assigned automatcially for new accounts)
191 =item _password_encoding
193 plain, crypt, ldap (or empty for autodetection)
201 Point of presence (see L<FS::svc_acct_pop>)
213 set automatically if blank (and uid is not)
233 svcnum from svc_domain
237 Optional svcnum from svc_pbx
239 =item radius_I<Radius_Attribute>
241 I<Radius-Attribute> (reply)
243 =item rc_I<Radius_Attribute>
245 I<Radius-Attribute> (check)
255 Creates a new account. To add the account to the database, see L<"insert">.
262 'longname_plural' => 'Access accounts and mailboxes',
263 'sorts' => [ 'username', 'uid', 'seconds', 'last_login' ],
264 'display_weight' => 10,
265 'cancel_weight' => 50,
266 'ip_field' => 'slipip',
267 'manual_require' => 1,
269 'dir' => 'Home directory',
272 def_info => 'set to fixed and blank for no UIDs',
275 'slipip' => 'IP address',
276 # 'popnum' => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
278 label => 'Access number',
280 select_table => 'svc_acct_pop',
281 select_key => 'popnum',
282 select_label => 'city',
288 disable_default => 1,
293 'password_selfchange' => { label => 'Password modification',
296 'password_recover' => { label => 'Password recovery',
300 label => 'Quota', #Mail storage limit
302 disable_inventory => 1,
305 label => 'File storage limit',
307 disable_inventory => 1,
310 label => 'Number of files limit',
312 disable_inventory => 1,
315 label => 'File size limit',
317 disable_inventory => 1,
319 '_password' => { label => 'Password',
324 def_info => 'when blank, defaults to UID',
329 def_info => 'set to blank for no shell tracking',
331 #select_list => [ $conf->config('shells') ],
332 select_list => [ $conf ? $conf->config('shells') : () ],
333 disable_inventory => 1,
336 '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 ($FS::svc_Common::noexport_hack or ( 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 foreach my $svc_phone (
929 qsearch( 'svc_phone', { 'forward_svcnum' => $self->svcnum })
931 $svc_phone->set('forward_svcnum', '');
932 my $error = $svc_phone->replace;
934 $dbh->rollback if $oldAutoCommit;
939 my $error = $self->delete_password_history
940 || $self->SUPER::delete; # usergroup here
942 $dbh->rollback if $oldAutoCommit;
946 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
950 =item replace OLD_RECORD
952 Replaces OLD_RECORD with this one in the database. If there is an error,
953 returns the error, otherwise returns false.
955 The additional field I<usergroup> can optionally be defined; if so it should
956 contain an arrayref of group names. See L<FS::radius_usergroup>.
964 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
968 warn "$me replacing $old with $new\n" if $DEBUG;
972 return "can't modify system account" if $old->_check_system;
975 #no warnings 'numeric'; #alas, a 5.006-ism
978 foreach my $xid (qw( uid gid )) {
980 return "Can't change $xid!"
981 if ! $conf->exists("svc_acct-edit_$xid")
982 && $old->$xid() != $new->$xid()
983 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
988 return "can't change username"
989 if $old->username ne $new->username
990 && $conf->exists('svc_acct-no_edit_username');
992 #change homdir when we change username
993 $new->setfield('dir', '') if $old->username ne $new->username;
995 local $SIG{HUP} = 'IGNORE';
996 local $SIG{INT} = 'IGNORE';
997 local $SIG{QUIT} = 'IGNORE';
998 local $SIG{TERM} = 'IGNORE';
999 local $SIG{TSTP} = 'IGNORE';
1000 local $SIG{PIPE} = 'IGNORE';
1002 my $oldAutoCommit = $FS::UID::AutoCommit;
1003 local $FS::UID::AutoCommit = 0;
1006 $error = $new->SUPER::replace($old, @_); # usergroup here
1008 # don't need to record this unless the password was changed
1009 if ( $old->_password ne $new->_password ) {
1010 $error ||= $new->insert_password_history;
1014 $dbh->rollback if $oldAutoCommit;
1015 return $error if $error;
1018 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1019 $error = $new->queue_fuzzyfiles_update;
1021 $dbh->rollback if $oldAutoCommit;
1022 return "updating fuzzy search cache: $error";
1026 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1030 =item queue_fuzzyfiles_update
1032 Used by insert & replace to update the fuzzy search cache
1036 sub queue_fuzzyfiles_update {
1039 local $SIG{HUP} = 'IGNORE';
1040 local $SIG{INT} = 'IGNORE';
1041 local $SIG{QUIT} = 'IGNORE';
1042 local $SIG{TERM} = 'IGNORE';
1043 local $SIG{TSTP} = 'IGNORE';
1044 local $SIG{PIPE} = 'IGNORE';
1046 my $oldAutoCommit = $FS::UID::AutoCommit;
1047 local $FS::UID::AutoCommit = 0;
1050 my $queue = new FS::queue {
1051 'svcnum' => $self->svcnum,
1052 'job' => 'FS::svc_acct::append_fuzzyfiles'
1054 my $error = $queue->insert($self->username);
1056 $dbh->rollback if $oldAutoCommit;
1057 return "queueing job (transaction rolled back): $error";
1060 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1068 Suspends this account by calling export-specific suspend hooks. If there is
1069 an error, returns the error, otherwise returns false.
1071 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1077 return "can't suspend system account" if $self->_check_system;
1078 $self->SUPER::suspend(@_);
1083 Unsuspends this account by by calling export-specific suspend hooks. If there
1084 is an error, returns the error, otherwise returns false.
1086 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1092 my %hash = $self->hash;
1093 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1094 $hash{_password} = $1;
1095 my $new = new FS::svc_acct ( \%hash );
1096 my $error = $new->replace($self);
1097 return $error if $error;
1100 $self->SUPER::unsuspend(@_);
1105 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1107 If the B<auto_unset_catchall> configuration option is set, this method will
1108 automatically remove any references to the canceled service in the catchall
1109 field of svc_domain. This allows packages that contain both a svc_domain and
1110 its catchall svc_acct to be canceled in one step.
1115 # Only one thing to do at this level
1117 foreach my $svc_domain (
1118 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1119 if($conf->exists('auto_unset_catchall')) {
1120 my %hash = $svc_domain->hash;
1121 $hash{catchall} = '';
1122 my $new = new FS::svc_domain ( \%hash );
1123 my $error = $new->replace($svc_domain);
1124 return $error if $error;
1126 return "cannot unprovision svc_acct #".$self->svcnum.
1127 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1131 $self->SUPER::cancel(@_);
1137 Checks all fields to make sure this is a valid service. If there is an error,
1138 returns the error, otherwise returns false. Called by the insert and replace
1141 Sets any fixed values; see L<FS::part_svc>.
1148 my($recref) = $self->hashref;
1150 my $x = $self->setfixed;
1151 return $x unless ref($x);
1154 my $error = $self->ut_numbern('svcnum')
1155 #|| $self->ut_number('domsvc')
1156 || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1157 || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' )
1158 || $self->ut_foreign_keyn('sectornum','tower_sector','sectornum')
1159 || $self->ut_foreign_keyn('routernum','router','routernum')
1160 || $self->ut_foreign_keyn('blocknum','addr_block','blocknum')
1161 || $self->ut_textn('sec_phrase')
1162 || $self->ut_snumbern('seconds')
1163 || $self->ut_snumbern('upbytes')
1164 || $self->ut_snumbern('downbytes')
1165 || $self->ut_snumbern('totalbytes')
1166 || $self->ut_snumbern('seconds_threshold')
1167 || $self->ut_snumbern('upbytes_threshold')
1168 || $self->ut_snumbern('downbytes_threshold')
1169 || $self->ut_snumbern('totalbytes_threshold')
1170 || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1171 || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1172 || $self->ut_enum('password_recover', [ '', 'Y' ])
1174 || $self->ut_anything('cf_privatekey')
1176 || $self->ut_textn('cgp_accessmodes')
1177 || $self->ut_alphan('cgp_type')
1178 || $self->ut_textn('cgp_aliases' ) #well
1180 || $self->ut_alphasn('cgp_rulesallowed')
1181 || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1182 || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1183 || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1184 || $self->ut_snumbern('cgp_archiveafter')
1186 || $self->ut_alphasn('cgp_deletemode')
1187 || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1188 || $self->ut_alphan('cgp_language')
1189 || $self->ut_textn('cgp_timezone')
1190 || $self->ut_textn('cgp_skinname')
1191 || $self->ut_textn('cgp_prontoskinname')
1192 || $self->ut_alphan('cgp_sendmdnmode')
1194 return $error if $error;
1196 # assign IP address, etc.
1197 if ( $conf->exists('svc_acct-ip_addr') ) {
1198 my $error = $self->svc_ip_check;
1199 return $error if $error;
1200 } else { # I think this is correct
1201 $self->routernum('');
1202 $self->blocknum('');
1206 local $username_letter = $username_letter;
1207 local $username_uppercase = $username_uppercase;
1208 if ($self->svcnum) {
1209 my $cust_svc = $self->cust_svc
1210 or return "no cust_svc record found for svcnum ". $self->svcnum;
1211 my $cust_pkg = $cust_svc->cust_pkg;
1213 if ($self->pkgnum) {
1214 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1218 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1219 $username_uppercase =
1220 $conf->exists('username-uppercase', $cust_pkg->cust_main->agentnum);
1223 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1225 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#\!]{$usernamemin,$ulen})$/i
1226 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1227 $recref->{username} = $1;
1229 my $uerror = gettext('illegal_username'). ': '. $recref->{username};
1231 unless ( $username_uppercase ) {
1232 $recref->{username} =~ /[A-Z]/ and return $uerror;
1234 if ( $username_letterfirst ) {
1235 $recref->{username} =~ /^[a-z]/ or return $uerror;
1236 } elsif ( $username_letter ) {
1237 $recref->{username} =~ /[a-z]/ or return $uerror;
1239 if ( $username_noperiod ) {
1240 $recref->{username} =~ /\./ and return $uerror;
1242 if ( $username_nounderscore ) {
1243 $recref->{username} =~ /_/ and return $uerror;
1245 if ( $username_nodash ) {
1246 $recref->{username} =~ /\-/ and return $uerror;
1248 unless ( $username_ampersand ) {
1249 $recref->{username} =~ /\&/ and return $uerror;
1251 unless ( $username_percent ) {
1252 $recref->{username} =~ /\%/ and return $uerror;
1254 unless ( $username_colon ) {
1255 $recref->{username} =~ /\:/ and return $uerror;
1257 unless ( $username_slash ) {
1258 $recref->{username} =~ /\// and return $uerror;
1260 unless ( $username_equals ) {
1261 $recref->{username} =~ /\=/ and return $uerror;
1263 unless ( $username_pound ) {
1264 $recref->{username} =~ /\#/ and return $uerror;
1266 unless ( $username_exclamation ) {
1267 $recref->{username} =~ /\!/ and return $uerror;
1271 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1272 $recref->{popnum} = $1;
1273 return "Unknown popnum" unless
1274 ! $recref->{popnum} ||
1275 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1277 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1279 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1280 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1282 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1283 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1284 #not all systems use gid=uid
1285 #you can set a fixed gid in part_svc
1287 return "Only root can have uid 0"
1288 if $recref->{uid} == 0
1289 && $recref->{username} !~ /^(root|toor|smtp)$/;
1291 unless ( $recref->{username} eq 'sync' ) {
1292 if ( grep $_ eq $recref->{shell}, @shells ) {
1293 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1295 return "Illegal shell \`". $self->shell. "\'; ".
1296 "shells configuration value contains: @shells";
1299 $recref->{shell} = '/bin/sync';
1303 $recref->{gid} ne '' ?
1304 return "Can't have gid without uid" : ( $recref->{gid}='' );
1305 #$recref->{dir} ne '' ?
1306 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1307 $recref->{shell} ne '' ?
1308 return "Can't have shell without uid" : ( $recref->{shell}='' );
1311 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1313 $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1314 or return "Illegal directory: ". $recref->{dir};
1315 $recref->{dir} = $1;
1316 return "Illegal directory"
1317 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1318 return "Illegal directory"
1319 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1320 unless ( $recref->{dir} ) {
1321 $recref->{dir} = $dir_prefix . '/';
1322 if ( $dirhash > 0 ) {
1323 for my $h ( 1 .. $dirhash ) {
1324 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1326 } elsif ( $dirhash < 0 ) {
1327 for my $h ( reverse $dirhash .. -1 ) {
1328 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1331 $recref->{dir} .= $recref->{username};
1337 if ( $self->getfield('finger') eq '' ) {
1338 my $cust_pkg = $self->svcnum
1339 ? $self->cust_svc->cust_pkg
1340 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1342 my $cust_main = $cust_pkg->cust_main;
1343 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1346 # $error = $self->ut_textn('finger');
1347 # return $error if $error;
1348 $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]*)$/
1349 or return "Illegal finger: ". $self->getfield('finger');
1350 $self->setfield('finger', $1);
1352 for (qw( quota file_quota file_maxsize )) {
1353 $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1356 $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1357 $recref->{file_maxnum} = $1;
1359 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1360 if ( $recref->{slipip} eq '' ) {
1361 $recref->{slipip} = ''; # eh?
1362 } elsif ( $recref->{slipip} eq '0e0' ) {
1363 $recref->{slipip} = '0e0';
1365 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1366 or return "Illegal slipip: ". $self->slipip;
1367 $recref->{slipip} = $1;
1371 #arbitrary RADIUS stuff; allow ut_textn for now
1372 foreach ( grep /^radius_/, fields('svc_acct') ) {
1373 $self->ut_textn($_);
1376 # First, if _password is blank, generate one and set default encoding.
1377 if ( ! $recref->{_password} ) {
1378 $error = $self->set_password('');
1380 # But if there's a _password but no encoding, assume it's plaintext and
1381 # set it to default encoding.
1382 elsif ( ! $recref->{_password_encoding} ) {
1383 $error = $self->set_password($recref->{_password});
1385 return $error if $error;
1387 # Next, check _password to ensure compliance with the encoding.
1388 if ( $recref->{_password_encoding} eq 'ldap' ) {
1390 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1391 $recref->{_password} = uc($1).$2;
1393 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1396 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1398 if ( $recref->{_password} =~
1399 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1400 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1403 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1406 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1409 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1410 # Password randomization is now in set_password.
1411 # Strip whitespace characters, check length requirements, etc.
1412 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1413 $recref->{_password} = $1;
1415 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1416 FS::Msgcat::_gettext('illegal_password_characters').
1417 ": ". $recref->{_password};
1420 if ( $password_noampersand ) {
1421 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1423 if ( $password_noexclamation ) {
1424 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1428 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1431 $self->SUPER::check;
1436 sub _password_encryption {
1438 my $encoding = lc($self->_password_encoding);
1439 return if !$encoding;
1440 return 'plain' if $encoding eq 'plain';
1441 if($encoding eq 'crypt') {
1442 my $pass = $self->_password;
1443 $pass =~ s/^\*SUSPENDED\* //;
1445 return 'md5' if $pass =~ /^\$1\$/;
1446 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1447 return 'des' if length($pass) == 13;
1450 if($encoding eq 'ldap') {
1451 uc($self->_password) =~ /^\{([\w-]+)\}/;
1452 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1453 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1454 return 'md5' if $1 eq 'MD5';
1455 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1462 sub get_cleartext_password {
1464 if($self->_password_encryption eq 'plain') {
1465 if($self->_password_encoding eq 'ldap') {
1466 $self->_password =~ /\{\w+\}(.*)$/;
1470 return $self->_password;
1479 Set the cleartext password for the account. If _password_encoding is set, the
1480 new password will be encoded according to the existing method (including
1481 encryption mode, if it can be determined). Otherwise,
1482 config('default-password-encoding') is used.
1484 If no password is supplied (or a zero-length password when minimum password length
1485 is >0), one will be generated randomly.
1490 my( $self, $pass ) = ( shift, shift );
1492 warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1495 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1496 FS::Msgcat::_gettext('illegal_password_characters').
1499 my( $encoding, $encryption ) = ('', '');
1501 if ( $self->_password_encoding ) {
1502 $encoding = $self->_password_encoding;
1503 # identify existing encryption method, try to use it.
1504 $encryption = $self->_password_encryption;
1506 # use the system default
1512 # set encoding to system default
1513 ($encoding, $encryption) =
1514 split(/-/, lc($conf->config('default-password-encoding') || ''));
1515 $encoding ||= 'legacy';
1516 $self->_password_encoding($encoding);
1519 if ( $encoding eq 'legacy' ) {
1521 # The legacy behavior from check():
1522 # If the password is blank, randomize it and set encoding to 'plain'.
1523 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1524 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1525 $self->_password_encoding('plain');
1527 # Prefix + valid-length password
1528 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1530 $self->_password_encoding('plain');
1531 # Prefix + crypt string
1532 } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1534 $self->_password_encoding('crypt');
1535 # Various disabled crypt passwords
1536 } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1537 $self->_password_encoding('crypt');
1543 $self->_password($pass);
1549 if $passwordmin && length($pass) < $passwordmin
1550 or $passwordmax && length($pass) > $passwordmax;
1552 if ( $encoding eq 'crypt' ) {
1553 if ($encryption eq 'md5') {
1554 $pass = unix_md5_crypt($pass);
1555 } elsif ($encryption eq 'des') {
1556 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1559 } elsif ( $encoding eq 'ldap' ) {
1560 if ($encryption eq 'md5') {
1561 $pass = md5_base64($pass);
1562 } elsif ($encryption eq 'sha1') {
1563 $pass = sha1_base64($pass);
1564 } elsif ($encryption eq 'crypt') {
1565 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1567 # else $encryption eq 'plain', do nothing
1568 $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1569 if $encryption eq 'md5' || $encryption eq 'sha1';
1570 $pass = '{'.uc($encryption).'}'.$pass;
1572 # else encoding eq 'plain'
1574 $self->_password($pass);
1580 Internal function to check the username against the list of system usernames
1581 from the I<system_usernames> configuration value. Returns true if the username
1582 is listed on the system username list.
1588 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1589 $conf->config('system_usernames')
1593 =item _check_duplicate
1595 Internal method to check for duplicates usernames, username@domain pairs and
1598 If the I<global_unique-username> configuration value is set to B<username> or
1599 B<username@domain>, enforces global username or username@domain uniqueness.
1601 In all cases, check for duplicate uids and usernames or username@domain pairs
1602 per export and with identical I<svcpart> values.
1606 sub _check_duplicate {
1609 my $global_unique = $conf->config('global_unique-username') || 'none';
1610 return '' if $global_unique eq 'disabled';
1614 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1615 unless ( $part_svc ) {
1616 return 'unknown svcpart '. $self->svcpart;
1619 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1620 qsearch( 'svc_acct', { 'username' => $self->username } );
1621 return gettext('username_in_use')
1622 if $global_unique eq 'username' && @dup_user;
1624 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1625 qsearch( 'svc_acct', { 'username' => $self->username,
1626 'domsvc' => $self->domsvc } );
1627 return gettext('username_in_use')
1628 if $global_unique eq 'username@domain' && @dup_userdomain;
1631 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1632 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1633 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1634 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1639 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1640 my $exports = FS::part_export::export_info('svc_acct');
1641 my %conflict_user_svcpart;
1642 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1644 foreach my $part_export ( $part_svc->part_export ) {
1646 #this will catch to the same exact export
1647 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1649 #this will catch to exports w/same exporthost+type ???
1650 #my @other_part_export = qsearch('part_export', {
1651 # 'machine' => $part_export->machine,
1652 # 'exporttype' => $part_export->exporttype,
1654 #foreach my $other_part_export ( @other_part_export ) {
1655 # push @svcparts, map { $_->svcpart }
1656 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1659 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1660 #silly kludge to avoid uninitialized value errors
1661 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1662 ? $exports->{$part_export->exporttype}{'nodomain'}
1664 if ( $nodomain =~ /^Y/i ) {
1665 $conflict_user_svcpart{$_} = $part_export->exportnum
1668 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1673 foreach my $dup_user ( @dup_user ) {
1674 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1675 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1676 return "duplicate username ". $self->username.
1677 ": conflicts with svcnum ". $dup_user->svcnum.
1678 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1682 foreach my $dup_userdomain ( @dup_userdomain ) {
1683 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1684 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1685 return "duplicate username\@domain ". $self->email.
1686 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1687 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1691 foreach my $dup_uid ( @dup_uid ) {
1692 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1693 if ( exists($conflict_user_svcpart{$dup_svcpart})
1694 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1695 return "duplicate uid ". $self->uid.
1696 ": conflicts with svcnum ". $dup_uid->svcnum.
1698 ( $conflict_user_svcpart{$dup_svcpart}
1699 || $conflict_userdomain_svcpart{$dup_svcpart} );
1711 Depriciated, use radius_reply instead.
1716 carp "FS::svc_acct::radius depriciated, use radius_reply";
1717 $_[0]->radius_reply;
1722 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1723 reply attributes of this record.
1725 Note that this is now the preferred method for reading RADIUS attributes -
1726 accessing the columns directly is discouraged, as the column names are
1727 expected to change in the future.
1734 return %{ $self->{'radius_reply'} }
1735 if exists $self->{'radius_reply'};
1740 my($column, $attrib) = ($1, $2);
1741 #$attrib =~ s/_/\-/g;
1742 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1743 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1745 if ( $self->slipip && $self->slipip ne '0e0' ) {
1746 $reply{$radius_ip} = $self->slipip;
1749 if ( $self->seconds !~ /^$/ ) {
1750 $reply{'Session-Timeout'} = $self->seconds;
1753 if ( $conf->exists('radius-chillispot-max') ) {
1754 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1756 #hmm. just because sqlradius.pm says so?
1763 foreach my $what (qw( input output total )) {
1764 my $is = $whatis{$what}.'bytes';
1765 if ( $self->$is() =~ /\d/ ) {
1766 my $big = new Math::BigInt $self->$is();
1767 $big = new Math::BigInt '0' if $big->is_neg();
1768 my $att = "Chillispot-Max-\u$what";
1769 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1770 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1781 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1782 check attributes of this record.
1784 Note that this is now the preferred method for reading RADIUS attributes -
1785 accessing the columns directly is discouraged, as the column names are
1786 expected to change in the future.
1793 return %{ $self->{'radius_check'} }
1794 if exists $self->{'radius_check'};
1799 my($column, $attrib) = ($1, $2);
1800 #$attrib =~ s/_/\-/g;
1801 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1802 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1805 my($pw_attrib, $password) = $self->radius_password;
1806 $check{$pw_attrib} = $password;
1808 my $cust_svc = $self->cust_svc;
1810 my $cust_pkg = $cust_svc->cust_pkg;
1811 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1812 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1815 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1816 "; can't set Expiration\n"
1824 =item radius_password
1826 Returns a key/value pair containing the RADIUS attribute name and value
1831 sub radius_password {
1835 if ( $self->_password_encoding eq 'ldap' ) {
1836 $pw_attrib = 'Password-With-Header';
1837 } elsif ( $self->_password_encoding eq 'crypt' ) {
1838 $pw_attrib = 'Crypt-Password';
1839 } elsif ( $self->_password_encoding eq 'plain' ) {
1840 $pw_attrib = $radius_password;
1842 $pw_attrib = length($self->_password) <= 12
1847 ($pw_attrib, $self->_password);
1853 This method instructs the object to "snapshot" or freeze RADIUS check and
1854 reply attributes to the current values.
1858 #bah, my english is too broken this morning
1859 #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
1860 #the FS::cust_pkg's replace method to trigger the correct export updates when
1861 #package dates change)
1866 $self->{$_} = { $self->$_() }
1867 foreach qw( radius_reply radius_check );
1871 =item forget_snapshot
1873 This methos instructs the object to forget any previously snapshotted
1874 RADIUS check and reply attributes.
1878 sub forget_snapshot {
1882 foreach qw( radius_reply radius_check );
1886 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1888 Returns the domain associated with this account.
1890 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1897 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1898 my $svc_domain = $self->svc_domain(@_)
1899 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1900 $svc_domain->domain;
1905 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1909 #inherited from svc_Common
1911 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1913 Returns an email address associated with the account.
1915 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1922 $self->username. '@'. $self->domain(@_);
1928 Returns an array of FS::acct_snarf records associated with the account.
1932 # unused as originally intended, but now by Communigate Pro "RPOP"
1936 'table' => 'acct_snarf',
1937 'hashref' => { 'svcnum' => $self->svcnum },
1938 #'order_by' => 'ORDER BY priority ASC',
1942 =item cgp_rpop_hashref
1944 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1948 sub cgp_rpop_hashref {
1950 { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1953 =item decrement_upbytes OCTETS
1955 Decrements the I<upbytes> field of this record by the given amount. If there
1956 is an error, returns the error, otherwise returns false.
1960 sub decrement_upbytes {
1961 shift->_op_usage('-', 'upbytes', @_);
1964 =item increment_upbytes OCTETS
1966 Increments the I<upbytes> field of this record by the given amount. If there
1967 is an error, returns the error, otherwise returns false.
1971 sub increment_upbytes {
1972 shift->_op_usage('+', 'upbytes', @_);
1975 =item decrement_downbytes OCTETS
1977 Decrements the I<downbytes> field of this record by the given amount. If there
1978 is an error, returns the error, otherwise returns false.
1982 sub decrement_downbytes {
1983 shift->_op_usage('-', 'downbytes', @_);
1986 =item increment_downbytes OCTETS
1988 Increments the I<downbytes> field of this record by the given amount. If there
1989 is an error, returns the error, otherwise returns false.
1993 sub increment_downbytes {
1994 shift->_op_usage('+', 'downbytes', @_);
1997 =item decrement_totalbytes OCTETS
1999 Decrements the I<totalbytes> field of this record by the given amount. If there
2000 is an error, returns the error, otherwise returns false.
2004 sub decrement_totalbytes {
2005 shift->_op_usage('-', 'totalbytes', @_);
2008 =item increment_totalbytes OCTETS
2010 Increments the I<totalbytes> field of this record by the given amount. If there
2011 is an error, returns the error, otherwise returns false.
2015 sub increment_totalbytes {
2016 shift->_op_usage('+', 'totalbytes', @_);
2019 =item decrement_seconds SECONDS
2021 Decrements the I<seconds> field of this record by the given amount. If there
2022 is an error, returns the error, otherwise returns false.
2026 sub decrement_seconds {
2027 shift->_op_usage('-', 'seconds', @_);
2030 =item increment_seconds SECONDS
2032 Increments the I<seconds> field of this record by the given amount. If there
2033 is an error, returns the error, otherwise returns false.
2037 sub increment_seconds {
2038 shift->_op_usage('+', 'seconds', @_);
2046 my %op2condition = (
2047 '-' => sub { my($self, $column, $amount) = @_;
2048 $self->$column - $amount <= 0;
2050 '+' => sub { my($self, $column, $amount) = @_;
2051 ($self->$column || 0) + $amount > 0;
2054 my %op2warncondition = (
2055 '-' => sub { my($self, $column, $amount) = @_;
2056 my $threshold = $column . '_threshold';
2057 $self->$column - $amount <= $self->$threshold + 0;
2059 '+' => sub { my($self, $column, $amount) = @_;
2060 ($self->$column || 0) + $amount > 0;
2065 my( $self, $op, $column, $amount ) = @_;
2067 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2068 ' ('. $self->email. "): $op $amount\n"
2071 return '' unless $amount;
2073 local $SIG{HUP} = 'IGNORE';
2074 local $SIG{INT} = 'IGNORE';
2075 local $SIG{QUIT} = 'IGNORE';
2076 local $SIG{TERM} = 'IGNORE';
2077 local $SIG{TSTP} = 'IGNORE';
2078 local $SIG{PIPE} = 'IGNORE';
2080 my $oldAutoCommit = $FS::UID::AutoCommit;
2081 local $FS::UID::AutoCommit = 0;
2084 my $sql = "UPDATE svc_acct SET $column = ".
2085 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2086 " $op ? WHERE svcnum = ?";
2090 my $sth = $dbh->prepare( $sql )
2091 or die "Error preparing $sql: ". $dbh->errstr;
2092 my $rv = $sth->execute($amount, $self->svcnum);
2093 die "Error executing $sql: ". $sth->errstr
2094 unless defined($rv);
2095 die "Can't update $column for svcnum". $self->svcnum
2098 #$self->snapshot; #not necessary, we retain the old values
2099 #create an object with the updated usage values
2100 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2102 my $error = $new->replace($self);
2104 $dbh->rollback if $oldAutoCommit;
2105 return "Error replacing: $error";
2108 #overlimit_action eq 'cancel' handling
2109 my $cust_pkg = $self->cust_svc->cust_pkg;
2111 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2112 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2116 my $error = $cust_pkg->cancel; #XXX should have a reason
2118 $dbh->rollback if $oldAutoCommit;
2119 return "Error cancelling: $error";
2122 #nothing else is relevant if we're cancelling, so commit & return success
2123 warn "$me update successful; committing\n"
2125 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2130 my $action = $op2action{$op};
2132 if ( &{$op2condition{$op}}($self, $column, $amount) &&
2133 ( $action eq 'suspend' && !$self->overlimit
2134 || $action eq 'unsuspend' && $self->overlimit )
2137 my $error = $self->_op_overlimit($action);
2139 $dbh->rollback if $oldAutoCommit;
2145 if ( $conf->exists("svc_acct-usage_$action")
2146 && &{$op2condition{$op}}($self, $column, $amount) ) {
2147 #my $error = $self->$action();
2148 my $error = $self->cust_svc->cust_pkg->$action();
2149 # $error ||= $self->overlimit($action);
2151 $dbh->rollback if $oldAutoCommit;
2152 return "Error ${action}ing: $error";
2156 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2157 my $wqueue = new FS::queue {
2158 'svcnum' => $self->svcnum,
2159 'job' => 'FS::svc_acct::reached_threshold',
2164 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2168 my $error = $wqueue->insert(
2169 'svcnum' => $self->svcnum,
2171 'column' => $column,
2175 $dbh->rollback if $oldAutoCommit;
2176 return "Error queuing threshold activity: $error";
2180 warn "$me update successful; committing\n"
2182 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2188 my( $self, $action ) = @_;
2190 local $SIG{HUP} = 'IGNORE';
2191 local $SIG{INT} = 'IGNORE';
2192 local $SIG{QUIT} = 'IGNORE';
2193 local $SIG{TERM} = 'IGNORE';
2194 local $SIG{TSTP} = 'IGNORE';
2195 local $SIG{PIPE} = 'IGNORE';
2197 my $oldAutoCommit = $FS::UID::AutoCommit;
2198 local $FS::UID::AutoCommit = 0;
2201 my $cust_pkg = $self->cust_svc->cust_pkg;
2203 my @conf_overlimit =
2205 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2206 : $conf->config('overlimit_groups');
2208 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2210 my @groups = scalar(@conf_overlimit) ? @conf_overlimit
2211 : split(' ',$part_export->option('overlimit_groups'));
2212 next unless scalar(@groups);
2214 my $other = new FS::svc_acct $self->hashref;
2215 $other->usergroup(\@groups);
2218 if ($action eq 'suspend') {
2221 } else { # $action eq 'unsuspend'
2226 my $error = $part_export->export_replace($new, $old)
2227 || $self->overlimit($action);
2230 $dbh->rollback if $oldAutoCommit;
2231 return "Error replacing radius groups: $error";
2236 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2242 my( $self, $valueref, %options ) = @_;
2244 warn "$me set_usage called for svcnum ". $self->svcnum.
2245 ' ('. $self->email. "): ".
2246 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2249 local $SIG{HUP} = 'IGNORE';
2250 local $SIG{INT} = 'IGNORE';
2251 local $SIG{QUIT} = 'IGNORE';
2252 local $SIG{TERM} = 'IGNORE';
2253 local $SIG{TSTP} = 'IGNORE';
2254 local $SIG{PIPE} = 'IGNORE';
2256 local $FS::svc_Common::noexport_hack = 1;
2257 my $oldAutoCommit = $FS::UID::AutoCommit;
2258 local $FS::UID::AutoCommit = 0;
2263 if ( $options{null} ) {
2264 %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2265 qw( seconds upbytes downbytes totalbytes )
2268 foreach my $field (keys %$valueref){
2269 $reset = 1 if $valueref->{$field};
2270 $self->setfield($field, $valueref->{$field});
2271 $self->setfield( $field.'_threshold',
2272 int($self->getfield($field)
2273 * ( $conf->exists('svc_acct-usage_threshold')
2274 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2279 $handyhash{$field} = $self->getfield($field);
2280 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2282 #my $error = $self->replace; #NO! we avoid the call to ->check for
2283 #die $error if $error; #services not explicity changed via the UI
2285 my $sql = "UPDATE svc_acct SET " .
2286 join (',', map { "$_ = ?" } (keys %handyhash) ).
2287 " WHERE svcnum = ". $self->svcnum;
2292 if (scalar(keys %handyhash)) {
2293 my $sth = $dbh->prepare( $sql )
2294 or die "Error preparing $sql: ". $dbh->errstr;
2295 my $rv = $sth->execute(values %handyhash);
2296 die "Error executing $sql: ". $sth->errstr
2297 unless defined($rv);
2298 die "Can't update usage for svcnum ". $self->svcnum
2302 #$self->snapshot; #not necessary, we retain the old values
2303 #create an object with the updated usage values
2304 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2305 local($FS::Record::nowarn_identical) = 1;
2306 my $error = $new->replace($self); #call exports
2308 $dbh->rollback if $oldAutoCommit;
2309 return "Error replacing: $error";
2316 $error = $self->_op_overlimit('unsuspend')
2317 if $self->overlimit;;
2319 $error ||= $self->cust_svc->cust_pkg->unsuspend
2320 if $conf->exists("svc_acct-usage_unsuspend");
2323 $dbh->rollback if $oldAutoCommit;
2324 return "Error unsuspending: $error";
2329 warn "$me update successful; committing\n"
2331 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2337 =item recharge HASHREF
2339 Increments usage columns by the amount specified in HASHREF as
2340 column=>amount pairs.
2345 my ($self, $vhash) = @_;
2348 warn "[$me] recharge called on $self: ". Dumper($self).
2349 "\nwith vhash: ". Dumper($vhash);
2352 my $oldAutoCommit = $FS::UID::AutoCommit;
2353 local $FS::UID::AutoCommit = 0;
2357 foreach my $column (keys %$vhash){
2358 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2362 $dbh->rollback if $oldAutoCommit;
2364 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2369 =item is_rechargeable
2371 Returns true if this svc_account can be "recharged" and false otherwise.
2375 sub is_rechargable {
2377 $self->seconds ne ''
2378 || $self->upbytes ne ''
2379 || $self->downbytes ne ''
2380 || $self->totalbytes ne '';
2383 =item seconds_since TIMESTAMP
2385 Returns the number of seconds this account has been online since TIMESTAMP,
2386 according to the session monitor (see L<FS::Session>).
2388 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2389 L<Time::Local> and L<Date::Parse> for conversion functions.
2393 #note: POD here, implementation in FS::cust_svc
2396 $self->cust_svc->seconds_since(@_);
2399 =item last_login_text
2401 Returns text describing the time of last login.
2405 sub last_login_text {
2407 $self->last_login ? ctime($self->last_login) : 'unknown';
2410 =item psearch_cdrs OPTIONS
2412 Returns a paged search (L<FS::PagedSearch>) for Call Detail Records
2413 associated with this service. For svc_acct, "associated with" means that
2414 either the "src" or the "charged_party" field of the CDR matches either
2415 the "username" field of the service or the username@domain label.
2420 my($self, %options) = @_;
2425 my $did = dbh->quote($self->username);
2426 my $diddomain = dbh->quote($self->label);
2428 my $prefix = $options{'default_prefix'} || ''; #convergent.au '+61'
2429 my $prefixdid = dbh->quote($prefix . $self->username);
2431 my $for_update = $options{'for_update'} ? 'FOR UPDATE' : '';
2433 if ( $options{inbound} ) {
2434 # these will be selected under their DIDs
2435 push @where, "FALSE";
2439 if (!$options{'disable_charged_party'}) {
2441 "charged_party = $did",
2442 "charged_party = $prefixdid",
2443 "charged_party = $diddomain"
2446 if (!$options{'disable_src'}) {
2448 "src = $did AND charged_party IS NULL",
2449 "src = $prefixdid AND charged_party IS NULL",
2450 "src = $diddomain AND charged_party IS NULL"
2453 push @where, '(' . join(' OR ', @orwhere) . ')';
2455 # $options{'status'} = '' is meaningful; for the rest of them it's not
2456 if ( exists $options{'status'} ) {
2457 $hash{'freesidestatus'} = $options{'status'};
2459 if ( $options{'cdrtypenum'} ) {
2460 $hash{'cdrtypenum'} = $options{'cdrtypenum'};
2462 if ( $options{'calltypenum'} ) {
2463 $hash{'calltypenum'} = $options{'calltypenum'};
2465 if ( $options{'begin'} ) {
2466 push @where, 'startdate >= '. $options{'begin'};
2468 if ( $options{'end'} ) {
2469 push @where, 'startdate < '. $options{'end'};
2471 if ( $options{'nonzero'} ) {
2472 push @where, 'duration > 0';
2475 my $extra_sql = join(' AND ', @where);
2478 $extra_sql = " AND ".$extra_sql;
2480 $extra_sql = " WHERE ".$extra_sql;
2486 'hashref' => \%hash,
2487 'extra_sql' => $extra_sql,
2488 'order_by' => "ORDER BY startdate $for_update",
2492 =item get_cdrs (DEPRECATED)
2494 Like psearch_cdrs, but returns all the L<FS::cdr> objects at once, in a
2495 single list. Arguments are the same as for psearch_cdrs.
2501 my $psearch = $self->psearch_cdrs(@_);
2502 qsearch ( $psearch->{query} )
2505 # sub radius_groups has moved to svc_Radius_Mixin
2507 =item clone_suspended
2509 Constructor used by FS::part_export::_export_suspend fallback. Document
2514 sub clone_suspended {
2516 my %hash = $self->hash;
2517 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2518 new FS::svc_acct \%hash;
2521 =item clone_kludge_unsuspend
2523 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2528 sub clone_kludge_unsuspend {
2530 my %hash = $self->hash;
2531 $hash{_password} = '';
2532 new FS::svc_acct \%hash;
2535 =item check_password
2537 Checks the supplied password against the (possibly encrypted) password in the
2538 database. Returns true for a successful authentication, false for no match.
2540 Currently supported encryptions are: classic DES crypt() and MD5
2544 sub check_password {
2545 my($self, $check_password) = @_;
2547 #remove old-style SUSPENDED kludge, they should be allowed to login to
2548 #self-service and pay up
2549 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2551 if ( $self->_password_encoding eq 'ldap' ) {
2553 $password =~ s/^{PLAIN}/{CLEARTEXT}/;
2554 my $auth = from_rfc2307 Authen::Passphrase $password;
2555 return $auth->match($check_password);
2557 } elsif ( $self->_password_encoding eq 'crypt' ) {
2559 my $auth = from_crypt Authen::Passphrase $self->_password;
2560 return $auth->match($check_password);
2562 } elsif ( $self->_password_encoding eq 'plain' ) {
2564 return $check_password eq $password;
2568 #XXX this could be replaced with Authen::Passphrase stuff
2570 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2572 } elsif ( length($password) < 13 ) { #plaintext
2573 $check_password eq $password;
2574 } elsif ( length($password) == 13 ) { #traditional DES crypt
2575 crypt($check_password, $password) eq $password;
2576 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2577 unix_md5_crypt($check_password, $password) eq $password;
2578 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2579 warn "Can't check password: Blowfish encryption not yet supported, ".
2580 "svcnum ". $self->svcnum. "\n";
2583 warn "Can't check password: Unrecognized encryption for svcnum ".
2584 $self->svcnum. "\n";
2592 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2594 Returns an encrypted password, either by passing through an encrypted password
2595 in the database or by encrypting a plaintext password from the database.
2597 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2598 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2599 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2600 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2601 encryption type is only used if the password is not already encrypted in the
2606 sub crypt_password {
2609 if ( $self->_password_encoding eq 'ldap' ) {
2611 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2614 #XXX this could be replaced with Authen::Passphrase stuff
2616 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2617 if ( $encryption eq 'crypt' ) {
2620 $saltset[int(rand(64))].$saltset[int(rand(64))]
2622 } elsif ( $encryption eq 'md5' ) {
2623 return unix_md5_crypt( $self->_password );
2624 } elsif ( $encryption eq 'blowfish' ) {
2625 croak "unknown encryption method $encryption";
2627 croak "unknown encryption method $encryption";
2630 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2634 } elsif ( $self->_password_encoding eq 'crypt' ) {
2636 return $self->_password;
2638 } elsif ( $self->_password_encoding eq 'plain' ) {
2640 #XXX this could be replaced with Authen::Passphrase stuff
2642 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2643 if ( $encryption eq 'crypt' ) {
2646 $saltset[int(rand(64))].$saltset[int(rand(64))]
2648 } elsif ( $encryption eq 'md5' ) {
2649 return unix_md5_crypt( $self->_password );
2650 } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2651 my $pass = sha1_base64( $self->_password );
2652 $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2654 } elsif ( $encryption eq 'blowfish' ) {
2655 croak "unknown encryption method $encryption";
2657 croak "unknown encryption method $encryption";
2662 if ( length($self->_password) == 13
2663 || $self->_password =~ /^\$(1|2a?)\$/
2664 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2670 #XXX this could be replaced with Authen::Passphrase stuff
2672 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2673 if ( $encryption eq 'crypt' ) {
2676 $saltset[int(rand(64))].$saltset[int(rand(64))]
2678 } elsif ( $encryption eq 'md5' ) {
2679 return unix_md5_crypt( $self->_password );
2680 } elsif ( $encryption eq 'blowfish' ) {
2681 croak "unknown encryption method $encryption";
2683 croak "unknown encryption method $encryption";
2692 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2694 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2695 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2696 "{MD5}5426824942db4253f87a1009fd5d2d4".
2698 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2699 to work the same as the B</crypt_password> method.
2705 #eventually should check a "password-encoding" field
2707 if ( $self->_password_encoding eq 'ldap' ) {
2709 return $self->_password;
2711 } elsif ( $self->_password_encoding eq 'crypt' ) {
2713 if ( length($self->_password) == 13 ) { #crypt
2714 return '{CRYPT}'. $self->_password;
2715 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2717 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2718 # die "Blowfish encryption not supported in this context, svcnum ".
2719 # $self->svcnum. "\n";
2721 warn "encryption method not (yet?) supported in LDAP context";
2722 return '{CRYPT}*'; #unsupported, should not auth
2725 } elsif ( $self->_password_encoding eq 'plain' ) {
2727 return '{PLAIN}'. $self->_password;
2729 #return '{CLEARTEXT}'. $self->_password; #?
2733 if ( length($self->_password) == 13 ) { #crypt
2734 return '{CRYPT}'. $self->_password;
2735 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2737 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2738 warn "Blowfish encryption not supported in this context, svcnum ".
2739 $self->svcnum. "\n";
2742 #are these two necessary anymore?
2743 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2744 return '{SSHA}'. $1;
2745 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2746 return '{NS-MTA-MD5}'. $1;
2749 return '{PLAIN}'. $self->_password;
2751 #return '{CLEARTEXT}'. $self->_password; #?
2753 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2754 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2755 #if ( $encryption eq 'crypt' ) {
2756 # return '{CRYPT}'. crypt(
2758 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2760 #} elsif ( $encryption eq 'md5' ) {
2761 # unix_md5_crypt( $self->_password );
2762 #} elsif ( $encryption eq 'blowfish' ) {
2763 # croak "unknown encryption method $encryption";
2765 # croak "unknown encryption method $encryption";
2773 =item domain_slash_username
2775 Returns $domain/$username/
2779 sub domain_slash_username {
2781 $self->domain. '/'. $self->username. '/';
2784 =item virtual_maildir
2786 Returns $domain/maildirs/$username/
2790 sub virtual_maildir {
2792 $self->domain. '/maildirs/'. $self->username. '/';
2795 =item password_svc_check
2797 Override, for L<FS::Password_Mixin>. Not really intended for other use.
2801 sub password_svc_check {
2802 my ($self, $password) = @_;
2803 foreach my $field ( qw(username finger) ) {
2804 foreach my $word (split(/\W+/,$self->get($field))) {
2805 next unless length($word) > 2;
2806 if ($password =~ /$word/i) {
2807 return qq(Password contains account information '$word');
2816 =head1 CLASS METHODS
2820 =item search HASHREF
2822 Class method which returns a qsearch hash expression to search for parameters
2823 specified in HASHREF. Valid parameters are
2837 Arrayref of pkgparts
2843 Arrayref of additional WHERE clauses, will be ANDed together.
2854 my( $class, $params, $from, $where ) = @_;
2856 #these two should probably move to svc_Domain_Mixin ?
2859 if ( $params->{'domain'} ) {
2860 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2861 #preserve previous behavior & bubble up an error if $svc_domain not found?
2862 push @$where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2866 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2867 push @$where, "domsvc = $1";
2872 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2873 push @$where, "popnum = $1";
2877 #and these in svc_Tower_Mixin, or maybe we never should have done svc_acct
2878 # towers (or, as mark thought, never should have done svc_broadband)
2881 my @where_sector = $class->tower_sector_sql($params);
2882 if ( @where_sector ) {
2883 push @$where, @where_sector;
2884 push @$from, ' LEFT JOIN tower_sector USING ( sectornum )';
2897 This is the FS::svc_acct job-queue-able version. It still uses
2898 FS::Misc::send_email under-the-hood.
2905 eval "use FS::Misc qw(send_email)";
2908 $opt{mimetype} ||= 'text/plain';
2909 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2911 my $error = send_email(
2912 'from' => $opt{from},
2914 'subject' => $opt{subject},
2915 'content-type' => $opt{mimetype},
2916 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2918 die $error if $error;
2921 =item check_and_rebuild_fuzzyfiles
2925 sub check_and_rebuild_fuzzyfiles {
2926 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2927 -e "$dir/svc_acct.username"
2928 or &rebuild_fuzzyfiles;
2931 =item rebuild_fuzzyfiles
2935 sub rebuild_fuzzyfiles {
2937 use Fcntl qw(:flock);
2939 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2943 open(USERNAMELOCK,">>$dir/svc_acct.username")
2944 or die "can't open $dir/svc_acct.username: $!";
2945 flock(USERNAMELOCK,LOCK_EX)
2946 or die "can't lock $dir/svc_acct.username: $!";
2948 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2950 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2951 or die "can't open $dir/svc_acct.username.tmp: $!";
2952 print USERNAMECACHE join("\n", @all_username), "\n";
2953 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2955 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2965 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2966 open(USERNAMECACHE,"<$dir/svc_acct.username")
2967 or die "can't open $dir/svc_acct.username: $!";
2968 my @array = map { chomp; $_; } <USERNAMECACHE>;
2969 close USERNAMECACHE;
2973 =item append_fuzzyfiles USERNAME
2977 sub append_fuzzyfiles {
2978 my $username = shift;
2980 &check_and_rebuild_fuzzyfiles;
2982 use Fcntl qw(:flock);
2984 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2986 open(USERNAME,">>$dir/svc_acct.username")
2987 or die "can't open $dir/svc_acct.username: $!";
2988 flock(USERNAME,LOCK_EX)
2989 or die "can't lock $dir/svc_acct.username: $!";
2991 print USERNAME "$username\n";
2993 flock(USERNAME,LOCK_UN)
2994 or die "can't unlock $dir/svc_acct.username: $!";
3001 =item reached_threshold
3003 Performs some activities when svc_acct thresholds (such as number of seconds
3004 remaining) are reached.
3008 sub reached_threshold {
3011 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3012 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3014 if ( $opt{'op'} eq '+' ){
3015 $svc_acct->setfield( $opt{'column'}.'_threshold',
3016 int($svc_acct->getfield($opt{'column'})
3017 * ( $conf->exists('svc_acct-usage_threshold')
3018 ? $conf->config('svc_acct-usage_threshold')/100
3023 my $error = $svc_acct->replace;
3024 die $error if $error;
3025 }elsif ( $opt{'op'} eq '-' ){
3027 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3028 return '' if ($threshold eq '' );
3030 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3031 my $error = $svc_acct->replace;
3032 die $error if $error; # email next time, i guess
3034 if ( $warning_template ) {
3035 eval "use FS::Misc qw(send_email)";
3038 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
3039 my $cust_main = $cust_pkg->cust_main;
3041 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3042 $cust_main->invoicing_list,
3043 ($opt{'to'} ? $opt{'to'} : ())
3046 my $mimetype = $warning_mimetype;
3047 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3049 my $body = $warning_template->fill_in( HASH => {
3050 'custnum' => $cust_main->custnum,
3051 'username' => $svc_acct->username,
3052 'password' => $svc_acct->_password,
3053 'first' => $cust_main->first,
3054 'last' => $cust_main->getfield('last'),
3055 'pkg' => $cust_pkg->part_pkg->pkg,
3056 'column' => $opt{'column'},
3057 'amount' => $opt{'column'} =~/bytes/
3058 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3059 : $svc_acct->getfield($opt{'column'}),
3060 'threshold' => $opt{'column'} =~/bytes/
3061 ? FS::UI::bytecount::display_bytecount($threshold)
3066 my $error = send_email(
3067 'from' => $warning_from,
3069 'subject' => $warning_subject,
3070 'content-type' => $mimetype,
3071 'body' => [ map "$_\n", split("\n", $body) ],
3073 die $error if $error;
3076 die "unknown op: " . $opt{'op'};
3084 The $recref stuff in sub check should be cleaned up.
3086 The suspend, unsuspend and cancel methods update the database, but not the
3087 current object. This is probably a bug as it's unexpected and
3090 insertion of RADIUS group stuff in insert could be done with child_objects now
3091 (would probably clean up export of them too)
3093 _op_usage and set_usage bypass the history... maybe they shouldn't
3097 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3098 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3099 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3100 L<freeside-queued>), L<FS::svc_acct_pop>,
3101 schema.html from the base documentation.