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',
353 'routernum' => 'Router/block',
355 'label' => 'Address block',
357 'select_table' => 'addr_block',
358 'select_key' => 'blocknum',
359 'select_label' => 'cidr',
360 'disable_inventory' => 1,
363 label => 'RADIUS groups',
364 type => 'select-radius_group.html',
365 disable_inventory => 1,
369 'seconds' => { label => 'Seconds',
370 label_sort => 'with Time Remaining',
372 disable_inventory => 1,
374 disable_part_svc_column => 1,
376 'upbytes' => { label => 'Upload',
378 disable_inventory => 1,
380 'format' => \&FS::UI::bytecount::display_bytecount,
381 'parse' => \&FS::UI::bytecount::parse_bytecount,
382 disable_part_svc_column => 1,
384 'downbytes' => { label => 'Download',
386 disable_inventory => 1,
388 'format' => \&FS::UI::bytecount::display_bytecount,
389 'parse' => \&FS::UI::bytecount::parse_bytecount,
390 disable_part_svc_column => 1,
392 'totalbytes'=> { label => 'Total up and download',
394 disable_inventory => 1,
396 'format' => \&FS::UI::bytecount::display_bytecount,
397 'parse' => \&FS::UI::bytecount::parse_bytecount,
398 disable_part_svc_column => 1,
400 'seconds_threshold' => { label => 'Seconds threshold',
402 disable_inventory => 1,
404 disable_part_svc_column => 1,
406 'upbytes_threshold' => { label => 'Upload threshold',
408 disable_inventory => 1,
410 'format' => \&FS::UI::bytecount::display_bytecount,
411 'parse' => \&FS::UI::bytecount::parse_bytecount,
412 disable_part_svc_column => 1,
414 'downbytes_threshold' => { label => 'Download threshold',
416 disable_inventory => 1,
418 'format' => \&FS::UI::bytecount::display_bytecount,
419 'parse' => \&FS::UI::bytecount::parse_bytecount,
420 disable_part_svc_column => 1,
422 'totalbytes_threshold'=> { label => 'Total up and download threshold',
424 disable_inventory => 1,
426 'format' => \&FS::UI::bytecount::display_bytecount,
427 'parse' => \&FS::UI::bytecount::parse_bytecount,
428 disable_part_svc_column => 1,
431 label => 'Last login',
435 label => 'Last logout',
440 label => 'Communigate aliases',
442 disable_inventory => 1,
447 label => 'Communigate account type',
449 select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
450 disable_inventory => 1,
453 'cgp_accessmodes' => {
454 label => 'Communigate enabled services',
455 type => 'communigate_pro-accessmodes',
456 disable_inventory => 1,
459 'cgp_rulesallowed' => {
460 label => 'Allowed mail rules',
462 select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
463 disable_inventory => 1,
466 'cgp_rpopallowed' => { label => 'RPOP modifications',
469 'cgp_mailtoall' => { label => 'Accepts mail to "all"',
472 'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
475 'cgp_archiveafter' => {
476 label => 'Archive messages after',
479 -2 => 'default(730 days)',
486 1209600 => '2 weeks',
487 2592000 => '30 days',
488 7776000 => '90 days',
489 15552000 => '180 days',
490 31536000 => '365 days',
491 63072000 => '730 days',
493 disable_inventory => 1,
499 'cgp_deletemode' => {
500 label => 'Communigate message delete method',
502 select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
503 disable_inventory => 1,
506 'cgp_emptytrash' => {
507 label => 'Communigate on logout remove trash',
509 select_list => __PACKAGE__->cgp_emptytrash_values,
510 disable_inventory => 1,
514 label => 'Communigate language',
516 select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
517 disable_inventory => 1,
521 label => 'Communigate time zone',
523 select_list => __PACKAGE__->cgp_timezone_values,
524 disable_inventory => 1,
528 label => 'Communigate layout',
530 select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
531 disable_inventory => 1,
534 'cgp_prontoskinname' => {
535 label => 'Communigate Pronto style',
537 select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ],
538 disable_inventory => 1,
541 'cgp_sendmdnmode' => {
542 label => 'Communigate send read receipts',
544 select_list => [ '', 'Never', 'Manually', 'Automatically' ],
545 disable_inventory => 1,
556 sub table { 'svc_acct'; }
558 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
561 shift->_lastlog('in', @_);
565 shift->_lastlog('out', @_);
569 my( $self, $op, $time ) = @_;
571 if ( defined($time) ) {
572 warn "$me last_log$op called on svcnum ". $self->svcnum.
573 ' ('. $self->email. "): $time\n"
578 my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
582 my $sth = $dbh->prepare( $sql )
583 or die "Error preparing $sql: ". $dbh->errstr;
584 my $rv = $sth->execute($time, $self->svcnum);
585 die "Error executing $sql: ". $sth->errstr
587 die "Can't update last_log$op for svcnum". $self->svcnum
590 $self->{'Hash'}->{"last_log$op"} = $time;
592 $self->getfield("last_log$op");
596 =item search_sql STRING
598 Class method which returns an SQL fragment to search for the given string.
603 my( $class, $string ) = @_;
604 if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
605 my( $username, $domain ) = ( $1, $2 );
606 my $q_username = dbh->quote($username);
607 my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
609 "svc_acct.username = $q_username AND ( ".
610 join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
615 } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
617 $class->search_sql_field('slipip', $string ).
619 $class->search_sql_field('username', $string ).
622 $class->search_sql_field('username', $string);
626 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
628 Returns the "username@domain" string for this account.
630 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
640 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
642 Returns a longer string label for this acccount ("Real Name <username@domain>"
643 if available, or "username@domain").
645 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
652 my $label = $self->label(@_);
653 my $finger = $self->finger;
654 return $label unless $finger =~ /\S/;
655 my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
656 $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
660 =item insert [ , OPTION => VALUE ... ]
662 Adds this account to the database. If there is an error, returns the error,
663 otherwise returns false.
665 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
666 defined. An FS::cust_svc record will be created and inserted.
668 The additional field I<usergroup> can optionally be defined; if so it should
669 contain an arrayref of group names. See L<FS::radius_usergroup>.
671 The additional field I<child_objects> can optionally be defined; if so it
672 should contain an arrayref of FS::tablename objects. They will have their
673 svcnum fields set and will be inserted after this record, but before any
674 exports are run. Each element of the array can also optionally be a
675 two-element array reference containing the child object and the name of an
676 alternate field to be filled in with the newly-inserted svcnum, for example
677 C<[ $svc_forward, 'srcsvc' ]>
679 Currently available options are: I<depend_jobnum>
681 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
682 jobnums), all provisioning jobs will have a dependancy on the supplied
683 jobnum(s) (they will not run until the specific job(s) complete(s)).
685 (TODOC: L<FS::queue> and L<freeside-queued>)
687 (TODOC: new exports!)
696 warn "[$me] insert called on $self: ". Dumper($self).
697 "\nwith options: ". Dumper(%options);
700 local $SIG{HUP} = 'IGNORE';
701 local $SIG{INT} = 'IGNORE';
702 local $SIG{QUIT} = 'IGNORE';
703 local $SIG{TERM} = 'IGNORE';
704 local $SIG{TSTP} = 'IGNORE';
705 local $SIG{PIPE} = 'IGNORE';
707 my $oldAutoCommit = $FS::UID::AutoCommit;
708 local $FS::UID::AutoCommit = 0;
712 my $error = $self->SUPER::insert( # usergroup is here
713 'jobnums' => \@jobnums,
714 'child_objects' => $self->child_objects,
718 $error ||= $self->insert_password_history;
721 $dbh->rollback if $oldAutoCommit;
725 unless ( $skip_fuzzyfiles ) {
726 $error = $self->queue_fuzzyfiles_update;
728 $dbh->rollback if $oldAutoCommit;
729 return "updating fuzzy search cache: $error";
733 my $cust_pkg = $self->cust_svc->cust_pkg;
736 my $cust_main = $cust_pkg->cust_main;
737 my $agentnum = $cust_main->agentnum;
739 if ( $conf->exists('emailinvoiceautoalways')
740 || $conf->exists('emailinvoiceauto')
741 && ! $cust_main->invoicing_list_emailonly
743 my @invoicing_list = $cust_main->invoicing_list;
744 push @invoicing_list, $self->email;
745 $cust_main->invoicing_list(\@invoicing_list);
749 my @welcome_exclude_svcparts = $conf->config('svc_acct_welcome_exclude');
750 unless ($FS::svc_Common::noexport_hack or ( grep { $_ eq $self->svcpart } @welcome_exclude_svcparts )) {
752 my $msgnum = $conf->config('welcome_msgnum', $agentnum);
754 my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
755 $error = $msg_template->send('cust_main' => $cust_main,
759 my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
760 = ('','','','','','');
762 if ( $conf->exists('welcome_email', $agentnum) ) {
763 $welcome_template = new Text::Template (
765 SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
766 ) or warn "can't create welcome email template: $Text::Template::ERROR";
767 $welcome_from = $conf->config('welcome_email-from', $agentnum);
768 # || 'your-isp-is-dum'
769 $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
771 $welcome_subject_template = new Text::Template (
773 SOURCE => $welcome_subject,
774 ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
775 $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
778 if ( $welcome_template ) {
779 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
783 'custnum' => $self->custnum,
784 'username' => $self->username,
785 'password' => $self->_password,
786 'first' => $cust_main->first,
787 'last' => $cust_main->getfield('last'),
788 'pkg' => $cust_pkg->part_pkg->pkg,
790 my $wqueue = new FS::queue {
791 'svcnum' => $self->svcnum,
792 'job' => 'FS::svc_acct::send_email'
794 my $error = $wqueue->insert(
796 'from' => $welcome_from,
797 'subject' => $welcome_subject_template->fill_in( HASH => \%hash, ),
798 'mimetype' => $welcome_mimetype,
799 'body' => $welcome_template->fill_in( HASH => \%hash, ),
802 $dbh->rollback if $oldAutoCommit;
803 return "error queuing welcome email: $error";
806 if ( $options{'depend_jobnum'} ) {
807 warn "$me depend_jobnum found; adding to welcome email dependancies"
809 if ( ref($options{'depend_jobnum'}) ) {
810 warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
811 "to welcome email dependancies"
813 push @jobnums, @{ $options{'depend_jobnum'} };
815 warn "$me adding job $options{'depend_jobnum'} ".
816 "to welcome email dependancies"
818 push @jobnums, $options{'depend_jobnum'};
822 foreach my $jobnum ( @jobnums ) {
823 my $error = $wqueue->depend_insert($jobnum);
825 $dbh->rollback if $oldAutoCommit;
826 return "error queuing welcome email job dependancy: $error";
832 } # if $welcome_template
837 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
841 # set usage fields and thresholds if unset but set in a package def
842 # AND the package already has a last bill date (otherwise they get double added)
843 sub preinsert_hook_first {
846 return '' unless $self->pkgnum;
848 my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
849 return '' unless $cust_pkg && $cust_pkg->last_bill;
851 my $part_pkg = $cust_pkg->part_pkg;
852 return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
854 my %values = $part_pkg->usage_valuehash;
855 my $multiplier = $conf->exists('svc_acct-usage_threshold')
856 ? 1 - $conf->config('svc_acct-usage_threshold')/100
857 : 0.20; #doesn't matter
859 foreach ( keys %values ) {
860 next if $self->getfield($_);
861 $self->setfield( $_, $values{$_} );
862 $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
863 if $conf->exists('svc_acct-usage_threshold');
871 Deletes this account from the database. If there is an error, returns the
872 error, otherwise returns false.
874 The corresponding FS::cust_svc record will be deleted as well.
876 (TODOC: new exports!)
883 return "can't delete system account" if $self->_check_system;
885 return "Can't delete an account which is a (svc_forward) source!"
886 if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
888 return "Can't delete an account which is a (svc_forward) destination!"
889 if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
891 return "Can't delete an account with (svc_www) web service!"
892 if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
894 # what about records in session ? (they should refer to history table)
896 local $SIG{HUP} = 'IGNORE';
897 local $SIG{INT} = 'IGNORE';
898 local $SIG{QUIT} = 'IGNORE';
899 local $SIG{TERM} = 'IGNORE';
900 local $SIG{TSTP} = 'IGNORE';
901 local $SIG{PIPE} = 'IGNORE';
903 my $oldAutoCommit = $FS::UID::AutoCommit;
904 local $FS::UID::AutoCommit = 0;
907 foreach my $cust_main_invoice (
908 qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
910 unless ( defined($cust_main_invoice) ) {
911 warn "WARNING: something's wrong with qsearch";
914 my %hash = $cust_main_invoice->hash;
915 $hash{'dest'} = $self->email;
916 my $new = new FS::cust_main_invoice \%hash;
917 my $error = $new->replace($cust_main_invoice);
919 $dbh->rollback if $oldAutoCommit;
924 foreach my $svc_domain (
925 qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
927 my %hash = new FS::svc_domain->hash;
928 $hash{'catchall'} = '';
929 my $new = new FS::svc_domain \%hash;
930 my $error = $new->replace($svc_domain);
932 $dbh->rollback if $oldAutoCommit;
937 foreach my $svc_phone (
938 qsearch( 'svc_phone', { 'forward_svcnum' => $self->svcnum })
940 $svc_phone->set('forward_svcnum', '');
941 my $error = $svc_phone->replace;
943 $dbh->rollback if $oldAutoCommit;
948 my $error = $self->delete_password_history
949 || $self->SUPER::delete; # usergroup here
951 $dbh->rollback if $oldAutoCommit;
955 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
959 =item replace OLD_RECORD
961 Replaces OLD_RECORD with this one in the database. If there is an error,
962 returns the error, otherwise returns false.
964 The additional field I<usergroup> can optionally be defined; if so it should
965 contain an arrayref of group names. See L<FS::radius_usergroup>.
973 my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
977 warn "$me replacing $old with $new\n" if $DEBUG;
981 return "can't modify system account" if $old->_check_system;
984 #no warnings 'numeric'; #alas, a 5.006-ism
987 foreach my $xid (qw( uid gid )) {
989 return "Can't change $xid!"
990 if ! $conf->exists("svc_acct-edit_$xid")
991 && $old->$xid() != $new->$xid()
992 && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
997 return "can't change username"
998 if $old->username ne $new->username
999 && $conf->exists('svc_acct-no_edit_username');
1001 #change homdir when we change username
1002 $new->setfield('dir', '') if $old->username ne $new->username;
1004 local $SIG{HUP} = 'IGNORE';
1005 local $SIG{INT} = 'IGNORE';
1006 local $SIG{QUIT} = 'IGNORE';
1007 local $SIG{TERM} = 'IGNORE';
1008 local $SIG{TSTP} = 'IGNORE';
1009 local $SIG{PIPE} = 'IGNORE';
1011 my $oldAutoCommit = $FS::UID::AutoCommit;
1012 local $FS::UID::AutoCommit = 0;
1015 $error = $new->SUPER::replace($old, @_); # usergroup here
1017 # don't need to record this unless the password was changed
1018 if ( $old->_password ne $new->_password ) {
1019 $error ||= $new->insert_password_history;
1023 $dbh->rollback if $oldAutoCommit;
1024 return $error if $error;
1027 if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1028 $error = $new->queue_fuzzyfiles_update;
1030 $dbh->rollback if $oldAutoCommit;
1031 return "updating fuzzy search cache: $error";
1035 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1039 =item queue_fuzzyfiles_update
1041 Used by insert & replace to update the fuzzy search cache
1045 sub queue_fuzzyfiles_update {
1048 local $SIG{HUP} = 'IGNORE';
1049 local $SIG{INT} = 'IGNORE';
1050 local $SIG{QUIT} = 'IGNORE';
1051 local $SIG{TERM} = 'IGNORE';
1052 local $SIG{TSTP} = 'IGNORE';
1053 local $SIG{PIPE} = 'IGNORE';
1055 my $oldAutoCommit = $FS::UID::AutoCommit;
1056 local $FS::UID::AutoCommit = 0;
1059 my $queue = new FS::queue {
1060 'svcnum' => $self->svcnum,
1061 'job' => 'FS::svc_acct::append_fuzzyfiles'
1063 my $error = $queue->insert($self->username);
1065 $dbh->rollback if $oldAutoCommit;
1066 return "queueing job (transaction rolled back): $error";
1069 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1077 Suspends this account by calling export-specific suspend hooks. If there is
1078 an error, returns the error, otherwise returns false.
1080 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1086 return "can't suspend system account" if $self->_check_system;
1087 $self->SUPER::suspend(@_);
1092 Unsuspends this account by by calling export-specific suspend hooks. If there
1093 is an error, returns the error, otherwise returns false.
1095 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1101 my %hash = $self->hash;
1102 if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1103 $hash{_password} = $1;
1104 my $new = new FS::svc_acct ( \%hash );
1105 my $error = $new->replace($self);
1106 return $error if $error;
1109 $self->SUPER::unsuspend(@_);
1114 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1116 If the B<auto_unset_catchall> configuration option is set, this method will
1117 automatically remove any references to the canceled service in the catchall
1118 field of svc_domain. This allows packages that contain both a svc_domain and
1119 its catchall svc_acct to be canceled in one step.
1124 # Only one thing to do at this level
1126 foreach my $svc_domain (
1127 qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1128 if($conf->exists('auto_unset_catchall')) {
1129 my %hash = $svc_domain->hash;
1130 $hash{catchall} = '';
1131 my $new = new FS::svc_domain ( \%hash );
1132 my $error = $new->replace($svc_domain);
1133 return $error if $error;
1135 return "cannot unprovision svc_acct #".$self->svcnum.
1136 " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1140 $self->SUPER::cancel(@_);
1146 Checks all fields to make sure this is a valid service. If there is an error,
1147 returns the error, otherwise returns false. Called by the insert and replace
1150 Sets any fixed values; see L<FS::part_svc>.
1157 my($recref) = $self->hashref;
1159 my $x = $self->setfixed;
1160 return $x unless ref($x);
1163 my $error = $self->ut_numbern('svcnum')
1164 #|| $self->ut_number('domsvc')
1165 || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1166 || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx', 'svcnum' )
1167 || $self->ut_foreign_keyn('sectornum','tower_sector','sectornum')
1168 || $self->ut_foreign_keyn('routernum','router','routernum')
1169 || $self->ut_foreign_keyn('blocknum','addr_block','blocknum')
1170 || $self->ut_textn('sec_phrase')
1171 || $self->ut_snumbern('seconds')
1172 || $self->ut_snumbern('upbytes')
1173 || $self->ut_snumbern('downbytes')
1174 || $self->ut_snumbern('totalbytes')
1175 || $self->ut_snumbern('seconds_threshold')
1176 || $self->ut_snumbern('upbytes_threshold')
1177 || $self->ut_snumbern('downbytes_threshold')
1178 || $self->ut_snumbern('totalbytes_threshold')
1179 || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1180 || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1181 || $self->ut_enum('password_recover', [ '', 'Y' ])
1183 || $self->ut_anything('cf_privatekey')
1185 || $self->ut_textn('cgp_accessmodes')
1186 || $self->ut_alphan('cgp_type')
1187 || $self->ut_textn('cgp_aliases' ) #well
1189 || $self->ut_alphasn('cgp_rulesallowed')
1190 || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1191 || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1192 || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1193 || $self->ut_snumbern('cgp_archiveafter')
1195 || $self->ut_alphasn('cgp_deletemode')
1196 || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1197 || $self->ut_alphan('cgp_language')
1198 || $self->ut_textn('cgp_timezone')
1199 || $self->ut_textn('cgp_skinname')
1200 || $self->ut_textn('cgp_prontoskinname')
1201 || $self->ut_alphan('cgp_sendmdnmode')
1203 return $error if $error;
1205 # assign IP address, etc.
1206 if ( $conf->exists('svc_acct-ip_addr') ) {
1207 my $error = $self->svc_ip_check;
1208 return $error if $error;
1209 } else { # I think this is correct
1210 $self->routernum('');
1211 $self->blocknum('');
1215 local $username_letter = $username_letter;
1216 local $username_uppercase = $username_uppercase;
1217 if ($self->svcnum) {
1218 my $cust_svc = $self->cust_svc
1219 or return "no cust_svc record found for svcnum ". $self->svcnum;
1220 my $cust_pkg = $cust_svc->cust_pkg;
1222 if ($self->pkgnum) {
1223 $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1227 $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1228 $username_uppercase =
1229 $conf->exists('username-uppercase', $cust_pkg->cust_main->agentnum);
1232 my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1234 $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#\!]{$usernamemin,$ulen})$/i
1235 or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1236 $recref->{username} = $1;
1238 my $uerror = gettext('illegal_username'). ': '. $recref->{username};
1240 unless ( $username_uppercase ) {
1241 $recref->{username} =~ /[A-Z]/ and return $uerror;
1243 if ( $username_letterfirst ) {
1244 $recref->{username} =~ /^[a-z]/ or return $uerror;
1245 } elsif ( $username_letter ) {
1246 $recref->{username} =~ /[a-z]/ or return $uerror;
1248 if ( $username_noperiod ) {
1249 $recref->{username} =~ /\./ and return $uerror;
1251 if ( $username_nounderscore ) {
1252 $recref->{username} =~ /_/ and return $uerror;
1254 if ( $username_nodash ) {
1255 $recref->{username} =~ /\-/ and return $uerror;
1257 unless ( $username_ampersand ) {
1258 $recref->{username} =~ /\&/ and return $uerror;
1260 unless ( $username_percent ) {
1261 $recref->{username} =~ /\%/ and return $uerror;
1263 unless ( $username_colon ) {
1264 $recref->{username} =~ /\:/ and return $uerror;
1266 unless ( $username_slash ) {
1267 $recref->{username} =~ /\// and return $uerror;
1269 unless ( $username_equals ) {
1270 $recref->{username} =~ /\=/ and return $uerror;
1272 unless ( $username_pound ) {
1273 $recref->{username} =~ /\#/ and return $uerror;
1275 unless ( $username_exclamation ) {
1276 $recref->{username} =~ /\!/ and return $uerror;
1280 $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1281 $recref->{popnum} = $1;
1282 return "Unknown popnum" unless
1283 ! $recref->{popnum} ||
1284 qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1286 unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1288 $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1289 $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1291 $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1292 $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1293 #not all systems use gid=uid
1294 #you can set a fixed gid in part_svc
1296 return "Only root can have uid 0"
1297 if $recref->{uid} == 0
1298 && $recref->{username} !~ /^(root|toor|smtp)$/;
1300 unless ( $recref->{username} eq 'sync' ) {
1301 if ( grep $_ eq $recref->{shell}, @shells ) {
1302 $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1304 return "Illegal shell \`". $self->shell. "\'; ".
1305 "shells configuration value contains: @shells";
1308 $recref->{shell} = '/bin/sync';
1312 $recref->{gid} ne '' ?
1313 return "Can't have gid without uid" : ( $recref->{gid}='' );
1314 #$recref->{dir} ne '' ?
1315 # return "Can't have directory without uid" : ( $recref->{dir}='' );
1316 $recref->{shell} ne '' ?
1317 return "Can't have shell without uid" : ( $recref->{shell}='' );
1320 unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1322 $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1323 or return "Illegal directory: ". $recref->{dir};
1324 $recref->{dir} = $1;
1325 return "Illegal directory"
1326 if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1327 return "Illegal directory"
1328 if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1329 unless ( $recref->{dir} ) {
1330 $recref->{dir} = $dir_prefix . '/';
1331 if ( $dirhash > 0 ) {
1332 for my $h ( 1 .. $dirhash ) {
1333 $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1335 } elsif ( $dirhash < 0 ) {
1336 for my $h ( reverse $dirhash .. -1 ) {
1337 $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1340 $recref->{dir} .= $recref->{username};
1346 if ( $self->getfield('finger') eq '' ) {
1347 my $cust_pkg = $self->svcnum
1348 ? $self->cust_svc->cust_pkg
1349 : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1351 my $cust_main = $cust_pkg->cust_main;
1352 $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1355 # $error = $self->ut_textn('finger');
1356 # return $error if $error;
1357 $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]*)$/
1358 or return "Illegal finger: ". $self->getfield('finger');
1359 $self->setfield('finger', $1);
1361 for (qw( quota file_quota file_maxsize )) {
1362 $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1365 $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1366 $recref->{file_maxnum} = $1;
1368 unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1369 if ( $recref->{slipip} eq '' ) {
1370 $recref->{slipip} = ''; # eh?
1371 } elsif ( $recref->{slipip} eq '0e0' ) {
1372 $recref->{slipip} = '0e0';
1374 $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1375 or return "Illegal slipip: ". $self->slipip;
1376 $recref->{slipip} = $1;
1380 #arbitrary RADIUS stuff; allow ut_textn for now
1381 foreach ( grep /^radius_/, fields('svc_acct') ) {
1382 $self->ut_textn($_);
1385 # First, if _password is blank, generate one and set default encoding.
1386 if ( ! $recref->{_password} ) {
1387 $error = $self->set_password('');
1389 # But if there's a _password but no encoding, assume it's plaintext and
1390 # set it to default encoding.
1391 elsif ( ! $recref->{_password_encoding} ) {
1392 $error = $self->set_password($recref->{_password});
1394 return $error if $error;
1396 # Next, check _password to ensure compliance with the encoding.
1397 if ( $recref->{_password_encoding} eq 'ldap' ) {
1399 if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1400 $recref->{_password} = uc($1).$2;
1402 return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1405 } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1407 if ( $recref->{_password} =~
1408 #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1409 /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1412 $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1415 return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1418 } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1419 # Password randomization is now in set_password.
1420 # Strip whitespace characters, check length requirements, etc.
1421 if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1422 $recref->{_password} = $1;
1424 return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1425 FS::Msgcat::_gettext('illegal_password_characters');
1428 if ( $password_noampersand ) {
1429 $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1431 if ( $password_noexclamation ) {
1432 $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1436 return "invalid password encoding ('".$recref->{_password_encoding}."'";
1439 $self->SUPER::check;
1444 sub _password_encryption {
1446 my $encoding = lc($self->_password_encoding);
1447 return if !$encoding;
1448 return 'plain' if $encoding eq 'plain';
1449 if($encoding eq 'crypt') {
1450 my $pass = $self->_password;
1451 $pass =~ s/^\*SUSPENDED\* //;
1453 return 'md5' if $pass =~ /^\$1\$/;
1454 #return 'blowfish' if $self->_password =~ /^\$2\$/;
1455 return 'des' if length($pass) == 13;
1458 if($encoding eq 'ldap') {
1459 uc($self->_password) =~ /^\{([\w-]+)\}/;
1460 return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1461 return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1462 return 'md5' if $1 eq 'MD5';
1463 return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1470 sub get_cleartext_password {
1472 if($self->_password_encryption eq 'plain') {
1473 if($self->_password_encoding eq 'ldap') {
1474 $self->_password =~ /\{\w+\}(.*)$/;
1478 return $self->_password;
1487 Set the cleartext password for the account. If _password_encoding is set, the
1488 new password will be encoded according to the existing method (including
1489 encryption mode, if it can be determined). Otherwise,
1490 config('default-password-encoding') is used.
1492 If no password is supplied (or a zero-length password when minimum password length
1493 is >0), one will be generated randomly.
1498 my( $self, $pass ) = ( shift, shift );
1500 warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1503 my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1504 FS::Msgcat::_gettext('illegal_password_characters').
1507 my( $encoding, $encryption ) = ('', '');
1509 if ( $self->_password_encoding ) {
1510 $encoding = $self->_password_encoding;
1511 # identify existing encryption method, try to use it.
1512 $encryption = $self->_password_encryption;
1514 # use the system default
1520 # set encoding to system default
1521 ($encoding, $encryption) =
1522 split(/-/, lc($conf->config('default-password-encoding') || ''));
1523 $encoding ||= 'legacy';
1524 $self->_password_encoding($encoding);
1527 if ( $encoding eq 'legacy' ) {
1529 # The legacy behavior from check():
1530 # If the password is blank, randomize it and set encoding to 'plain'.
1531 if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1532 $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1533 $self->_password_encoding('plain');
1535 # Prefix + valid-length password
1536 if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1538 $self->_password_encoding('plain');
1539 # Prefix + crypt string
1540 } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1542 $self->_password_encoding('crypt');
1543 # Various disabled crypt passwords
1544 } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1545 $self->_password_encoding('crypt');
1551 $self->_password($pass);
1557 if $passwordmin && length($pass) < $passwordmin
1558 or $passwordmax && length($pass) > $passwordmax;
1560 if ( $encoding eq 'crypt' ) {
1561 if ($encryption eq 'md5') {
1562 $pass = unix_md5_crypt($pass);
1563 } elsif ($encryption eq 'des') {
1564 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1567 } elsif ( $encoding eq 'ldap' ) {
1568 if ($encryption eq 'md5') {
1569 $pass = md5_base64($pass);
1570 } elsif ($encryption eq 'sha1') {
1571 $pass = sha1_base64($pass);
1572 } elsif ($encryption eq 'crypt') {
1573 $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1575 # else $encryption eq 'plain', do nothing
1576 $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1577 if $encryption eq 'md5' || $encryption eq 'sha1';
1578 $pass = '{'.uc($encryption).'}'.$pass;
1580 # else encoding eq 'plain'
1582 $self->_password($pass);
1588 Internal function to check the username against the list of system usernames
1589 from the I<system_usernames> configuration value. Returns true if the username
1590 is listed on the system username list.
1596 scalar( grep { $self->username eq $_ || $self->email eq $_ }
1597 $conf->config('system_usernames')
1601 =item _check_duplicate
1603 Internal method to check for duplicates usernames, username@domain pairs and
1606 If the I<global_unique-username> configuration value is set to B<username> or
1607 B<username@domain>, enforces global username or username@domain uniqueness.
1609 In all cases, check for duplicate uids and usernames or username@domain pairs
1610 per export and with identical I<svcpart> values.
1614 sub _check_duplicate {
1617 my $global_unique = $conf->config('global_unique-username') || 'none';
1618 return '' if $global_unique eq 'disabled';
1622 my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1623 unless ( $part_svc ) {
1624 return 'unknown svcpart '. $self->svcpart;
1627 my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1628 qsearch( 'svc_acct', { 'username' => $self->username } );
1629 return gettext('username_in_use')
1630 if $global_unique eq 'username' && @dup_user;
1632 my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1633 qsearch( 'svc_acct', { 'username' => $self->username,
1634 'domsvc' => $self->domsvc } );
1635 return gettext('username_in_use')
1636 if $global_unique eq 'username@domain' && @dup_userdomain;
1639 if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1640 && $self->username !~ /^(toor|(hyla)?fax)$/ ) {
1641 @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1642 qsearch( 'svc_acct', { 'uid' => $self->uid } );
1647 if ( @dup_user || @dup_userdomain || @dup_uid ) {
1648 my $exports = FS::part_export::export_info('svc_acct');
1649 my %conflict_user_svcpart;
1650 my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1652 foreach my $part_export ( $part_svc->part_export ) {
1654 #this will catch to the same exact export
1655 my @svcparts = map { $_->svcpart } $part_export->export_svc;
1657 #this will catch to exports w/same exporthost+type ???
1658 #my @other_part_export = qsearch('part_export', {
1659 # 'machine' => $part_export->machine,
1660 # 'exporttype' => $part_export->exporttype,
1662 #foreach my $other_part_export ( @other_part_export ) {
1663 # push @svcparts, map { $_->svcpart }
1664 # qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1667 #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1668 #silly kludge to avoid uninitialized value errors
1669 my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1670 ? $exports->{$part_export->exporttype}{'nodomain'}
1672 if ( $nodomain =~ /^Y/i ) {
1673 $conflict_user_svcpart{$_} = $part_export->exportnum
1676 $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1681 foreach my $dup_user ( @dup_user ) {
1682 my $dup_svcpart = $dup_user->cust_svc->svcpart;
1683 if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1684 return "duplicate username ". $self->username.
1685 ": conflicts with svcnum ". $dup_user->svcnum.
1686 " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1690 foreach my $dup_userdomain ( @dup_userdomain ) {
1691 my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1692 if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1693 return "duplicate username\@domain ". $self->email.
1694 ": conflicts with svcnum ". $dup_userdomain->svcnum.
1695 " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1699 foreach my $dup_uid ( @dup_uid ) {
1700 my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1701 if ( exists($conflict_user_svcpart{$dup_svcpart})
1702 || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1703 return "duplicate uid ". $self->uid.
1704 ": conflicts with svcnum ". $dup_uid->svcnum.
1706 ( $conflict_user_svcpart{$dup_svcpart}
1707 || $conflict_userdomain_svcpart{$dup_svcpart} );
1719 Depriciated, use radius_reply instead.
1724 carp "FS::svc_acct::radius depriciated, use radius_reply";
1725 $_[0]->radius_reply;
1730 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1731 reply attributes of this record.
1733 Note that this is now the preferred method for reading RADIUS attributes -
1734 accessing the columns directly is discouraged, as the column names are
1735 expected to change in the future.
1742 return %{ $self->{'radius_reply'} }
1743 if exists $self->{'radius_reply'};
1748 my($column, $attrib) = ($1, $2);
1749 #$attrib =~ s/_/\-/g;
1750 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1751 } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1753 if ( $self->slipip && $self->slipip ne '0e0' ) {
1754 $reply{$radius_ip} = $self->slipip;
1757 if ( $self->seconds !~ /^$/ ) {
1758 $reply{'Session-Timeout'} = $self->seconds;
1761 if ( $conf->exists('radius-chillispot-max') ) {
1762 #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1764 #hmm. just because sqlradius.pm says so?
1771 foreach my $what (qw( input output total )) {
1772 my $is = $whatis{$what}.'bytes';
1773 if ( $self->$is() =~ /\d/ ) {
1774 my $big = new Math::BigInt $self->$is();
1775 $big = new Math::BigInt '0' if $big->is_neg();
1776 my $att = "Chillispot-Max-\u$what";
1777 $reply{"$att-Octets"} = $big->copy->band(0xffffffff)->bstr;
1778 $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1789 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1790 check attributes of this record.
1792 Note that this is now the preferred method for reading RADIUS attributes -
1793 accessing the columns directly is discouraged, as the column names are
1794 expected to change in the future.
1801 return %{ $self->{'radius_check'} }
1802 if exists $self->{'radius_check'};
1807 my($column, $attrib) = ($1, $2);
1808 #$attrib =~ s/_/\-/g;
1809 ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1810 } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1813 my($pw_attrib, $password) = $self->radius_password;
1814 $check{$pw_attrib} = $password;
1816 my $cust_svc = $self->cust_svc;
1818 my $cust_pkg = $cust_svc->cust_pkg;
1819 if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1820 $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1823 warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1824 "; can't set Expiration\n"
1832 =item radius_password
1834 Returns a key/value pair containing the RADIUS attribute name and value
1839 sub radius_password {
1843 if ( $self->_password_encoding eq 'ldap' ) {
1844 $pw_attrib = 'Password-With-Header';
1845 } elsif ( $self->_password_encoding eq 'crypt' ) {
1846 $pw_attrib = 'Crypt-Password';
1847 } elsif ( $self->_password_encoding eq 'plain' ) {
1848 $pw_attrib = $radius_password;
1850 $pw_attrib = length($self->_password) <= 12
1855 ($pw_attrib, $self->_password);
1861 This method instructs the object to "snapshot" or freeze RADIUS check and
1862 reply attributes to the current values.
1866 #bah, my english is too broken this morning
1867 #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
1868 #the FS::cust_pkg's replace method to trigger the correct export updates when
1869 #package dates change)
1874 $self->{$_} = { $self->$_() }
1875 foreach qw( radius_reply radius_check );
1879 =item forget_snapshot
1881 This methos instructs the object to forget any previously snapshotted
1882 RADIUS check and reply attributes.
1886 sub forget_snapshot {
1890 foreach qw( radius_reply radius_check );
1894 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1896 Returns the domain associated with this account.
1898 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1905 die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1906 my $svc_domain = $self->svc_domain(@_)
1907 or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1908 $svc_domain->domain;
1913 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1917 #inherited from svc_Common
1919 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1921 Returns an email address associated with the account.
1923 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1930 $self->username. '@'. $self->domain(@_);
1936 Returns an array of FS::acct_snarf records associated with the account.
1940 # unused as originally intended, but now by Communigate Pro "RPOP"
1944 'table' => 'acct_snarf',
1945 'hashref' => { 'svcnum' => $self->svcnum },
1946 #'order_by' => 'ORDER BY priority ASC',
1950 =item cgp_rpop_hashref
1952 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1956 sub cgp_rpop_hashref {
1958 { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1961 =item decrement_upbytes OCTETS
1963 Decrements the I<upbytes> field of this record by the given amount. If there
1964 is an error, returns the error, otherwise returns false.
1968 sub decrement_upbytes {
1969 shift->_op_usage('-', 'upbytes', @_);
1972 =item increment_upbytes OCTETS
1974 Increments the I<upbytes> field of this record by the given amount. If there
1975 is an error, returns the error, otherwise returns false.
1979 sub increment_upbytes {
1980 shift->_op_usage('+', 'upbytes', @_);
1983 =item decrement_downbytes OCTETS
1985 Decrements the I<downbytes> field of this record by the given amount. If there
1986 is an error, returns the error, otherwise returns false.
1990 sub decrement_downbytes {
1991 shift->_op_usage('-', 'downbytes', @_);
1994 =item increment_downbytes OCTETS
1996 Increments the I<downbytes> field of this record by the given amount. If there
1997 is an error, returns the error, otherwise returns false.
2001 sub increment_downbytes {
2002 shift->_op_usage('+', 'downbytes', @_);
2005 =item decrement_totalbytes OCTETS
2007 Decrements the I<totalbytes> field of this record by the given amount. If there
2008 is an error, returns the error, otherwise returns false.
2012 sub decrement_totalbytes {
2013 shift->_op_usage('-', 'totalbytes', @_);
2016 =item increment_totalbytes OCTETS
2018 Increments the I<totalbytes> field of this record by the given amount. If there
2019 is an error, returns the error, otherwise returns false.
2023 sub increment_totalbytes {
2024 shift->_op_usage('+', 'totalbytes', @_);
2027 =item decrement_seconds SECONDS
2029 Decrements the I<seconds> field of this record by the given amount. If there
2030 is an error, returns the error, otherwise returns false.
2034 sub decrement_seconds {
2035 shift->_op_usage('-', 'seconds', @_);
2038 =item increment_seconds SECONDS
2040 Increments the I<seconds> field of this record by the given amount. If there
2041 is an error, returns the error, otherwise returns false.
2045 sub increment_seconds {
2046 shift->_op_usage('+', 'seconds', @_);
2054 my %op2condition = (
2055 '-' => sub { my($self, $column, $amount) = @_;
2056 $self->$column - $amount <= 0;
2058 '+' => sub { my($self, $column, $amount) = @_;
2059 ($self->$column || 0) + $amount > 0;
2062 my %op2warncondition = (
2063 '-' => sub { my($self, $column, $amount) = @_;
2064 my $threshold = $column . '_threshold';
2065 $self->$column - $amount <= $self->$threshold + 0;
2067 '+' => sub { my($self, $column, $amount) = @_;
2068 ($self->$column || 0) + $amount > 0;
2073 my( $self, $op, $column, $amount ) = @_;
2075 warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2076 ' ('. $self->email. "): $op $amount\n"
2079 return '' unless $amount;
2081 local $SIG{HUP} = 'IGNORE';
2082 local $SIG{INT} = 'IGNORE';
2083 local $SIG{QUIT} = 'IGNORE';
2084 local $SIG{TERM} = 'IGNORE';
2085 local $SIG{TSTP} = 'IGNORE';
2086 local $SIG{PIPE} = 'IGNORE';
2088 my $oldAutoCommit = $FS::UID::AutoCommit;
2089 local $FS::UID::AutoCommit = 0;
2092 my $sql = "UPDATE svc_acct SET $column = ".
2093 " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2094 " $op ? WHERE svcnum = ?";
2098 my $sth = $dbh->prepare( $sql )
2099 or die "Error preparing $sql: ". $dbh->errstr;
2100 my $rv = $sth->execute($amount, $self->svcnum);
2101 die "Error executing $sql: ". $sth->errstr
2102 unless defined($rv);
2103 die "Can't update $column for svcnum". $self->svcnum
2106 if ( $conf->exists('radius-chillispot-max') ) {
2107 #$self->snapshot; #not necessary, we retain the old values
2108 #create an object with the updated usage values
2109 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2111 my $error = $new->replace($self);
2113 $dbh->rollback if $oldAutoCommit;
2114 return "Error replacing: $error";
2118 #overlimit_action eq 'cancel' handling
2119 my $cust_pkg = $self->cust_svc->cust_pkg;
2121 && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2122 && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2126 my $error = $cust_pkg->cancel; #XXX should have a reason
2128 $dbh->rollback if $oldAutoCommit;
2129 return "Error cancelling: $error";
2132 #nothing else is relevant if we're cancelling, so commit & return success
2133 warn "$me update successful; committing\n"
2135 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2140 my $action = $op2action{$op};
2142 if ( &{$op2condition{$op}}($self, $column, $amount) &&
2143 ( $action eq 'suspend' && !$self->overlimit
2144 || $action eq 'unsuspend' && $self->overlimit )
2147 my $error = $self->_op_overlimit($action);
2149 $dbh->rollback if $oldAutoCommit;
2155 if ( $conf->exists("svc_acct-usage_$action")
2156 && &{$op2condition{$op}}($self, $column, $amount) ) {
2157 #my $error = $self->$action();
2158 my $error = $self->cust_svc->cust_pkg->$action();
2159 # $error ||= $self->overlimit($action);
2161 $dbh->rollback if $oldAutoCommit;
2162 return "Error ${action}ing: $error";
2166 if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2167 my $wqueue = new FS::queue {
2168 'svcnum' => $self->svcnum,
2169 'job' => 'FS::svc_acct::reached_threshold',
2174 $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2178 my $error = $wqueue->insert(
2179 'svcnum' => $self->svcnum,
2181 'column' => $column,
2185 $dbh->rollback if $oldAutoCommit;
2186 return "Error queuing threshold activity: $error";
2190 warn "$me update successful; committing\n"
2192 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2198 my( $self, $action ) = @_;
2200 local $SIG{HUP} = 'IGNORE';
2201 local $SIG{INT} = 'IGNORE';
2202 local $SIG{QUIT} = 'IGNORE';
2203 local $SIG{TERM} = 'IGNORE';
2204 local $SIG{TSTP} = 'IGNORE';
2205 local $SIG{PIPE} = 'IGNORE';
2207 my $oldAutoCommit = $FS::UID::AutoCommit;
2208 local $FS::UID::AutoCommit = 0;
2211 my $cust_pkg = $self->cust_svc->cust_pkg;
2213 my @conf_overlimit =
2215 ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2216 : $conf->config('overlimit_groups');
2218 foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2220 my @groups = scalar(@conf_overlimit) ? @conf_overlimit
2221 : split(' ',$part_export->option('overlimit_groups'));
2222 next unless scalar(@groups);
2224 my $other = new FS::svc_acct $self->hashref;
2225 $other->usergroup(\@groups);
2228 if ($action eq 'suspend') {
2231 } else { # $action eq 'unsuspend'
2236 my $error = $part_export->export_replace($new, $old)
2237 || $self->overlimit($action);
2240 $dbh->rollback if $oldAutoCommit;
2241 return "Error replacing radius groups: $error";
2246 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2252 my( $self, $valueref, %options ) = @_;
2254 warn "$me set_usage called for svcnum ". $self->svcnum.
2255 ' ('. $self->email. "): ".
2256 join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2259 local $SIG{HUP} = 'IGNORE';
2260 local $SIG{INT} = 'IGNORE';
2261 local $SIG{QUIT} = 'IGNORE';
2262 local $SIG{TERM} = 'IGNORE';
2263 local $SIG{TSTP} = 'IGNORE';
2264 local $SIG{PIPE} = 'IGNORE';
2266 local $FS::svc_Common::noexport_hack = 1;
2267 my $oldAutoCommit = $FS::UID::AutoCommit;
2268 local $FS::UID::AutoCommit = 0;
2273 if ( $options{null} ) {
2274 %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2275 qw( seconds upbytes downbytes totalbytes )
2278 foreach my $field (keys %$valueref){
2279 $reset = 1 if $valueref->{$field};
2280 $self->setfield($field, $valueref->{$field});
2281 $self->setfield( $field.'_threshold',
2282 int($self->getfield($field)
2283 * ( $conf->exists('svc_acct-usage_threshold')
2284 ? 1 - $conf->config('svc_acct-usage_threshold')/100
2289 $handyhash{$field} = $self->getfield($field);
2290 $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2292 #my $error = $self->replace; #NO! we avoid the call to ->check for
2293 #die $error if $error; #services not explicity changed via the UI
2295 my $sql = "UPDATE svc_acct SET " .
2296 join (',', map { "$_ = ?" } (keys %handyhash) ).
2297 " WHERE svcnum = ". $self->svcnum;
2302 if (scalar(keys %handyhash)) {
2303 my $sth = $dbh->prepare( $sql )
2304 or die "Error preparing $sql: ". $dbh->errstr;
2305 my $rv = $sth->execute(values %handyhash);
2306 die "Error executing $sql: ". $sth->errstr
2307 unless defined($rv);
2308 die "Can't update usage for svcnum ". $self->svcnum
2312 if ( $conf->exists('radius-chillispot-max') ) {
2313 #$self->snapshot; #not necessary, we retain the old values
2314 #create an object with the updated usage values
2315 my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2316 local($FS::Record::nowarn_identical) = 1;
2317 my $error = $new->replace($self); #call exports
2319 $dbh->rollback if $oldAutoCommit;
2320 return "Error replacing: $error";
2328 $error = $self->_op_overlimit('unsuspend')
2329 if $self->overlimit;;
2331 $error ||= $self->cust_svc->cust_pkg->unsuspend
2332 if $conf->exists("svc_acct-usage_unsuspend");
2335 $dbh->rollback if $oldAutoCommit;
2336 return "Error unsuspending: $error";
2341 warn "$me update successful; committing\n"
2343 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2349 =item recharge HASHREF
2351 Increments usage columns by the amount specified in HASHREF as
2352 column=>amount pairs.
2357 my ($self, $vhash) = @_;
2360 warn "[$me] recharge called on $self: ". Dumper($self).
2361 "\nwith vhash: ". Dumper($vhash);
2364 my $oldAutoCommit = $FS::UID::AutoCommit;
2365 local $FS::UID::AutoCommit = 0;
2369 foreach my $column (keys %$vhash){
2370 $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2374 $dbh->rollback if $oldAutoCommit;
2376 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2381 =item is_rechargeable
2383 Returns true if this svc_account can be "recharged" and false otherwise.
2387 sub is_rechargable {
2389 $self->seconds ne ''
2390 || $self->upbytes ne ''
2391 || $self->downbytes ne ''
2392 || $self->totalbytes ne '';
2395 =item seconds_since TIMESTAMP
2397 Returns the number of seconds this account has been online since TIMESTAMP,
2398 according to the session monitor (see L<FS::session>).
2400 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">. Also see
2401 L<Time::Local> and L<Date::Parse> for conversion functions.
2405 #note: POD here, implementation in FS::cust_svc
2408 $self->cust_svc->seconds_since(@_);
2411 =item last_login_text
2413 Returns text describing the time of last login.
2417 sub last_login_text {
2419 $self->last_login ? ctime($self->last_login) : 'unknown';
2422 =item psearch_cdrs OPTIONS
2424 Returns a paged search (L<FS::PagedSearch>) for Call Detail Records
2425 associated with this service. For svc_acct, "associated with" means that
2426 either the "src" or the "charged_party" field of the CDR matches either
2427 the "username" field of the service or the username@domain label.
2432 my($self, %options) = @_;
2437 my $did = dbh->quote($self->username);
2438 my $diddomain = dbh->quote($self->label);
2440 my $prefix = $options{'default_prefix'} || ''; #convergent.au '+61'
2441 my $prefixdid = dbh->quote($prefix . $self->username);
2443 my $for_update = $options{'for_update'} ? 'FOR UPDATE' : '';
2445 if ( $options{inbound} ) {
2446 # these will be selected under their DIDs
2447 push @where, "FALSE";
2451 if (!$options{'disable_charged_party'}) {
2453 "charged_party = $did",
2454 "charged_party = $prefixdid",
2455 "charged_party = $diddomain"
2458 if (!$options{'disable_src'}) {
2460 "src = $did AND charged_party IS NULL",
2461 "src = $prefixdid AND charged_party IS NULL",
2462 "src = $diddomain AND charged_party IS NULL"
2465 push @where, '(' . join(' OR ', @orwhere) . ')';
2467 # $options{'status'} = '' is meaningful; for the rest of them it's not
2468 if ( exists $options{'status'} ) {
2469 $hash{'freesidestatus'} = $options{'status'};
2471 if ( $options{'cdrtypenum'} ) {
2472 $hash{'cdrtypenum'} = $options{'cdrtypenum'};
2474 if ( $options{'calltypenum'} ) {
2475 $hash{'calltypenum'} = $options{'calltypenum'};
2477 if ( $options{'begin'} ) {
2478 push @where, 'startdate >= '. $options{'begin'};
2480 if ( $options{'end'} ) {
2481 push @where, 'startdate < '. $options{'end'};
2483 if ( $options{'nonzero'} ) {
2484 push @where, 'duration > 0';
2487 my $extra_sql = join(' AND ', @where);
2490 $extra_sql = " AND ".$extra_sql;
2492 $extra_sql = " WHERE ".$extra_sql;
2498 'hashref' => \%hash,
2499 'extra_sql' => $extra_sql,
2500 'order_by' => "ORDER BY startdate $for_update",
2504 =item get_cdrs (DEPRECATED)
2506 Like psearch_cdrs, but returns all the L<FS::cdr> objects at once, in a
2507 single list. Arguments are the same as for psearch_cdrs.
2513 my $psearch = $self->psearch_cdrs(@_);
2514 qsearch ( $psearch->{query} )
2517 # sub radius_groups has moved to svc_Radius_Mixin
2519 =item clone_suspended
2521 Constructor used by FS::part_export::_export_suspend fallback. Document
2526 sub clone_suspended {
2528 my %hash = $self->hash;
2529 $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2530 new FS::svc_acct \%hash;
2533 =item clone_kludge_unsuspend
2535 Constructor used by FS::part_export::_export_unsuspend fallback. Document
2540 sub clone_kludge_unsuspend {
2542 my %hash = $self->hash;
2543 $hash{_password} = '';
2544 new FS::svc_acct \%hash;
2547 =item check_password
2549 Checks the supplied password against the (possibly encrypted) password in the
2550 database. Returns true for a successful authentication, false for no match.
2552 Currently supported encryptions are: classic DES crypt() and MD5
2556 sub check_password {
2557 my($self, $check_password) = @_;
2559 #remove old-style SUSPENDED kludge, they should be allowed to login to
2560 #self-service and pay up
2561 ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2563 if ( $self->_password_encoding eq 'ldap' ) {
2565 $password =~ s/^{PLAIN}/{CLEARTEXT}/;
2566 my $auth = from_rfc2307 Authen::Passphrase $password;
2567 return $auth->match($check_password);
2569 } elsif ( $self->_password_encoding eq 'crypt' ) {
2571 my $auth = from_crypt Authen::Passphrase $self->_password;
2572 return $auth->match($check_password);
2574 } elsif ( $self->_password_encoding eq 'plain' ) {
2576 return $check_password eq $password;
2580 #XXX this could be replaced with Authen::Passphrase stuff
2582 if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2584 } elsif ( length($password) < 13 ) { #plaintext
2585 $check_password eq $password;
2586 } elsif ( length($password) == 13 ) { #traditional DES crypt
2587 crypt($check_password, $password) eq $password;
2588 } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2589 unix_md5_crypt($check_password, $password) eq $password;
2590 } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2591 warn "Can't check password: Blowfish encryption not yet supported, ".
2592 "svcnum ". $self->svcnum. "\n";
2595 warn "Can't check password: Unrecognized encryption for svcnum ".
2596 $self->svcnum. "\n";
2604 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2606 Returns an encrypted password, either by passing through an encrypted password
2607 in the database or by encrypting a plaintext password from the database.
2609 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2610 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2611 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2612 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.). The default
2613 encryption type is only used if the password is not already encrypted in the
2618 sub crypt_password {
2621 if ( $self->_password_encoding eq 'ldap' ) {
2623 if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2626 #XXX this could be replaced with Authen::Passphrase stuff
2628 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2629 if ( $encryption eq 'crypt' ) {
2632 $saltset[int(rand(64))].$saltset[int(rand(64))]
2634 } elsif ( $encryption eq 'md5' ) {
2635 return unix_md5_crypt( $self->_password );
2636 } elsif ( $encryption eq 'blowfish' ) {
2637 croak "unknown encryption method $encryption";
2639 croak "unknown encryption method $encryption";
2642 } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2646 } elsif ( $self->_password_encoding eq 'crypt' ) {
2648 return $self->_password;
2650 } elsif ( $self->_password_encoding eq 'plain' ) {
2652 #XXX this could be replaced with Authen::Passphrase stuff
2654 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2655 if ( $encryption eq 'crypt' ) {
2658 $saltset[int(rand(64))].$saltset[int(rand(64))]
2660 } elsif ( $encryption eq 'md5' ) {
2661 return unix_md5_crypt( $self->_password );
2662 } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2663 my $pass = sha1_base64( $self->_password );
2664 $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2666 } elsif ( $encryption eq 'blowfish' ) {
2667 croak "unknown encryption method $encryption";
2669 croak "unknown encryption method $encryption";
2674 if ( length($self->_password) == 13
2675 || $self->_password =~ /^\$(1|2a?)\$/
2676 || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2682 #XXX this could be replaced with Authen::Passphrase stuff
2684 my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2685 if ( $encryption eq 'crypt' ) {
2688 $saltset[int(rand(64))].$saltset[int(rand(64))]
2690 } elsif ( $encryption eq 'md5' ) {
2691 return unix_md5_crypt( $self->_password );
2692 } elsif ( $encryption eq 'blowfish' ) {
2693 croak "unknown encryption method $encryption";
2695 croak "unknown encryption method $encryption";
2704 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2706 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2707 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2708 "{MD5}5426824942db4253f87a1009fd5d2d4".
2710 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2711 to work the same as the B</crypt_password> method.
2717 #eventually should check a "password-encoding" field
2719 if ( $self->_password_encoding eq 'ldap' ) {
2721 return $self->_password;
2723 } elsif ( $self->_password_encoding eq 'crypt' ) {
2725 if ( length($self->_password) == 13 ) { #crypt
2726 return '{CRYPT}'. $self->_password;
2727 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2729 #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2730 # die "Blowfish encryption not supported in this context, svcnum ".
2731 # $self->svcnum. "\n";
2733 warn "encryption method not (yet?) supported in LDAP context";
2734 return '{CRYPT}*'; #unsupported, should not auth
2737 } elsif ( $self->_password_encoding eq 'plain' ) {
2739 return '{PLAIN}'. $self->_password;
2741 #return '{CLEARTEXT}'. $self->_password; #?
2745 if ( length($self->_password) == 13 ) { #crypt
2746 return '{CRYPT}'. $self->_password;
2747 } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2749 } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2750 warn "Blowfish encryption not supported in this context, svcnum ".
2751 $self->svcnum. "\n";
2754 #are these two necessary anymore?
2755 } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2756 return '{SSHA}'. $1;
2757 } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2758 return '{NS-MTA-MD5}'. $1;
2761 return '{PLAIN}'. $self->_password;
2763 #return '{CLEARTEXT}'. $self->_password; #?
2765 #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2766 #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2767 #if ( $encryption eq 'crypt' ) {
2768 # return '{CRYPT}'. crypt(
2770 # $saltset[int(rand(64))].$saltset[int(rand(64))]
2772 #} elsif ( $encryption eq 'md5' ) {
2773 # unix_md5_crypt( $self->_password );
2774 #} elsif ( $encryption eq 'blowfish' ) {
2775 # croak "unknown encryption method $encryption";
2777 # croak "unknown encryption method $encryption";
2785 =item domain_slash_username
2787 Returns $domain/$username/
2791 sub domain_slash_username {
2793 $self->domain. '/'. $self->username. '/';
2796 =item virtual_maildir
2798 Returns $domain/maildirs/$username/
2802 sub virtual_maildir {
2804 $self->domain. '/maildirs/'. $self->username. '/';
2807 =item password_svc_check
2809 Override, for L<FS::Password_Mixin>. Not really intended for other use.
2813 sub password_svc_check {
2814 my ($self, $password) = @_;
2815 foreach my $field ( qw(username finger) ) {
2816 foreach my $word (split(/\W+/,$self->get($field))) {
2817 next unless length($word) > 2;
2818 if ($password =~ /$word/i) {
2819 return qq(Password contains account information '$word');
2828 =head1 CLASS METHODS
2832 =item search HASHREF
2834 Class method which returns a qsearch hash expression to search for parameters
2835 specified in HASHREF. Valid parameters are
2849 Arrayref of pkgparts
2855 Arrayref of additional WHERE clauses, will be ANDed together.
2866 my( $class, $params, $from, $where ) = @_;
2868 #these two should probably move to svc_Domain_Mixin ?
2871 if ( $params->{'domain'} ) {
2872 my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2873 #preserve previous behavior & bubble up an error if $svc_domain not found?
2874 push @$where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2878 if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2879 push @$where, "domsvc = $1";
2884 if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2885 push @$where, "popnum = $1";
2889 #and these in svc_Tower_Mixin, or maybe we never should have done svc_acct
2890 # towers (or, as mark thought, never should have done svc_broadband)
2893 my @where_sector = $class->tower_sector_sql($params);
2894 if ( @where_sector ) {
2895 push @$where, @where_sector;
2896 push @$from, ' LEFT JOIN tower_sector USING ( sectornum )';
2909 This is the FS::svc_acct job-queue-able version. It still uses
2910 FS::Misc::send_email under-the-hood.
2917 eval "use FS::Misc qw(send_email)";
2920 $opt{mimetype} ||= 'text/plain';
2921 $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2923 my $error = send_email(
2924 'from' => $opt{from},
2926 'subject' => $opt{subject},
2927 'content-type' => $opt{mimetype},
2928 'body' => [ map "$_\n", split("\n", $opt{body}) ],
2930 die $error if $error;
2933 =item check_and_rebuild_fuzzyfiles
2937 sub check_and_rebuild_fuzzyfiles {
2938 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2939 -e "$dir/svc_acct.username"
2940 or &rebuild_fuzzyfiles;
2943 =item rebuild_fuzzyfiles
2947 sub rebuild_fuzzyfiles {
2949 use Fcntl qw(:flock);
2951 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2955 open(USERNAMELOCK,">>$dir/svc_acct.username")
2956 or die "can't open $dir/svc_acct.username: $!";
2957 flock(USERNAMELOCK,LOCK_EX)
2958 or die "can't lock $dir/svc_acct.username: $!";
2960 my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2962 open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2963 or die "can't open $dir/svc_acct.username.tmp: $!";
2964 print USERNAMECACHE join("\n", @all_username), "\n";
2965 close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2967 rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2977 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2978 open(USERNAMECACHE,"<$dir/svc_acct.username")
2979 or die "can't open $dir/svc_acct.username: $!";
2980 my @array = map { chomp; $_; } <USERNAMECACHE>;
2981 close USERNAMECACHE;
2985 =item append_fuzzyfiles USERNAME
2989 sub append_fuzzyfiles {
2990 my $username = shift;
2992 &check_and_rebuild_fuzzyfiles;
2994 use Fcntl qw(:flock);
2996 my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2998 open(USERNAME,">>$dir/svc_acct.username")
2999 or die "can't open $dir/svc_acct.username: $!";
3000 flock(USERNAME,LOCK_EX)
3001 or die "can't lock $dir/svc_acct.username: $!";
3003 print USERNAME "$username\n";
3005 flock(USERNAME,LOCK_UN)
3006 or die "can't unlock $dir/svc_acct.username: $!";
3013 =item reached_threshold
3015 Performs some activities when svc_acct thresholds (such as number of seconds
3016 remaining) are reached.
3020 sub reached_threshold {
3023 my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3024 die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3026 if ( $opt{'op'} eq '+' ){
3027 $svc_acct->setfield( $opt{'column'}.'_threshold',
3028 int($svc_acct->getfield($opt{'column'})
3029 * ( $conf->exists('svc_acct-usage_threshold')
3030 ? $conf->config('svc_acct-usage_threshold')/100
3035 my $error = $svc_acct->replace;
3036 die $error if $error;
3037 }elsif ( $opt{'op'} eq '-' ){
3039 my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3040 return '' if ($threshold eq '' );
3042 $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3043 my $error = $svc_acct->replace;
3044 die $error if $error; # email next time, i guess
3046 if ( $warning_template ) {
3047 eval "use FS::Misc qw(send_email)";
3050 my $cust_pkg = $svc_acct->cust_svc->cust_pkg;
3051 my $cust_main = $cust_pkg->cust_main;
3053 my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3054 $cust_main->invoicing_list,
3055 ($opt{'to'} ? $opt{'to'} : ())
3058 my $mimetype = $warning_mimetype;
3059 $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3061 my $body = $warning_template->fill_in( HASH => {
3062 'custnum' => $cust_main->custnum,
3063 'username' => $svc_acct->username,
3064 'password' => $svc_acct->_password,
3065 'first' => $cust_main->first,
3066 'last' => $cust_main->getfield('last'),
3067 'pkg' => $cust_pkg->part_pkg->pkg,
3068 'column' => $opt{'column'},
3069 'amount' => $opt{'column'} =~/bytes/
3070 ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3071 : $svc_acct->getfield($opt{'column'}),
3072 'threshold' => $opt{'column'} =~/bytes/
3073 ? FS::UI::bytecount::display_bytecount($threshold)
3078 my $error = send_email(
3079 'from' => $warning_from,
3081 'subject' => $warning_subject,
3082 'content-type' => $mimetype,
3083 'body' => [ map "$_\n", split("\n", $body) ],
3085 die $error if $error;
3088 die "unknown op: " . $opt{'op'};
3096 The $recref stuff in sub check should be cleaned up.
3098 The suspend, unsuspend and cancel methods update the database, but not the
3099 current object. This is probably a bug as it's unexpected and
3102 insertion of RADIUS group stuff in insert could be done with child_objects now
3103 (would probably clean up export of them too)
3105 _op_usage and set_usage bypass the history... maybe they shouldn't
3109 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3110 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3111 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3112 L<freeside-queued>), L<FS::svc_acct_pop>,
3113 schema.html from the base documentation.