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