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