FS/FS/svc_acct.pm

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