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