FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use vars qw( @ISA $DEBUG $me $conf $skip_fuzzyfiles
   5              $dir_prefix @shells $usernamemin
   6              $usernamemax $passwordmin $passwordmax
   7              $username_ampersand $username_letter $username_letterfirst
   8              $username_noperiod $username_nounderscore $username_nodash
   9              $username_uppercase $username_percent
  10              $password_noampersand $password_noexclamation
  11              $warning_template $warning_from $warning_subject $warning_mimetype
  12              $warning_cc
  13              $smtpmachine
  14              $radius_password $radius_ip
  15              $dirhash
  16              @saltset @pw_set );
  17 use Carp;
  18 use Fcntl qw(:flock);
  19 use Date::Format;
  20 use Crypt::PasswdMD5 1.2;
  21 use Data::Dumper;
  22 use Authen::Passphrase;
  23 use FS::UID qw( datasrc );
  24 use FS::Conf;
  25 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  26 use FS::Msgcat qw(gettext);
  27 use FS::UI::bytecount;
  28 use FS::svc_Common;
  29 use FS::cust_svc;
  30 use FS::part_svc;
  31 use FS::svc_acct_pop;
  32 use FS::cust_main_invoice;
  33 use FS::svc_domain;
  34 use FS::raddb;
  35 use FS::queue;
  36 use FS::radius_usergroup;
  37 use FS::export_svc;
  38 use FS::part_export;
  39 use FS::svc_forward;
  40 use FS::svc_www;
  41 use FS::cdr;
  42
  43 @ISA = qw( FS::svc_Common );
  44
  45 $DEBUG = 0;
  46 $me = '[FS::svc_acct]';
  47
  48 #ask FS::UID to run this stuff for us later
  49 $FS::UID::callback{'FS::svc_acct'} = sub {
  50   $conf = new FS::Conf;
  51   $dir_prefix = $conf->config('home');
  52   @shells = $conf->config('shells');
  53   $usernamemin = $conf->config('usernamemin') || 2;
  54   $usernamemax = $conf->config('usernamemax');
  55   $passwordmin = $conf->config('passwordmin') || 6;
  56   $passwordmax = $conf->config('passwordmax') || 8;
  57   $username_letter = $conf->exists('username-letter');
  58   $username_letterfirst = $conf->exists('username-letterfirst');
  59   $username_noperiod = $conf->exists('username-noperiod');
  60   $username_nounderscore = $conf->exists('username-nounderscore');
  61   $username_nodash = $conf->exists('username-nodash');
  62   $username_uppercase = $conf->exists('username-uppercase');
  63   $username_ampersand = $conf->exists('username-ampersand');
  64   $username_percent = $conf->exists('username-percent');
  65   $password_noampersand = $conf->exists('password-noexclamation');
  66   $password_noexclamation = $conf->exists('password-noexclamation');
  67   $dirhash = $conf->config('dirhash') || 0;
  68   if ( $conf->exists('warning_email') ) {
  69     $warning_template = new Text::Template (
  70       TYPE   => 'ARRAY',
  71       SOURCE => [ map "$_\n", $conf->config('warning_email') ]
  72     ) or warn "can't create warning email template: $Text::Template::ERROR";
  73     $warning_from = $conf->config('warning_email-from'); # || 'your-isp-is-dum'
  74     $warning_subject = $conf->config('warning_email-subject') || 'Warning';
  75     $warning_mimetype = $conf->config('warning_email-mimetype') || 'text/plain';
  76     $warning_cc = $conf->config('warning_email-cc');
  77   } else {
  78     $warning_template = '';
  79     $warning_from = '';
  80     $warning_subject = '';
  81     $warning_mimetype = '';
  82     $warning_cc = '';
  83   }
  84   $smtpmachine = $conf->config('smtpmachine');
  85   $radius_password = $conf->config('radius-password') || 'Password';
  86   $radius_ip = $conf->config('radius-ip') || 'Framed-IP-Address';
  87   @pw_set = ( 'A'..'Z' ) if $conf->exists('password-generated-allcaps');
  88 };
  89
  90 @saltset = ( 'a'..'z' , 'A'..'Z' , '0'..'9' , '.' , '/' );
  91 @pw_set = ( 'a'..'z', 'A'..'Z', '0'..'9', '(', ')', '#', '!', '.', ',' );
  92
  93 sub _cache {
  94   my $self = shift;
  95   my ( $hashref, $cache ) = @_;
  96   if ( $hashref->{'svc_acct_svcnum'} ) {
  97     $self->{'_domsvc'} = FS::svc_domain->new( {
  98       'svcnum'   => $hashref->{'domsvc'},
  99       'domain'   => $hashref->{'svc_acct_domain'},
 100       'catchall' => $hashref->{'svc_acct_catchall'},
 101     } );
 102   }
 103 }
 104
 105 =head1 NAME
 106
 107 FS::svc_acct - Object methods for svc_acct records
 108
 109 =head1 SYNOPSIS
 110
 111   use FS::svc_acct;
 112
 113   $record = new FS::svc_acct \%hash;
 114   $record = new FS::svc_acct { 'column' => 'value' };
 115
 116   $error = $record->insert;
 117
 118   $error = $new_record->replace($old_record);
 119
 120   $error = $record->delete;
 121
 122   $error = $record->check;
 123
 124   $error = $record->suspend;
 125
 126   $error = $record->unsuspend;
 127
 128   $error = $record->cancel;
 129
 130   %hash = $record->radius;
 131
 132   %hash = $record->radius_reply;
 133
 134   %hash = $record->radius_check;
 135
 136   $domain = $record->domain;
 137
 138   $svc_domain = $record->svc_domain;
 139
 140   $email = $record->email;
 141
 142   $seconds_since = $record->seconds_since($timestamp);
 143
 144 =head1 DESCRIPTION
 145
 146 An FS::svc_acct object represents an account.  FS::svc_acct inherits from
 147 FS::svc_Common.  The following fields are currently supported:
 148
 149 =over 4
 150
 151 =item svcnum - primary key (assigned automatcially for new accounts)
 152
 153 =item username
 154
 155 =item _password - generated if blank
 156
 157 =item _password_encoding - plain, crypt, ldap (or empty for autodetection)
 158
 159 =item sec_phrase - security phrase
 160
 161 =item popnum - Point of presence (see L<FS::svc_acct_pop>)
 162
 163 =item uid
 164
 165 =item gid
 166
 167 =item finger - GECOS
 168
 169 =item dir - set automatically if blank (and uid is not)
 170
 171 =item shell
 172
 173 =item quota - (unimplementd)
 174
 175 =item slipip - IP address
 176
 177 =item seconds -
 178
 179 =item upbytes -
 180
 181 =item downbytes -
 182
 183 =item totalbytes -
 184
 185 =item domsvc - svcnum from svc_domain
 186
 187 =item radius_I<Radius_Attribute> - I<Radius-Attribute> (reply)
 188
 189 =item rc_I<Radius_Attribute> - I<Radius-Attribute> (check)
 190
 191 =back
 192
 193 =head1 METHODS
 194
 195 =over 4
 196
 197 =item new HASHREF
 198
 199 Creates a new account.  To add the account to the database, see L<"insert">.
 200
 201 =cut
 202
 203 sub table_info {
 204   {
 205     'name'   => 'Account',
 206     'longname_plural' => 'Access accounts and mailboxes',
 207     'sorts' => [ 'username', 'uid', ],
 208     'display_weight' => 10,
 209     'cancel_weight'  => 50,
 210     'fields' => {
 211         'dir'       => 'Home directory',
 212         'uid'       => {
 213                          label     => 'UID',
 214                          def_label => 'UID (set to fixed and blank for no UIDs)',
 215                          type      => 'text',
 216                        },
 217         'slipip'    => 'IP address',
 218     #    'popnum'    => qq!<A HREF="$p/browse/svc_acct_pop.cgi/">POP number</A>!,
 219         'popnum'    => {
 220                          label => 'Access number',
 221                          type => 'select',
 222                          select_table => 'svc_acct_pop',
 223                          select_key   => 'popnum',
 224                          select_label => 'city',
 225                          disable_select => 1,
 226                        },
 227         'username'  => {
 228                          label => 'Username',
 229                          type => 'text',
 230                          disable_default => 1,
 231                          disable_fixed => 1,
 232                          disable_select => 1,
 233                        },
 234         'quota'     => {
 235                          label => 'Quota',
 236                          type => 'text',
 237                          disable_inventory => 1,
 238                          disable_select => 1,
 239                        },
 240         '_password' => 'Password',
 241         'gid'       => {
 242                          label     => 'GID',
 243                          def_label => 'GID (when blank, defaults to UID)',
 244                          type      => 'text',
 245                        },
 246         'shell'     => {
 247                          #desc =>'Shell (all service definitions should have a default or fixed shell that is present in the <b>shells</b> configuration file, set to blank for no shell tracking)',
 248                          label    => 'Shell',
 249                          def_label=> 'Shell (set to blank for no shell tracking)',
 250                          type     =>'select',
 251                          select_list => [ $conf->config('shells') ],
 252                          disable_inventory => 1,
 253                          disable_select => 1,
 254                        },
 255         'finger'    => 'Real name (GECOS)',
 256         'domsvc'    => {
 257                          label     => 'Domain',
 258                          #def_label => 'svcnum from svc_domain',
 259                          type      => 'select',
 260                          select_table => 'svc_domain',
 261                          select_key   => 'svcnum',
 262                          select_label => 'domain',
 263                          disable_inventory => 1,
 264
 265                        },
 266         'usergroup' => {
 267                          label => 'RADIUS groups',
 268                          type  => 'radius_usergroup_selector',
 269                          disable_inventory => 1,
 270                          disable_select => 1,
 271                        },
 272         'seconds'   => { label => 'Seconds',
 273                          type  => 'text',
 274                          disable_inventory => 1,
 275                          disable_select => 1,
 276                        },
 277         'upbytes'   => { label => 'Upload',
 278                          type  => 'text',
 279                          disable_inventory => 1,
 280                          disable_select => 1,
 281                          'format' => \&FS::UI::bytecount::display_bytecount,
 282                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 283                        },
 284         'downbytes' => { label => 'Download',
 285                          type  => 'text',
 286                          disable_inventory => 1,
 287                          disable_select => 1,
 288                          'format' => \&FS::UI::bytecount::display_bytecount,
 289                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 290                        },
 291         'totalbytes'=> { label => 'Total up and download',
 292                          type  => 'text',
 293                          disable_inventory => 1,
 294                          disable_select => 1,
 295                          'format' => \&FS::UI::bytecount::display_bytecount,
 296                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 297                        },
 298         'seconds_threshold'   => { label => 'Seconds',
 299                                    type  => 'text',
 300                                    disable_inventory => 1,
 301                                    disable_select => 1,
 302                                  },
 303         'upbytes_threshold'   => { label => 'Upload',
 304                                    type  => 'text',
 305                                    disable_inventory => 1,
 306                                    disable_select => 1,
 307                                    'format' => \&FS::UI::bytecount::display_bytecount,
 308                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 309                                  },
 310         'downbytes_threshold' => { label => 'Download',
 311                                    type  => 'text',
 312                                    disable_inventory => 1,
 313                                    disable_select => 1,
 314                                    'format' => \&FS::UI::bytecount::display_bytecount,
 315                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 316                                  },
 317         'totalbytes_threshold'=> { label => 'Total up and download',
 318                                    type  => 'text',
 319                                    disable_inventory => 1,
 320                                    disable_select => 1,
 321                                    'format' => \&FS::UI::bytecount::display_bytecount,
 322                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 323                                  },
 324     },
 325   };
 326 }
 327
 328 sub table { 'svc_acct'; }
 329
 330 sub _fieldhandlers {
 331   {
 332     #false laziness with edit/svc_acct.cgi
 333     'usergroup' => sub {
 334                          my( $self, $groups ) = @_;
 335                          if ( ref($groups) eq 'ARRAY' ) {
 336                            $groups;
 337                          } elsif ( length($groups) ) {
 338                            [ split(/\s*,\s*/, $groups) ];
 339                          } else {
 340                            [];
 341                          }
 342                        },
 343   };
 344 }
 345
 346 =item search_sql STRING
 347
 348 Class method which returns an SQL fragment to search for the given string.
 349
 350 =cut
 351
 352 sub search_sql {
 353   my( $class, $string ) = @_;
 354   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 355     my( $username, $domain ) = ( $1, $2 );
 356     my $q_username = dbh->quote($username);
 357     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 358     if ( @svc_domain ) {
 359       "svc_acct.username = $q_username AND ( ".
 360         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 361       " )";
 362     } else {
 363       '1 = 0'; #false
 364     }
 365   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 366     ' ( '.
 367       $class->search_sql_field('slipip',   $string ).
 368     ' OR '.
 369       $class->search_sql_field('username', $string ).
 370     ' ) ';
 371   } else {
 372     $class->search_sql_field('username', $string);
 373   }
 374 }
 375
 376 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 377
 378 Returns the "username@domain" string for this account.
 379
 380 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 381 history records.
 382
 383 =cut
 384
 385 sub label {
 386   my $self = shift;
 387   $self->email(@_);
 388 }
 389
 390 =cut
 391
 392 =item insert [ , OPTION => VALUE ... ]
 393
 394 Adds this account to the database.  If there is an error, returns the error,
 395 otherwise returns false.
 396
 397 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 398 defined.  An FS::cust_svc record will be created and inserted.
 399
 400 The additional field I<usergroup> can optionally be defined; if so it should
 401 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 402
 403 The additional field I<child_objects> can optionally be defined; if so it
 404 should contain an arrayref of FS::tablename objects.  They will have their
 405 svcnum fields set and will be inserted after this record, but before any
 406 exports are run.  Each element of the array can also optionally be a
 407 two-element array reference containing the child object and the name of an
 408 alternate field to be filled in with the newly-inserted svcnum, for example
 409 C<[ $svc_forward, 'srcsvc' ]>
 410
 411 Currently available options are: I<depend_jobnum>
 412
 413 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 414 jobnums), all provisioning jobs will have a dependancy on the supplied
 415 jobnum(s) (they will not run until the specific job(s) complete(s)).
 416
 417 (TODOC: L<FS::queue> and L<freeside-queued>)
 418
 419 (TODOC: new exports!)
 420
 421 =cut
 422
 423 sub insert {
 424   my $self = shift;
 425   my %options = @_;
 426
 427   if ( $DEBUG ) {
 428     warn "[$me] insert called on $self: ". Dumper($self).
 429          "\nwith options: ". Dumper(%options);
 430   }
 431
 432   local $SIG{HUP} = 'IGNORE';
 433   local $SIG{INT} = 'IGNORE';
 434   local $SIG{QUIT} = 'IGNORE';
 435   local $SIG{TERM} = 'IGNORE';
 436   local $SIG{TSTP} = 'IGNORE';
 437   local $SIG{PIPE} = 'IGNORE';
 438
 439   my $oldAutoCommit = $FS::UID::AutoCommit;
 440   local $FS::UID::AutoCommit = 0;
 441   my $dbh = dbh;
 442
 443   my $error = $self->check;
 444   return $error if $error;
 445
 446   if ( $self->svcnum && qsearchs('cust_svc',{'svcnum'=>$self->svcnum}) ) {
 447     my $cust_svc = qsearchs('cust_svc',{'svcnum'=>$self->svcnum});
 448     unless ( $cust_svc ) {
 449       $dbh->rollback if $oldAutoCommit;
 450       return "no cust_svc record found for svcnum ". $self->svcnum;
 451     }
 452     $self->pkgnum($cust_svc->pkgnum);
 453     $self->svcpart($cust_svc->svcpart);
 454   }
 455
 456   $error = $self->_check_duplicate;
 457   if ( $error ) {
 458     $dbh->rollback if $oldAutoCommit;
 459     return $error;
 460   }
 461
 462   my @jobnums;
 463   $error = $self->SUPER::insert(
 464     'jobnums'       => \@jobnums,
 465     'child_objects' => $self->child_objects,
 466     %options,
 467   );
 468   if ( $error ) {
 469     $dbh->rollback if $oldAutoCommit;
 470     return $error;
 471   }
 472
 473   if ( $self->usergroup ) {
 474     foreach my $groupname ( @{$self->usergroup} ) {
 475       my $radius_usergroup = new FS::radius_usergroup ( {
 476         svcnum    => $self->svcnum,
 477         groupname => $groupname,
 478       } );
 479       my $error = $radius_usergroup->insert;
 480       if ( $error ) {
 481         $dbh->rollback if $oldAutoCommit;
 482         return $error;
 483       }
 484     }
 485   }
 486
 487   unless ( $skip_fuzzyfiles ) {
 488     $error = $self->queue_fuzzyfiles_update;
 489     if ( $error ) {
 490       $dbh->rollback if $oldAutoCommit;
 491       return "updating fuzzy search cache: $error";
 492     }
 493   }
 494
 495   my $cust_pkg = $self->cust_svc->cust_pkg;
 496
 497   if ( $cust_pkg ) {
 498     my $cust_main = $cust_pkg->cust_main;
 499     my $agentnum = $cust_main->agentnum;
 500
 501     if (   $conf->exists('emailinvoiceautoalways')
 502         || $conf->exists('emailinvoiceauto')
 503         && ! $cust_main->invoicing_list_emailonly
 504        ) {
 505       my @invoicing_list = $cust_main->invoicing_list;
 506       push @invoicing_list, $self->email;
 507       $cust_main->invoicing_list(\@invoicing_list);
 508     }
 509
 510     #welcome email
 511     my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
 512       = ('','','','','','');
 513
 514     if ( $conf->exists('welcome_email', $agentnum) ) {
 515       $welcome_template = new Text::Template (
 516         TYPE   => 'ARRAY',
 517         SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
 518       ) or warn "can't create welcome email template: $Text::Template::ERROR";
 519       $welcome_from = $conf->config('welcome_email-from', $agentnum);
 520         # || 'your-isp-is-dum'
 521       $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
 522         || 'Welcome';
 523       $welcome_subject_template = new Text::Template (
 524         TYPE   => 'STRING',
 525         SOURCE => $welcome_subject,
 526       ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
 527       $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
 528         || 'text/plain';
 529     }
 530     if ( $welcome_template && $cust_pkg ) {
 531       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 532       if ( $to ) {
 533
 534         my %hash = (
 535                      'custnum'  => $self->custnum,
 536                      'username' => $self->username,
 537                      'password' => $self->_password,
 538                      'first'    => $cust_main->first,
 539                      'last'     => $cust_main->getfield('last'),
 540                      'pkg'      => $cust_pkg->part_pkg->pkg,
 541                    );
 542         my $wqueue = new FS::queue {
 543           'svcnum' => $self->svcnum,
 544           'job'    => 'FS::svc_acct::send_email'
 545         };
 546         my $error = $wqueue->insert(
 547           'to'       => $to,
 548           'from'     => $welcome_from,
 549           'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 550           'mimetype' => $welcome_mimetype,
 551           'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 552         );
 553         if ( $error ) {
 554           $dbh->rollback if $oldAutoCommit;
 555           return "error queuing welcome email: $error";
 556         }
 557
 558         if ( $options{'depend_jobnum'} ) {
 559           warn "$me depend_jobnum found; adding to welcome email dependancies"
 560             if $DEBUG;
 561           if ( ref($options{'depend_jobnum'}) ) {
 562             warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 563                  "to welcome email dependancies"
 564               if $DEBUG;
 565             push @jobnums, @{ $options{'depend_jobnum'} };
 566           } else {
 567             warn "$me adding job $options{'depend_jobnum'} ".
 568                  "to welcome email dependancies"
 569               if $DEBUG;
 570             push @jobnums, $options{'depend_jobnum'};
 571           }
 572         }
 573
 574         foreach my $jobnum ( @jobnums ) {
 575           my $error = $wqueue->depend_insert($jobnum);
 576           if ( $error ) {
 577             $dbh->rollback if $oldAutoCommit;
 578             return "error queuing welcome email job dependancy: $error";
 579           }
 580         }
 581
 582       }
 583
 584     }
 585
 586   } # if ( $cust_pkg )
 587
 588   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 589   ''; #no error
 590 }
 591
 592 =item delete
 593
 594 Deletes this account from the database.  If there is an error, returns the
 595 error, otherwise returns false.
 596
 597 The corresponding FS::cust_svc record will be deleted as well.
 598
 599 (TODOC: new exports!)
 600
 601 =cut
 602
 603 sub delete {
 604   my $self = shift;
 605
 606   return "can't delete system account" if $self->_check_system;
 607
 608   return "Can't delete an account which is a (svc_forward) source!"
 609     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 610
 611   return "Can't delete an account which is a (svc_forward) destination!"
 612     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 613
 614   return "Can't delete an account with (svc_www) web service!"
 615     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 616
 617   # what about records in session ? (they should refer to history table)
 618
 619   local $SIG{HUP} = 'IGNORE';
 620   local $SIG{INT} = 'IGNORE';
 621   local $SIG{QUIT} = 'IGNORE';
 622   local $SIG{TERM} = 'IGNORE';
 623   local $SIG{TSTP} = 'IGNORE';
 624   local $SIG{PIPE} = 'IGNORE';
 625
 626   my $oldAutoCommit = $FS::UID::AutoCommit;
 627   local $FS::UID::AutoCommit = 0;
 628   my $dbh = dbh;
 629
 630   foreach my $cust_main_invoice (
 631     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 632   ) {
 633     unless ( defined($cust_main_invoice) ) {
 634       warn "WARNING: something's wrong with qsearch";
 635       next;
 636     }
 637     my %hash = $cust_main_invoice->hash;
 638     $hash{'dest'} = $self->email;
 639     my $new = new FS::cust_main_invoice \%hash;
 640     my $error = $new->replace($cust_main_invoice);
 641     if ( $error ) {
 642       $dbh->rollback if $oldAutoCommit;
 643       return $error;
 644     }
 645   }
 646
 647   foreach my $svc_domain (
 648     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 649   ) {
 650     my %hash = new FS::svc_domain->hash;
 651     $hash{'catchall'} = '';
 652     my $new = new FS::svc_domain \%hash;
 653     my $error = $new->replace($svc_domain);
 654     if ( $error ) {
 655       $dbh->rollback if $oldAutoCommit;
 656       return $error;
 657     }
 658   }
 659
 660   my $error = $self->SUPER::delete;
 661   if ( $error ) {
 662     $dbh->rollback if $oldAutoCommit;
 663     return $error;
 664   }
 665
 666   foreach my $radius_usergroup (
 667     qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } )
 668   ) {
 669     my $error = $radius_usergroup->delete;
 670     if ( $error ) {
 671       $dbh->rollback if $oldAutoCommit;
 672       return $error;
 673     }
 674   }
 675
 676   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 677   '';
 678 }
 679
 680 =item replace OLD_RECORD
 681
 682 Replaces OLD_RECORD with this one in the database.  If there is an error,
 683 returns the error, otherwise returns false.
 684
 685 The additional field I<usergroup> can optionally be defined; if so it should
 686 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 687
 688
 689 =cut
 690
 691 sub replace {
 692   my ( $new, $old ) = ( shift, shift );
 693   my $error;
 694   warn "$me replacing $old with $new\n" if $DEBUG;
 695
 696   # We absolutely have to have an old vs. new record to make this work.
 697   if (!defined($old)) {
 698     $old = qsearchs( 'svc_acct', { 'svcnum' => $new->svcnum } );
 699   }
 700
 701   return "can't modify system account" if $old->_check_system;
 702
 703   {
 704     #no warnings 'numeric';  #alas, a 5.006-ism
 705     local($^W) = 0;
 706
 707     foreach my $xid (qw( uid gid )) {
 708
 709       return "Can't change $xid!"
 710         if ! $conf->exists("svc_acct-edit_$xid")
 711            && $old->$xid() != $new->$xid()
 712            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 713     }
 714
 715   }
 716
 717   #change homdir when we change username
 718   $new->setfield('dir', '') if $old->username ne $new->username;
 719
 720   local $SIG{HUP} = 'IGNORE';
 721   local $SIG{INT} = 'IGNORE';
 722   local $SIG{QUIT} = 'IGNORE';
 723   local $SIG{TERM} = 'IGNORE';
 724   local $SIG{TSTP} = 'IGNORE';
 725   local $SIG{PIPE} = 'IGNORE';
 726
 727   my $oldAutoCommit = $FS::UID::AutoCommit;
 728   local $FS::UID::AutoCommit = 0;
 729   my $dbh = dbh;
 730
 731   # redundant, but so $new->usergroup gets set
 732   $error = $new->check;
 733   return $error if $error;
 734
 735   $old->usergroup( [ $old->radius_groups ] );
 736   if ( $DEBUG ) {
 737     warn $old->email. " old groups: ". join(' ',@{$old->usergroup}). "\n";
 738     warn $new->email. "new groups: ". join(' ',@{$new->usergroup}). "\n";
 739   }
 740   if ( $new->usergroup ) {
 741     #(sorta) false laziness with FS::part_export::sqlradius::_export_replace
 742     my @newgroups = @{$new->usergroup};
 743     foreach my $oldgroup ( @{$old->usergroup} ) {
 744       if ( grep { $oldgroup eq $_ } @newgroups ) {
 745         @newgroups = grep { $oldgroup ne $_ } @newgroups;
 746         next;
 747       }
 748       my $radius_usergroup = qsearchs('radius_usergroup', {
 749         svcnum    => $old->svcnum,
 750         groupname => $oldgroup,
 751       } );
 752       my $error = $radius_usergroup->delete;
 753       if ( $error ) {
 754         $dbh->rollback if $oldAutoCommit;
 755         return "error deleting radius_usergroup $oldgroup: $error";
 756       }
 757     }
 758
 759     foreach my $newgroup ( @newgroups ) {
 760       my $radius_usergroup = new FS::radius_usergroup ( {
 761         svcnum    => $new->svcnum,
 762         groupname => $newgroup,
 763       } );
 764       my $error = $radius_usergroup->insert;
 765       if ( $error ) {
 766         $dbh->rollback if $oldAutoCommit;
 767         return "error adding radius_usergroup $newgroup: $error";
 768       }
 769     }
 770
 771   }
 772
 773   if ( $old->username ne $new->username || $old->domsvc != $new->domsvc ) {
 774     $new->svcpart( $new->cust_svc->svcpart ) unless $new->svcpart;
 775     $error = $new->_check_duplicate;
 776     if ( $error ) {
 777       $dbh->rollback if $oldAutoCommit;
 778       return $error;
 779     }
 780   }
 781
 782   $error = $new->SUPER::replace($old, @_);
 783   if ( $error ) {
 784     $dbh->rollback if $oldAutoCommit;
 785     return $error if $error;
 786   }
 787
 788   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 789     $error = $new->queue_fuzzyfiles_update;
 790     if ( $error ) {
 791       $dbh->rollback if $oldAutoCommit;
 792       return "updating fuzzy search cache: $error";
 793     }
 794   }
 795
 796   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 797   ''; #no error
 798 }
 799
 800 =item queue_fuzzyfiles_update
 801
 802 Used by insert & replace to update the fuzzy search cache
 803
 804 =cut
 805
 806 sub queue_fuzzyfiles_update {
 807   my $self = shift;
 808
 809   local $SIG{HUP} = 'IGNORE';
 810   local $SIG{INT} = 'IGNORE';
 811   local $SIG{QUIT} = 'IGNORE';
 812   local $SIG{TERM} = 'IGNORE';
 813   local $SIG{TSTP} = 'IGNORE';
 814   local $SIG{PIPE} = 'IGNORE';
 815
 816   my $oldAutoCommit = $FS::UID::AutoCommit;
 817   local $FS::UID::AutoCommit = 0;
 818   my $dbh = dbh;
 819
 820   my $queue = new FS::queue {
 821     'svcnum' => $self->svcnum,
 822     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 823   };
 824   my $error = $queue->insert($self->username);
 825   if ( $error ) {
 826     $dbh->rollback if $oldAutoCommit;
 827     return "queueing job (transaction rolled back): $error";
 828   }
 829
 830   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 831   '';
 832
 833 }
 834
 835
 836 =item suspend
 837
 838 Suspends this account by calling export-specific suspend hooks.  If there is
 839 an error, returns the error, otherwise returns false.
 840
 841 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 842
 843 =cut
 844
 845 sub suspend {
 846   my $self = shift;
 847   return "can't suspend system account" if $self->_check_system;
 848   $self->SUPER::suspend(@_);
 849 }
 850
 851 =item unsuspend
 852
 853 Unsuspends this account by by calling export-specific suspend hooks.  If there
 854 is an error, returns the error, otherwise returns false.
 855
 856 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 857
 858 =cut
 859
 860 sub unsuspend {
 861   my $self = shift;
 862   my %hash = $self->hash;
 863   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
 864     $hash{_password} = $1;
 865     my $new = new FS::svc_acct ( \%hash );
 866     my $error = $new->replace($self);
 867     return $error if $error;
 868   }
 869
 870   $self->SUPER::unsuspend(@_);
 871 }
 872
 873 =item cancel
 874
 875 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 876
 877 If the B<auto_unset_catchall> configuration option is set, this method will
 878 automatically remove any references to the canceled service in the catchall
 879 field of svc_domain.  This allows packages that contain both a svc_domain and
 880 its catchall svc_acct to be canceled in one step.
 881
 882 =cut
 883
 884 sub cancel {
 885   # Only one thing to do at this level
 886   my $self = shift;
 887   foreach my $svc_domain (
 888       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
 889     if($conf->exists('auto_unset_catchall')) {
 890       my %hash = $svc_domain->hash;
 891       $hash{catchall} = '';
 892       my $new = new FS::svc_domain ( \%hash );
 893       my $error = $new->replace($svc_domain);
 894       return $error if $error;
 895     } else {
 896       return "cannot unprovision svc_acct #".$self->svcnum.
 897           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
 898     }
 899   }
 900
 901   $self->SUPER::cancel(@_);
 902 }
 903
 904
 905 =item check
 906
 907 Checks all fields to make sure this is a valid service.  If there is an error,
 908 returns the error, otherwise returns false.  Called by the insert and replace
 909 methods.
 910
 911 Sets any fixed values; see L<FS::part_svc>.
 912
 913 =cut
 914
 915 sub check {
 916   my $self = shift;
 917
 918   my($recref) = $self->hashref;
 919
 920   my $x = $self->setfixed( $self->_fieldhandlers );
 921   return $x unless ref($x);
 922   my $part_svc = $x;
 923
 924   if ( $part_svc->part_svc_column('usergroup')->columnflag eq "F" ) {
 925     $self->usergroup(
 926       [ split(',', $part_svc->part_svc_column('usergroup')->columnvalue) ] );
 927   }
 928
 929   my $error = $self->ut_numbern('svcnum')
 930               #|| $self->ut_number('domsvc')
 931               || $self->ut_foreign_key('domsvc', 'svc_domain', 'svcnum' )
 932               || $self->ut_textn('sec_phrase')
 933               || $self->ut_snumbern('seconds')
 934               || $self->ut_snumbern('upbytes')
 935               || $self->ut_snumbern('downbytes')
 936               || $self->ut_snumbern('totalbytes')
 937               || $self->ut_enum( '_password_encoding',
 938                                  [ '', qw( plain crypt ldap ) ]
 939                                )
 940   ;
 941   return $error if $error;
 942
 943   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
 944   if ( $username_uppercase ) {
 945     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/i
 946       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 947     $recref->{username} = $1;
 948   } else {
 949     $recref->{username} =~ /^([a-z0-9_\-\.\&\%]{$usernamemin,$ulen})$/
 950       or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
 951     $recref->{username} = $1;
 952   }
 953
 954   if ( $username_letterfirst ) {
 955     $recref->{username} =~ /^[a-z]/ or return gettext('illegal_username');
 956   } elsif ( $username_letter ) {
 957     $recref->{username} =~ /[a-z]/ or return gettext('illegal_username');
 958   }
 959   if ( $username_noperiod ) {
 960     $recref->{username} =~ /\./ and return gettext('illegal_username');
 961   }
 962   if ( $username_nounderscore ) {
 963     $recref->{username} =~ /_/ and return gettext('illegal_username');
 964   }
 965   if ( $username_nodash ) {
 966     $recref->{username} =~ /\-/ and return gettext('illegal_username');
 967   }
 968   unless ( $username_ampersand ) {
 969     $recref->{username} =~ /\&/ and return gettext('illegal_username');
 970   }
 971   unless ( $username_percent ) {
 972     $recref->{username} =~ /\%/ and return gettext('illegal_username');
 973   }
 974
 975   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
 976   $recref->{popnum} = $1;
 977   return "Unknown popnum" unless
 978     ! $recref->{popnum} ||
 979     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
 980
 981   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
 982
 983     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
 984     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
 985
 986     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
 987     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
 988     #not all systems use gid=uid
 989     #you can set a fixed gid in part_svc
 990
 991     return "Only root can have uid 0"
 992       if $recref->{uid} == 0
 993          && $recref->{username} !~ /^(root|toor|smtp)$/;
 994
 995     unless ( $recref->{username} eq 'sync' ) {
 996       if ( grep $_ eq $recref->{shell}, @shells ) {
 997         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
 998       } else {
 999         return "Illegal shell \`". $self->shell. "\'; ".
1000                "shells configuration value contains: @shells";
1001       }
1002     } else {
1003       $recref->{shell} = '/bin/sync';
1004     }
1005
1006   } else {
1007     $recref->{gid} ne '' ?
1008       return "Can't have gid without uid" : ( $recref->{gid}='' );
1009     #$recref->{dir} ne '' ?
1010     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1011     $recref->{shell} ne '' ?
1012       return "Can't have shell without uid" : ( $recref->{shell}='' );
1013   }
1014
1015   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1016
1017     $recref->{dir} =~ /^([\/\w\-\.\&]*)$/
1018       or return "Illegal directory: ". $recref->{dir};
1019     $recref->{dir} = $1;
1020     return "Illegal directory"
1021       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1022     return "Illegal directory"
1023       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1024     unless ( $recref->{dir} ) {
1025       $recref->{dir} = $dir_prefix . '/';
1026       if ( $dirhash > 0 ) {
1027         for my $h ( 1 .. $dirhash ) {
1028           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1029         }
1030       } elsif ( $dirhash < 0 ) {
1031         for my $h ( reverse $dirhash .. -1 ) {
1032           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1033         }
1034       }
1035       $recref->{dir} .= $recref->{username};
1036     ;
1037     }
1038
1039   }
1040
1041   #  $error = $self->ut_textn('finger');
1042   #  return $error if $error;
1043   if ( $self->getfield('finger') eq '' ) {
1044     my $cust_pkg = $self->svcnum
1045       ? $self->cust_svc->cust_pkg
1046       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1047     if ( $cust_pkg ) {
1048       my $cust_main = $cust_pkg->cust_main;
1049       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1050     }
1051   }
1052   $self->getfield('finger') =~
1053     /^([\w \t\!\@\#\$\%\&\(\)\-\+\;\'\"\,\.\?\/\*\<\>]*)$/
1054       or return "Illegal finger: ". $self->getfield('finger');
1055   $self->setfield('finger', $1);
1056
1057   $recref->{quota} =~ /^(\w*)$/ or return "Illegal quota";
1058   $recref->{quota} = $1;
1059
1060   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1061     if ( $recref->{slipip} eq '' ) {
1062       $recref->{slipip} = '';
1063     } elsif ( $recref->{slipip} eq '0e0' ) {
1064       $recref->{slipip} = '0e0';
1065     } else {
1066       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1067         or return "Illegal slipip: ". $self->slipip;
1068       $recref->{slipip} = $1;
1069     }
1070
1071   }
1072
1073   #arbitrary RADIUS stuff; allow ut_textn for now
1074   foreach ( grep /^radius_/, fields('svc_acct') ) {
1075     $self->ut_textn($_);
1076   }
1077
1078   if ( $recref->{_password_encoding} eq 'ldap' ) {
1079
1080     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1081       $recref->{_password} = uc($1).$2;
1082     } else {
1083       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1084     }
1085
1086   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1087
1088     if ( $recref->{_password} =~
1089            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1090            /^(!!?)?(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1091        ) {
1092
1093       $recref->{_password} = $1.$2;
1094
1095     } else {
1096       return 'Illegal (crypt-encoded) password';
1097     }
1098
1099   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1100
1101     #generate a password if it is blank
1102     $recref->{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) )
1103       unless length( $recref->{_password} );
1104
1105     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1106       $recref->{_password} = $1;
1107     } else {
1108       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1109              FS::Msgcat::_gettext('illegal_password_characters').
1110              ": ". $recref->{_password};
1111     }
1112
1113     if ( $password_noampersand ) {
1114       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1115     }
1116     if ( $password_noexclamation ) {
1117       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1118     }
1119
1120   } else {
1121
1122     #carp "warning: _password_encoding unspecified\n";
1123
1124     #generate a password if it is blank
1125     unless ( length( $recref->{_password} ) ) {
1126
1127       $recref->{_password} =
1128         join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1129       $recref->{_password_encoding} = 'plain';
1130
1131     } else {
1132
1133       #if ( $recref->{_password} =~ /^((\*SUSPENDED\* )?)([^\t\n]{4,16})$/ ) {
1134       if ( $recref->{_password} =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1135         $recref->{_password} = $1.$3;
1136         $recref->{_password_encoding} = 'plain';
1137       } elsif ( $recref->{_password} =~
1138                   /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/
1139               ) {
1140         $recref->{_password} = $1.$3;
1141         $recref->{_password_encoding} = 'crypt';
1142       } elsif ( $recref->{_password} eq '*' ) {
1143         $recref->{_password} = '*';
1144         $recref->{_password_encoding} = 'crypt';
1145       } elsif ( $recref->{_password} eq '!' ) {
1146         $recref->{_password_encoding} = 'crypt';
1147         $recref->{_password} = '!';
1148       } elsif ( $recref->{_password} eq '!!' ) {
1149         $recref->{_password} = '!!';
1150         $recref->{_password_encoding} = 'crypt';
1151       } else {
1152         #return "Illegal password";
1153         return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1154                FS::Msgcat::_gettext('illegal_password_characters').
1155                ": ". $recref->{_password};
1156       }
1157
1158     }
1159
1160   }
1161
1162   $self->SUPER::check;
1163
1164 }
1165
1166 =item _check_system
1167
1168 Internal function to check the username against the list of system usernames
1169 from the I<system_usernames> configuration value.  Returns true if the username
1170 is listed on the system username list.
1171
1172 =cut
1173
1174 sub _check_system {
1175   my $self = shift;
1176   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1177                $conf->config('system_usernames')
1178         );
1179 }
1180
1181 =item _check_duplicate
1182
1183 Internal function to check for duplicates usernames, username@domain pairs and
1184 uids.
1185
1186 If the I<global_unique-username> configuration value is set to B<username> or
1187 B<username@domain>, enforces global username or username@domain uniqueness.
1188
1189 In all cases, check for duplicate uids and usernames or username@domain pairs
1190 per export and with identical I<svcpart> values.
1191
1192 =cut
1193
1194 sub _check_duplicate {
1195   my $self = shift;
1196
1197   my $global_unique = $conf->config('global_unique-username') || 'none';
1198   return '' if $global_unique eq 'disabled';
1199
1200   #this is Pg-specific.  what to do for mysql etc?
1201   # ( mysql LOCK TABLES certainly isn't equivalent or useful here :/ )
1202   warn "$me locking svc_acct table for duplicate search" if $DEBUG;
1203   dbh->do("LOCK TABLE svc_acct IN SHARE ROW EXCLUSIVE MODE")
1204     or die dbh->errstr;
1205   warn "$me acquired svc_acct table lock for duplicate search" if $DEBUG;
1206
1207   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1208   unless ( $part_svc ) {
1209     return 'unknown svcpart '. $self->svcpart;
1210   }
1211
1212   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1213                  qsearch( 'svc_acct', { 'username' => $self->username } );
1214   return gettext('username_in_use')
1215     if $global_unique eq 'username' && @dup_user;
1216
1217   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1218                        qsearch( 'svc_acct', { 'username' => $self->username,
1219                                               'domsvc'   => $self->domsvc } );
1220   return gettext('username_in_use')
1221     if $global_unique eq 'username@domain' && @dup_userdomain;
1222
1223   my @dup_uid;
1224   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1225        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1226     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1227                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1228   } else {
1229     @dup_uid = ();
1230   }
1231
1232   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1233     my $exports = FS::part_export::export_info('svc_acct');
1234     my %conflict_user_svcpart;
1235     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1236
1237     foreach my $part_export ( $part_svc->part_export ) {
1238
1239       #this will catch to the same exact export
1240       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1241
1242       #this will catch to exports w/same exporthost+type ???
1243       #my @other_part_export = qsearch('part_export', {
1244       #  'machine'    => $part_export->machine,
1245       #  'exporttype' => $part_export->exporttype,
1246       #} );
1247       #foreach my $other_part_export ( @other_part_export ) {
1248       #  push @svcparts, map { $_->svcpart }
1249       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1250       #}
1251
1252       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1253       #silly kludge to avoid uninitialized value errors
1254       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1255                      ? $exports->{$part_export->exporttype}{'nodomain'}
1256                      : '';
1257       if ( $nodomain =~ /^Y/i ) {
1258         $conflict_user_svcpart{$_} = $part_export->exportnum
1259           foreach @svcparts;
1260       } else {
1261         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1262           foreach @svcparts;
1263       }
1264     }
1265
1266     foreach my $dup_user ( @dup_user ) {
1267       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1268       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1269         return "duplicate username: conflicts with svcnum ". $dup_user->svcnum.
1270                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1271       }
1272     }
1273
1274     foreach my $dup_userdomain ( @dup_userdomain ) {
1275       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1276       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1277         return "duplicate username\@domain: conflicts with svcnum ".
1278                $dup_userdomain->svcnum. " via exportnum ".
1279                $conflict_userdomain_svcpart{$dup_svcpart};
1280       }
1281     }
1282
1283     foreach my $dup_uid ( @dup_uid ) {
1284       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1285       if ( exists($conflict_user_svcpart{$dup_svcpart})
1286            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1287         return "duplicate uid: conflicts with svcnum ". $dup_uid->svcnum.
1288                " via exportnum ". $conflict_user_svcpart{$dup_svcpart}
1289                                  || $conflict_userdomain_svcpart{$dup_svcpart};
1290       }
1291     }
1292
1293   }
1294
1295   return '';
1296
1297 }
1298
1299 =item radius
1300
1301 Depriciated, use radius_reply instead.
1302
1303 =cut
1304
1305 sub radius {
1306   carp "FS::svc_acct::radius depriciated, use radius_reply";
1307   $_[0]->radius_reply;
1308 }
1309
1310 =item radius_reply
1311
1312 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1313 reply attributes of this record.
1314
1315 Note that this is now the preferred method for reading RADIUS attributes -
1316 accessing the columns directly is discouraged, as the column names are
1317 expected to change in the future.
1318
1319 =cut
1320
1321 sub radius_reply {
1322   my $self = shift;
1323
1324   return %{ $self->{'radius_reply'} }
1325     if exists $self->{'radius_reply'};
1326
1327   my %reply =
1328     map {
1329       /^(radius_(.*))$/;
1330       my($column, $attrib) = ($1, $2);
1331       #$attrib =~ s/_/\-/g;
1332       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1333     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1334
1335   if ( $self->slipip && $self->slipip ne '0e0' ) {
1336     $reply{$radius_ip} = $self->slipip;
1337   }
1338
1339   if ( $self->seconds !~ /^$/ ) {
1340     $reply{'Session-Timeout'} = $self->seconds;
1341   }
1342
1343   %reply;
1344 }
1345
1346 =item radius_check
1347
1348 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1349 check attributes of this record.
1350
1351 Note that this is now the preferred method for reading RADIUS attributes -
1352 accessing the columns directly is discouraged, as the column names are
1353 expected to change in the future.
1354
1355 =cut
1356
1357 sub radius_check {
1358   my $self = shift;
1359
1360   return %{ $self->{'radius_check'} }
1361     if exists $self->{'radius_check'};
1362
1363   my %check =
1364     map {
1365       /^(rc_(.*))$/;
1366       my($column, $attrib) = ($1, $2);
1367       #$attrib =~ s/_/\-/g;
1368       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1369     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1370
1371   my $password = $self->_password;
1372   my $pw_attrib = length($password) <= 12 ? $radius_password : 'Crypt-Password';  $check{$pw_attrib} = $password;
1373
1374   my $cust_svc = $self->cust_svc;
1375   die "FATAL: no cust_svc record for svc_acct.svcnum ". $self->svcnum. "\n"
1376     unless $cust_svc;
1377   my $cust_pkg = $cust_svc->cust_pkg;
1378   if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1379     $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1380   }
1381
1382   %check;
1383
1384 }
1385
1386 =item snapshot
1387
1388 This method instructs the object to "snapshot" or freeze RADIUS check and
1389 reply attributes to the current values.
1390
1391 =cut
1392
1393 #bah, my english is too broken this morning
1394 #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
1395 #the FS::cust_pkg's replace method to trigger the correct export updates when
1396 #package dates change)
1397
1398 sub snapshot {
1399   my $self = shift;
1400
1401   $self->{$_} = { $self->$_() }
1402     foreach qw( radius_reply radius_check );
1403
1404 }
1405
1406 =item forget_snapshot
1407
1408 This methos instructs the object to forget any previously snapshotted
1409 RADIUS check and reply attributes.
1410
1411 =cut
1412
1413 sub forget_snapshot {
1414   my $self = shift;
1415
1416   delete $self->{$_}
1417     foreach qw( radius_reply radius_check );
1418
1419 }
1420
1421 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1422
1423 Returns the domain associated with this account.
1424
1425 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1426 history records.
1427
1428 =cut
1429
1430 sub domain {
1431   my $self = shift;
1432   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1433   my $svc_domain = $self->svc_domain(@_)
1434     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1435   $svc_domain->domain;
1436 }
1437
1438 =item svc_domain
1439
1440 Returns the FS::svc_domain record for this account's domain (see
1441 L<FS::svc_domain>).
1442
1443 =cut
1444
1445 # FS::h_svc_acct has a history-aware svc_domain override
1446
1447 sub svc_domain {
1448   my $self = shift;
1449   $self->{'_domsvc'}
1450     ? $self->{'_domsvc'}
1451     : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
1452 }
1453
1454 =item cust_svc
1455
1456 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1457
1458 =cut
1459
1460 #inherited from svc_Common
1461
1462 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1463
1464 Returns an email address associated with the account.
1465
1466 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1467 history records.
1468
1469 =cut
1470
1471 sub email {
1472   my $self = shift;
1473   $self->username. '@'. $self->domain(@_);
1474 }
1475
1476 =item acct_snarf
1477
1478 Returns an array of FS::acct_snarf records associated with the account.
1479 If the acct_snarf table does not exist or there are no associated records,
1480 an empty list is returned
1481
1482 =cut
1483
1484 sub acct_snarf {
1485   my $self = shift;
1486   return () unless dbdef->table('acct_snarf');
1487   eval "use FS::acct_snarf;";
1488   die $@ if $@;
1489   qsearch('acct_snarf', { 'svcnum' => $self->svcnum } );
1490 }
1491
1492 =item decrement_upbytes OCTETS
1493
1494 Decrements the I<upbytes> field of this record by the given amount.  If there
1495 is an error, returns the error, otherwise returns false.
1496
1497 =cut
1498
1499 sub decrement_upbytes {
1500   shift->_op_usage('-', 'upbytes', @_);
1501 }
1502
1503 =item increment_upbytes OCTETS
1504
1505 Increments the I<upbytes> field of this record by the given amount.  If there
1506 is an error, returns the error, otherwise returns false.
1507
1508 =cut
1509
1510 sub increment_upbytes {
1511   shift->_op_usage('+', 'upbytes', @_);
1512 }
1513
1514 =item decrement_downbytes OCTETS
1515
1516 Decrements the I<downbytes> field of this record by the given amount.  If there
1517 is an error, returns the error, otherwise returns false.
1518
1519 =cut
1520
1521 sub decrement_downbytes {
1522   shift->_op_usage('-', 'downbytes', @_);
1523 }
1524
1525 =item increment_downbytes OCTETS
1526
1527 Increments the I<downbytes> field of this record by the given amount.  If there
1528 is an error, returns the error, otherwise returns false.
1529
1530 =cut
1531
1532 sub increment_downbytes {
1533   shift->_op_usage('+', 'downbytes', @_);
1534 }
1535
1536 =item decrement_totalbytes OCTETS
1537
1538 Decrements the I<totalbytes> field of this record by the given amount.  If there
1539 is an error, returns the error, otherwise returns false.
1540
1541 =cut
1542
1543 sub decrement_totalbytes {
1544   shift->_op_usage('-', 'totalbytes', @_);
1545 }
1546
1547 =item increment_totalbytes OCTETS
1548
1549 Increments the I<totalbytes> field of this record by the given amount.  If there
1550 is an error, returns the error, otherwise returns false.
1551
1552 =cut
1553
1554 sub increment_totalbytes {
1555   shift->_op_usage('+', 'totalbytes', @_);
1556 }
1557
1558 =item decrement_seconds SECONDS
1559
1560 Decrements the I<seconds> field of this record by the given amount.  If there
1561 is an error, returns the error, otherwise returns false.
1562
1563 =cut
1564
1565 sub decrement_seconds {
1566   shift->_op_usage('-', 'seconds', @_);
1567 }
1568
1569 =item increment_seconds SECONDS
1570
1571 Increments the I<seconds> field of this record by the given amount.  If there
1572 is an error, returns the error, otherwise returns false.
1573
1574 =cut
1575
1576 sub increment_seconds {
1577   shift->_op_usage('+', 'seconds', @_);
1578 }
1579
1580
1581 my %op2action = (
1582   '-' => 'suspend',
1583   '+' => 'unsuspend',
1584 );
1585 my %op2condition = (
1586   '-' => sub { my($self, $column, $amount) = @_;
1587                $self->$column - $amount <= 0;
1588              },
1589   '+' => sub { my($self, $column, $amount) = @_;
1590                $self->$column + $amount > 0;
1591              },
1592 );
1593 my %op2warncondition = (
1594   '-' => sub { my($self, $column, $amount) = @_;
1595                my $threshold = $column . '_threshold';
1596                $self->$column - $amount <= $self->$threshold + 0;
1597              },
1598   '+' => sub { my($self, $column, $amount) = @_;
1599                $self->$column + $amount > 0;
1600              },
1601 );
1602
1603 sub _op_usage {
1604   my( $self, $op, $column, $amount ) = @_;
1605
1606   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1607        ' ('. $self->email. "): $op $amount\n"
1608     if $DEBUG;
1609
1610   return '' unless $amount;
1611
1612   local $SIG{HUP} = 'IGNORE';
1613   local $SIG{INT} = 'IGNORE';
1614   local $SIG{QUIT} = 'IGNORE';
1615   local $SIG{TERM} = 'IGNORE';
1616   local $SIG{TSTP} = 'IGNORE';
1617   local $SIG{PIPE} = 'IGNORE';
1618
1619   my $oldAutoCommit = $FS::UID::AutoCommit;
1620   local $FS::UID::AutoCommit = 0;
1621   my $dbh = dbh;
1622
1623   my $sql = "UPDATE svc_acct SET $column = ".
1624             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1625             " $op ? WHERE svcnum = ?";
1626   warn "$me $sql\n"
1627     if $DEBUG;
1628
1629   my $sth = $dbh->prepare( $sql )
1630     or die "Error preparing $sql: ". $dbh->errstr;
1631   my $rv = $sth->execute($amount, $self->svcnum);
1632   die "Error executing $sql: ". $sth->errstr
1633     unless defined($rv);
1634   die "Can't update $column for svcnum". $self->svcnum
1635     if $rv == 0;
1636
1637   my $action = $op2action{$op};
1638
1639   if ( &{$op2condition{$op}}($self, $column, $amount) &&
1640         ( $action eq 'suspend'   && !$self->overlimit
1641        || $action eq 'unsuspend' &&  $self->overlimit )
1642      ) {
1643     foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1644       if ($part_export->option('overlimit_groups')) {
1645         my ($new,$old);
1646         my $other = new FS::svc_acct $self->hashref;
1647         my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1648                        ($self, $part_export->option('overlimit_groups'));
1649         $other->usergroup( $groups );
1650         if ($action eq 'suspend'){
1651           $new = $other; $old = $self;
1652         }else{
1653           $new = $self; $old = $other;
1654         }
1655         my $error = $part_export->export_replace($new, $old);
1656         $error ||= $self->overlimit($action);
1657         if ( $error ) {
1658           $dbh->rollback if $oldAutoCommit;
1659           return "Error replacing radius groups in export, ${op}: $error";
1660         }
1661       }
1662     }
1663   }
1664
1665   if ( $conf->exists("svc_acct-usage_$action")
1666        && &{$op2condition{$op}}($self, $column, $amount)    ) {
1667     #my $error = $self->$action();
1668     my $error = $self->cust_svc->cust_pkg->$action();
1669     # $error ||= $self->overlimit($action);
1670     if ( $error ) {
1671       $dbh->rollback if $oldAutoCommit;
1672       return "Error ${action}ing: $error";
1673     }
1674   }
1675
1676   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
1677     my $wqueue = new FS::queue {
1678       'svcnum' => $self->svcnum,
1679       'job'    => 'FS::svc_acct::reached_threshold',
1680     };
1681
1682     my $to = '';
1683     if ($op eq '-'){
1684       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
1685     }
1686
1687     # x_threshold race
1688     my $error = $wqueue->insert(
1689       'svcnum' => $self->svcnum,
1690       'op'     => $op,
1691       'column' => $column,
1692       'to'     => $to,
1693     );
1694     if ( $error ) {
1695       $dbh->rollback if $oldAutoCommit;
1696       return "Error queuing threshold activity: $error";
1697     }
1698   }
1699
1700   warn "$me update successful; committing\n"
1701     if $DEBUG;
1702   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1703   '';
1704
1705 }
1706
1707 sub set_usage {
1708   my( $self, $valueref ) = @_;
1709
1710   warn "$me set_usage called for svcnum ". $self->svcnum.
1711        ' ('. $self->email. "): ".
1712        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
1713     if $DEBUG;
1714
1715   local $SIG{HUP} = 'IGNORE';
1716   local $SIG{INT} = 'IGNORE';
1717   local $SIG{QUIT} = 'IGNORE';
1718   local $SIG{TERM} = 'IGNORE';
1719   local $SIG{TSTP} = 'IGNORE';
1720   local $SIG{PIPE} = 'IGNORE';
1721
1722   local $FS::svc_Common::noexport_hack = 1;
1723   my $oldAutoCommit = $FS::UID::AutoCommit;
1724   local $FS::UID::AutoCommit = 0;
1725   my $dbh = dbh;
1726
1727   my $reset = 0;
1728   my %handyhash = ();
1729   foreach my $field (keys %$valueref){
1730     $reset = 1 if $valueref->{$field};
1731     $self->setfield($field, $valueref->{$field});
1732     $self->setfield( $field.'_threshold',
1733                      int($self->getfield($field)
1734                          * ( $conf->exists('svc_acct-usage_threshold')
1735                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
1736                              : 0.20
1737                            )
1738                        )
1739                      );
1740     $handyhash{$field} = $self->getfield($field);
1741     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
1742   }
1743   #my $error = $self->replace;   #NO! we avoid the call to ->check for
1744   #die $error if $error;         #services not explicity changed via the UI
1745
1746   my $sql = "UPDATE svc_acct SET " .
1747     join (',', map { "$_ =  ?" } (keys %handyhash) ).
1748     " WHERE svcnum = ?";
1749
1750   warn "$me $sql\n"
1751     if $DEBUG;
1752
1753   if (scalar(keys %handyhash)) {
1754     my $sth = $dbh->prepare( $sql )
1755       or die "Error preparing $sql: ". $dbh->errstr;
1756     my $rv = $sth->execute((values %handyhash), $self->svcnum);
1757     die "Error executing $sql: ". $sth->errstr
1758       unless defined($rv);
1759     die "Can't update usage for svcnum ". $self->svcnum
1760       if $rv == 0;
1761   }
1762
1763   if ( $reset ) {
1764     my $error;
1765
1766     if ($self->overlimit) {
1767       $error = $self->overlimit('unsuspend');
1768       foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
1769         if ($part_export->option('overlimit_groups')) {
1770           my $old = new FS::svc_acct $self->hashref;
1771           my $groups = &{ $self->_fieldhandlers->{'usergroup'} }
1772                          ($self, $part_export->option('overlimit_groups'));
1773           $old->usergroup( $groups );
1774           $error ||= $part_export->export_replace($self, $old);
1775         }
1776       }
1777     }
1778
1779     if ( $conf->exists("svc_acct-usage_unsuspend")) {
1780       $error ||= $self->cust_svc->cust_pkg->unsuspend;
1781     }
1782     if ( $error ) {
1783       $dbh->rollback if $oldAutoCommit;
1784       return "Error unsuspending: $error";
1785     }
1786   }
1787
1788   warn "$me update successful; committing\n"
1789     if $DEBUG;
1790   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1791   '';
1792
1793 }
1794
1795
1796 =item recharge HASHREF
1797
1798   Increments usage columns by the amount specified in HASHREF as
1799   column=>amount pairs.
1800
1801 =cut
1802
1803 sub recharge {
1804   my ($self, $vhash) = @_;
1805
1806   if ( $DEBUG ) {
1807     warn "[$me] recharge called on $self: ". Dumper($self).
1808          "\nwith vhash: ". Dumper($vhash);
1809   }
1810
1811   my $oldAutoCommit = $FS::UID::AutoCommit;
1812   local $FS::UID::AutoCommit = 0;
1813   my $dbh = dbh;
1814   my $error = '';
1815
1816   foreach my $column (keys %$vhash){
1817     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
1818   }
1819
1820   if ( $error ) {
1821     $dbh->rollback if $oldAutoCommit;
1822   }else{
1823     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1824   }
1825   return $error;
1826 }
1827
1828 =item is_rechargeable
1829
1830 Returns true if this svc_account can be "recharged" and false otherwise.
1831
1832 =cut
1833
1834 sub is_rechargable {
1835   my $self = shift;
1836   $self->seconds ne ''
1837     || $self->upbytes ne ''
1838     || $self->downbytes ne ''
1839     || $self->totalbytes ne '';
1840 }
1841
1842 =item seconds_since TIMESTAMP
1843
1844 Returns the number of seconds this account has been online since TIMESTAMP,
1845 according to the session monitor (see L<FS::Session>).
1846
1847 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
1848 L<Time::Local> and L<Date::Parse> for conversion functions.
1849
1850 =cut
1851
1852 #note: POD here, implementation in FS::cust_svc
1853 sub seconds_since {
1854   my $self = shift;
1855   $self->cust_svc->seconds_since(@_);
1856 }
1857
1858 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
1859
1860 Returns the numbers of seconds this account has been online between
1861 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
1862 external SQL radacct table, specified via sqlradius export.  Sessions which
1863 started in the specified range but are still open are counted from session
1864 start to the end of the range (unless they are over 1 day old, in which case
1865 they are presumed missing their stop record and not counted).  Also, sessions
1866 which end in the range but started earlier are counted from the start of the
1867 range to session end.  Finally, sessions which start before the range but end
1868 after are counted for the entire range.
1869
1870 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1871 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1872 functions.
1873
1874 =cut
1875
1876 #note: POD here, implementation in FS::cust_svc
1877 sub seconds_since_sqlradacct {
1878   my $self = shift;
1879   $self->cust_svc->seconds_since_sqlradacct(@_);
1880 }
1881
1882 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
1883
1884 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
1885 in this package for sessions ending between TIMESTAMP_START (inclusive) and
1886 TIMESTAMP_END (exclusive).
1887
1888 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
1889 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
1890 functions.
1891
1892 =cut
1893
1894 #note: POD here, implementation in FS::cust_svc
1895 sub attribute_since_sqlradacct {
1896   my $self = shift;
1897   $self->cust_svc->attribute_since_sqlradacct(@_);
1898 }
1899
1900 =item get_session_history TIMESTAMP_START TIMESTAMP_END
1901
1902 Returns an array of hash references of this customers login history for the
1903 given time range.  (document this better)
1904
1905 =cut
1906
1907 sub get_session_history {
1908   my $self = shift;
1909   $self->cust_svc->get_session_history(@_);
1910 }
1911
1912 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
1913
1914 =cut
1915
1916 sub get_cdrs {
1917   my($self, $start, $end, %opt ) = @_;
1918
1919   my $did = $self->username; #yup
1920
1921   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
1922
1923   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
1924
1925   #SELECT $for_update * FROM cdr
1926   #  WHERE calldate >= $start #need a conversion
1927   #    AND calldate <  $end   #ditto
1928   #    AND (    charged_party = "$did"
1929   #          OR charged_party = "$prefix$did" #if length($prefix);
1930   #          OR ( ( charged_party IS NULL OR charged_party = '' )
1931   #               AND
1932   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
1933   #             )
1934   #        )
1935   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
1936
1937   my $charged_or_src;
1938   if ( length($prefix) ) {
1939     $charged_or_src =
1940       " AND (    charged_party = '$did'
1941               OR charged_party = '$prefix$did'
1942               OR ( ( charged_party IS NULL OR charged_party = '' )
1943                    AND
1944                    ( src = '$did' OR src = '$prefix$did' )
1945                  )
1946             )
1947       ";
1948   } else {
1949     $charged_or_src =
1950       " AND (    charged_party = '$did'
1951               OR ( ( charged_party IS NULL OR charged_party = '' )
1952                    AND
1953                    src = '$did'
1954                  )
1955             )
1956       ";
1957
1958   }
1959
1960   qsearch(
1961     'select'    => "$for_update *",
1962     'table'     => 'cdr',
1963     'hashref'   => {
1964                      #( freesidestatus IS NULL OR freesidestatus = '' )
1965                      'freesidestatus' => '',
1966                    },
1967     'extra_sql' => $charged_or_src,
1968
1969   );
1970
1971 }
1972
1973 =item radius_groups
1974
1975 Returns all RADIUS groups for this account (see L<FS::radius_usergroup>).
1976
1977 =cut
1978
1979 sub radius_groups {
1980   my $self = shift;
1981   if ( $self->usergroup ) {
1982     confess "explicitly specified usergroup not an arrayref: ". $self->usergroup
1983       unless ref($self->usergroup) eq 'ARRAY';
1984     #when provisioning records, export callback runs in svc_Common.pm before
1985     #radius_usergroup records can be inserted...
1986     @{$self->usergroup};
1987   } else {
1988     map { $_->groupname }
1989       qsearch('radius_usergroup', { 'svcnum' => $self->svcnum } );
1990   }
1991 }
1992
1993 =item clone_suspended
1994
1995 Constructor used by FS::part_export::_export_suspend fallback.  Document
1996 better.
1997
1998 =cut
1999
2000 sub clone_suspended {
2001   my $self = shift;
2002   my %hash = $self->hash;
2003   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2004   new FS::svc_acct \%hash;
2005 }
2006
2007 =item clone_kludge_unsuspend
2008
2009 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2010 better.
2011
2012 =cut
2013
2014 sub clone_kludge_unsuspend {
2015   my $self = shift;
2016   my %hash = $self->hash;
2017   $hash{_password} = '';
2018   new FS::svc_acct \%hash;
2019 }
2020
2021 =item check_password
2022
2023 Checks the supplied password against the (possibly encrypted) password in the
2024 database.  Returns true for a successful authentication, false for no match.
2025
2026 Currently supported encryptions are: classic DES crypt() and MD5
2027
2028 =cut
2029
2030 sub check_password {
2031   my($self, $check_password) = @_;
2032
2033   #remove old-style SUSPENDED kludge, they should be allowed to login to
2034   #self-service and pay up
2035   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2036
2037   if ( $self->_password_encoding eq 'ldap' ) {
2038
2039     my $auth = from_rfc2307 Authen::Passphrase $self->_password;
2040     return $auth->match($check_password);
2041
2042   } elsif ( $self->_password_encoding eq 'crypt' ) {
2043
2044     my $auth = from_crypt Authen::Passphrase $self->_password;
2045     return $auth->match($check_password);
2046
2047   } elsif ( $self->_password_encoding eq 'plain' ) {
2048
2049     return $check_password eq $password;
2050
2051   } else {
2052
2053     #XXX this could be replaced with Authen::Passphrase stuff
2054
2055     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2056       return 0;
2057     } elsif ( length($password) < 13 ) { #plaintext
2058       $check_password eq $password;
2059     } elsif ( length($password) == 13 ) { #traditional DES crypt
2060       crypt($check_password, $password) eq $password;
2061     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2062       unix_md5_crypt($check_password, $password) eq $password;
2063     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2064       warn "Can't check password: Blowfish encryption not yet supported, ".
2065            "svcnum ".  $self->svcnum. "\n";
2066       0;
2067     } else {
2068       warn "Can't check password: Unrecognized encryption for svcnum ".
2069            $self->svcnum. "\n";
2070       0;
2071     }
2072
2073   }
2074
2075 }
2076
2077 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2078
2079 Returns an encrypted password, either by passing through an encrypted password
2080 in the database or by encrypting a plaintext password from the database.
2081
2082 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2083 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2084 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2085 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2086 encryption type is only used if the password is not already encrypted in the
2087 database.
2088
2089 =cut
2090
2091 sub crypt_password {
2092   my $self = shift;
2093
2094   if ( $self->_password_encoding eq 'ldap' ) {
2095
2096     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2097       my $plain = $2;
2098
2099       #XXX this could be replaced with Authen::Passphrase stuff
2100
2101       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2102       if ( $encryption eq 'crypt' ) {
2103         crypt(
2104           $self->_password,
2105           $saltset[int(rand(64))].$saltset[int(rand(64))]
2106         );
2107       } elsif ( $encryption eq 'md5' ) {
2108         unix_md5_crypt( $self->_password );
2109       } elsif ( $encryption eq 'blowfish' ) {
2110         croak "unknown encryption method $encryption";
2111       } else {
2112         croak "unknown encryption method $encryption";
2113       }
2114
2115     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2116       $1;
2117     }
2118
2119   } elsif ( $self->_password_encoding eq 'crypt' ) {
2120
2121     return $self->_password;
2122
2123   } elsif ( $self->_password_encoding eq 'plain' ) {
2124
2125     #XXX this could be replaced with Authen::Passphrase stuff
2126
2127     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2128     if ( $encryption eq 'crypt' ) {
2129       crypt(
2130         $self->_password,
2131         $saltset[int(rand(64))].$saltset[int(rand(64))]
2132       );
2133     } elsif ( $encryption eq 'md5' ) {
2134       unix_md5_crypt( $self->_password );
2135     } elsif ( $encryption eq 'blowfish' ) {
2136       croak "unknown encryption method $encryption";
2137     } else {
2138       croak "unknown encryption method $encryption";
2139     }
2140
2141   } else {
2142
2143     if ( length($self->_password) == 13
2144          || $self->_password =~ /^\$(1|2a?)\$/
2145          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2146        )
2147     {
2148       $self->_password;
2149     } else {
2150
2151       #XXX this could be replaced with Authen::Passphrase stuff
2152
2153       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2154       if ( $encryption eq 'crypt' ) {
2155         crypt(
2156           $self->_password,
2157           $saltset[int(rand(64))].$saltset[int(rand(64))]
2158         );
2159       } elsif ( $encryption eq 'md5' ) {
2160         unix_md5_crypt( $self->_password );
2161       } elsif ( $encryption eq 'blowfish' ) {
2162         croak "unknown encryption method $encryption";
2163       } else {
2164         croak "unknown encryption method $encryption";
2165       }
2166
2167     }
2168
2169   }
2170
2171 }
2172
2173 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2174
2175 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2176 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2177 "{MD5}5426824942db4253f87a1009fd5d2d4".
2178
2179 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2180 to work the same as the B</crypt_password> method.
2181
2182 =cut
2183
2184 sub ldap_password {
2185   my $self = shift;
2186   #eventually should check a "password-encoding" field
2187
2188   if ( $self->_password_encoding eq 'ldap' ) {
2189
2190     return $self->_password;
2191
2192   } elsif ( $self->_password_encoding eq 'crypt' ) {
2193
2194     if ( length($self->_password) == 13 ) { #crypt
2195       return '{CRYPT}'. $self->_password;
2196     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2197       return '{MD5}'. $1;
2198     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2199     #  die "Blowfish encryption not supported in this context, svcnum ".
2200     #      $self->svcnum. "\n";
2201     } else {
2202       warn "encryption method not (yet?) supported in LDAP context";
2203       return '{CRYPT}*'; #unsupported, should not auth
2204     }
2205
2206   } elsif ( $self->_password_encoding eq 'plain' ) {
2207
2208     return '{PLAIN}'. $self->_password;
2209
2210     #return '{CLEARTEXT}'. $self->_password; #?
2211
2212   } else {
2213
2214     if ( length($self->_password) == 13 ) { #crypt
2215       return '{CRYPT}'. $self->_password;
2216     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2217       return '{MD5}'. $1;
2218     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2219       warn "Blowfish encryption not supported in this context, svcnum ".
2220           $self->svcnum. "\n";
2221       return '{CRYPT}*';
2222
2223     #are these two necessary anymore?
2224     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2225       return '{SSHA}'. $1;
2226     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2227       return '{NS-MTA-MD5}'. $1;
2228
2229     } else { #plaintext
2230       return '{PLAIN}'. $self->_password;
2231
2232       #return '{CLEARTEXT}'. $self->_password; #?
2233
2234       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2235       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2236       #if ( $encryption eq 'crypt' ) {
2237       #  return '{CRYPT}'. crypt(
2238       #    $self->_password,
2239       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2240       #  );
2241       #} elsif ( $encryption eq 'md5' ) {
2242       #  unix_md5_crypt( $self->_password );
2243       #} elsif ( $encryption eq 'blowfish' ) {
2244       #  croak "unknown encryption method $encryption";
2245       #} else {
2246       #  croak "unknown encryption method $encryption";
2247       #}
2248     }
2249
2250   }
2251
2252 }
2253
2254 =item domain_slash_username
2255
2256 Returns $domain/$username/
2257
2258 =cut
2259
2260 sub domain_slash_username {
2261   my $self = shift;
2262   $self->domain. '/'. $self->username. '/';
2263 }
2264
2265 =item virtual_maildir
2266
2267 Returns $domain/maildirs/$username/
2268
2269 =cut
2270
2271 sub virtual_maildir {
2272   my $self = shift;
2273   $self->domain. '/maildirs/'. $self->username. '/';
2274 }
2275
2276 =back
2277
2278 =head1 SUBROUTINES
2279
2280 =over 4
2281
2282 =item send_email
2283
2284 This is the FS::svc_acct job-queue-able version.  It still uses
2285 FS::Misc::send_email under-the-hood.
2286
2287 =cut
2288
2289 sub send_email {
2290   my %opt = @_;
2291
2292   eval "use FS::Misc qw(send_email)";
2293   die $@ if $@;
2294
2295   $opt{mimetype} ||= 'text/plain';
2296   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2297
2298   my $error = send_email(
2299     'from'         => $opt{from},
2300     'to'           => $opt{to},
2301     'subject'      => $opt{subject},
2302     'content-type' => $opt{mimetype},
2303     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2304   );
2305   die $error if $error;
2306 }
2307
2308 =item check_and_rebuild_fuzzyfiles
2309
2310 =cut
2311
2312 sub check_and_rebuild_fuzzyfiles {
2313   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2314   -e "$dir/svc_acct.username"
2315     or &rebuild_fuzzyfiles;
2316 }
2317
2318 =item rebuild_fuzzyfiles
2319
2320 =cut
2321
2322 sub rebuild_fuzzyfiles {
2323
2324   use Fcntl qw(:flock);
2325
2326   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2327
2328   #username
2329
2330   open(USERNAMELOCK,">>$dir/svc_acct.username")
2331     or die "can't open $dir/svc_acct.username: $!";
2332   flock(USERNAMELOCK,LOCK_EX)
2333     or die "can't lock $dir/svc_acct.username: $!";
2334
2335   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2336
2337   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2338     or die "can't open $dir/svc_acct.username.tmp: $!";
2339   print USERNAMECACHE join("\n", @all_username), "\n";
2340   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2341
2342   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2343   close USERNAMELOCK;
2344
2345 }
2346
2347 =item all_username
2348
2349 =cut
2350
2351 sub all_username {
2352   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2353   open(USERNAMECACHE,"<$dir/svc_acct.username")
2354     or die "can't open $dir/svc_acct.username: $!";
2355   my @array = map { chomp; $_; } <USERNAMECACHE>;
2356   close USERNAMECACHE;
2357   \@array;
2358 }
2359
2360 =item append_fuzzyfiles USERNAME
2361
2362 =cut
2363
2364 sub append_fuzzyfiles {
2365   my $username = shift;
2366
2367   &check_and_rebuild_fuzzyfiles;
2368
2369   use Fcntl qw(:flock);
2370
2371   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2372
2373   open(USERNAME,">>$dir/svc_acct.username")
2374     or die "can't open $dir/svc_acct.username: $!";
2375   flock(USERNAME,LOCK_EX)
2376     or die "can't lock $dir/svc_acct.username: $!";
2377
2378   print USERNAME "$username\n";
2379
2380   flock(USERNAME,LOCK_UN)
2381     or die "can't unlock $dir/svc_acct.username: $!";
2382   close USERNAME;
2383
2384   1;
2385 }
2386
2387
2388
2389 =item radius_usergroup_selector GROUPS_ARRAYREF [ SELECTNAME ]
2390
2391 =cut
2392
2393 sub radius_usergroup_selector {
2394   my $sel_groups = shift;
2395   my %sel_groups = map { $_=>1 } @$sel_groups;
2396
2397   my $selectname = shift || 'radius_usergroup';
2398
2399   my $dbh = dbh;
2400   my $sth = $dbh->prepare(
2401     'SELECT DISTINCT(groupname) FROM radius_usergroup ORDER BY groupname'
2402   ) or die $dbh->errstr;
2403   $sth->execute() or die $sth->errstr;
2404   my @all_groups = map { $_->[0] } @{$sth->fetchall_arrayref};
2405
2406   my $html = <<END;
2407     <SCRIPT>
2408     function ${selectname}_doadd(object) {
2409       var myvalue = object.${selectname}_add.value;
2410       var optionName = new Option(myvalue,myvalue,false,true);
2411       var length = object.$selectname.length;
2412       object.$selectname.options[length] = optionName;
2413       object.${selectname}_add.value = "";
2414     }
2415     </SCRIPT>
2416     <SELECT MULTIPLE NAME="$selectname">
2417 END
2418
2419   foreach my $group ( @all_groups ) {
2420     $html .= qq(<OPTION VALUE="$group");
2421     if ( $sel_groups{$group} ) {
2422       $html .= ' SELECTED';
2423       $sel_groups{$group} = 0;
2424     }
2425     $html .= ">$group</OPTION>\n";
2426   }
2427   foreach my $group ( grep { $sel_groups{$_} } keys %sel_groups ) {
2428     $html .= qq(<OPTION VALUE="$group" SELECTED>$group</OPTION>\n);
2429   };
2430   $html .= '</SELECT>';
2431
2432   $html .= qq!<BR><INPUT TYPE="text" NAME="${selectname}_add">!.
2433            qq!<INPUT TYPE="button" VALUE="Add new group" onClick="${selectname}_doadd(this.form)">!;
2434
2435   $html;
2436 }
2437
2438 =item reached_threshold
2439
2440 Performs some activities when svc_acct thresholds (such as number of seconds
2441 remaining) are reached.
2442
2443 =cut
2444
2445 sub reached_threshold {
2446   my %opt = @_;
2447
2448   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2449   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2450
2451   if ( $opt{'op'} eq '+' ){
2452     $svc_acct->setfield( $opt{'column'}.'_threshold',
2453                          int($svc_acct->getfield($opt{'column'})
2454                              * ( $conf->exists('svc_acct-usage_threshold')
2455                                  ? $conf->config('svc_acct-usage_threshold')/100
2456                                  : 0.80
2457                                )
2458                          )
2459                        );
2460     my $error = $svc_acct->replace;
2461     die $error if $error;
2462   }elsif ( $opt{'op'} eq '-' ){
2463
2464     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2465     return '' if ($threshold eq '' );
2466
2467     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2468     my $error = $svc_acct->replace;
2469     die $error if $error; # email next time, i guess
2470
2471     if ( $warning_template ) {
2472       eval "use FS::Misc qw(send_email)";
2473       die $@ if $@;
2474
2475       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
2476       my $cust_main = $cust_pkg->cust_main;
2477
2478       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
2479                                $cust_main->invoicing_list,
2480                                ($opt{'to'} ? $opt{'to'} : ())
2481                    );
2482
2483       my $mimetype = $warning_mimetype;
2484       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2485
2486       my $body       =  $warning_template->fill_in( HASH => {
2487                         'custnum'   => $cust_main->custnum,
2488                         'username'  => $svc_acct->username,
2489                         'password'  => $svc_acct->_password,
2490                         'first'     => $cust_main->first,
2491                         'last'      => $cust_main->getfield('last'),
2492                         'pkg'       => $cust_pkg->part_pkg->pkg,
2493                         'column'    => $opt{'column'},
2494                         'amount'    => $opt{'column'} =~/bytes/
2495                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2496                                        : $svc_acct->getfield($opt{'column'}),
2497                         'threshold' => $opt{'column'} =~/bytes/
2498                                        ? FS::UI::bytecount::display_bytecount($threshold)
2499                                        : $threshold,
2500                       } );
2501
2502
2503       my $error = send_email(
2504         'from'         => $warning_from,
2505         'to'           => $to,
2506         'subject'      => $warning_subject,
2507         'content-type' => $mimetype,
2508         'body'         => [ map "$_\n", split("\n", $body) ],
2509       );
2510       die $error if $error;
2511     }
2512   }else{
2513     die "unknown op: " . $opt{'op'};
2514   }
2515 }
2516
2517 =back
2518
2519 =head1 BUGS
2520
2521 The $recref stuff in sub check should be cleaned up.
2522
2523 The suspend, unsuspend and cancel methods update the database, but not the
2524 current object.  This is probably a bug as it's unexpected and
2525 counterintuitive.
2526
2527 radius_usergroup_selector?  putting web ui components in here?  they should
2528 probably live somewhere else...
2529
2530 insertion of RADIUS group stuff in insert could be done with child_objects now
2531 (would probably clean up export of them too)
2532
2533 =head1 SEE ALSO
2534
2535 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2536 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2537 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2538 L<freeside-queued>), L<FS::svc_acct_pop>,
2539 schema.html from the base documentation.
2540
2541 =cut
2542
2543 1;
2544