FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2 use base qw( FS::svc_Domain_Mixin FS::svc_PBX_Mixin
   3              FS::svc_CGP_Mixin FS::svc_CGPRule_Mixin
   4              FS::svc_Radius_Mixin
   5              FS::svc_Tower_Mixin
   6              FS::svc_IP_Mixin
   7              FS::Password_Mixin
   8              FS::svc_Common
   9            );
  10
  11 use strict;
  12 use vars qw( $DEBUG $me $conf $skip_fuzzyfiles
  13              $dir_prefix @shells $usernamemin
  14              $usernamemax $passwordmin $passwordmax
  15              $username_ampersand $username_letter $username_letterfirst
  16              $username_noperiod $username_nounderscore $username_nodash
  17              $username_uppercase $username_percent $username_colon
  18              $username_slash $username_equals $username_pound
  19              $username_exclamation
  20              $password_noampersand $password_noexclamation
  21              $warning_msgnum
  22              $smtpmachine
  23              $radius_password $radius_ip
  24              $dirhash
  25              @saltset @pw_set );
  26 use Scalar::Util qw( blessed );
  27 use Math::BigInt;
  28 use Carp;
  29 use Fcntl qw(:flock);
  30 use Date::Format;
  31 use Crypt::PasswdMD5 1.2;
  32 use Digest::SHA 'sha1_base64';
  33 use Digest::MD5 'md5_base64';
  34 use Data::Dumper;
  35 use Text::Template;
  36 use Authen::Passphrase;
  37 use FS::UID qw( datasrc driver_name );
  38 use FS::Conf;
  39 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  40 use FS::Msgcat qw(gettext);
  41 use FS::UI::bytecount;
  42 use FS::UI::Web;
  43 use FS::PagedSearch qw( psearch ); # XXX in v4, replace with FS::Cursor
  44 use FS::part_pkg;
  45 use FS::part_svc;
  46 use FS::svc_acct_pop;
  47 use FS::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') || 12;
  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
 688   $error ||= $self->insert_password_history;
 689
 690   if ( $error ) {
 691     $dbh->rollback if $oldAutoCommit;
 692     return $error;
 693   }
 694
 695   unless ( $skip_fuzzyfiles ) {
 696     $error = $self->queue_fuzzyfiles_update;
 697     if ( $error ) {
 698       $dbh->rollback if $oldAutoCommit;
 699       return "updating fuzzy search cache: $error";
 700     }
 701   }
 702
 703   my $cust_pkg = $self->cust_svc->cust_pkg;
 704
 705   if ( $cust_pkg ) {
 706     my $cust_main = $cust_pkg->cust_main;
 707     my $agentnum = $cust_main->agentnum;
 708
 709     if (   $conf->exists('emailinvoiceautoalways')
 710         || $conf->exists('emailinvoiceauto')
 711         && ! $cust_main->invoicing_list_emailonly
 712        ) {
 713
 714       # slight false laziness w/ edit/process/cust_main.cgi...
 715       # and also slightly arbitrary behavior.
 716       #
 717       # this will never happen but check it anyway
 718       my ($contact) = map { $_->contact }
 719         qsearch('contact_email', { emailaddress => $self->email });
 720
 721       if (!$contact) {
 722         # if the "real name" of this account matches the first + last name
 723         # of a contact, attach the email address to that person.
 724         my @contacts = map { $_->contact } $cust_main->cust_contact;
 725         my $myname = $self->get('finger');
 726         my ($contact) =
 727           grep { $_->get('first') . ' ' . $_->get('last') eq $myname } @contacts;
 728         # otherwise just pick the first one
 729         $contact = $contacts[0];
 730       }
 731       # if there is one
 732       $contact ||= FS::contact->new({
 733           'custnum'       => $cust_main->get('custnum'),
 734           'locationnum'   => $cust_main->get('bill_locationnum'),
 735           'last'          => $cust_main->get('last'),
 736           'first'         => $cust_main->get('first'),
 737       });
 738       $contact->set('emailaddress', $self->email);
 739       $contact->set('invoice_dest', 'Y');
 740
 741       if ( $contact->get('contactnum') ) {
 742         $error = $contact->replace;
 743       } else {
 744         $error = $contact->insert;
 745       }
 746
 747       if ( $error ) {
 748         $dbh->rollback if $oldAutoCommit;
 749         return "creating invoice destination contact: $error";
 750       }
 751     }
 752
 753     #welcome email
 754     my @welcome_exclude_svcparts = $conf->config('svc_acct_welcome_exclude');
 755     unless ( grep { $_ eq $self->svcpart } @welcome_exclude_svcparts ) {
 756         my $error = '';
 757         my $msgnum = $conf->config('welcome_msgnum', $agentnum);
 758         if ( $msgnum ) {
 759           my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 760           $error = $msg_template->send('cust_main' => $cust_main,
 761                                        'object'    => $self);
 762           #should this do something on error?
 763         }
 764     }
 765   } # if $cust_pkg
 766
 767   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 768   ''; #no error
 769 }
 770
 771 # set usage fields and thresholds if unset but set in a package def
 772 # AND the package already has a last bill date (otherwise they get double added)
 773 sub preinsert_hook_first {
 774   my $self = shift;
 775
 776   return '' unless $self->pkgnum;
 777
 778   my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 779   return '' unless $cust_pkg && $cust_pkg->last_bill;
 780
 781   my $part_pkg = $cust_pkg->part_pkg;
 782   return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
 783
 784   my %values = $part_pkg->usage_valuehash;
 785   my $multiplier = $conf->exists('svc_acct-usage_threshold')
 786                      ? 1 - $conf->config('svc_acct-usage_threshold')/100
 787                      : 0.20; #doesn't matter
 788
 789   foreach ( keys %values ) {
 790     next if $self->getfield($_);
 791     $self->setfield( $_, $values{$_} );
 792     $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
 793       if $conf->exists('svc_acct-usage_threshold');
 794   }
 795
 796   ''; #no error
 797 }
 798
 799 =item delete
 800
 801 Deletes this account from the database.  If there is an error, returns the
 802 error, otherwise returns false.
 803
 804 The corresponding FS::cust_svc record will be deleted as well.
 805
 806 (TODOC: new exports!)
 807
 808 =cut
 809
 810 sub delete {
 811   my $self = shift;
 812
 813   return "can't delete system account" if $self->_check_system;
 814
 815   return "Can't delete an account which is a (svc_forward) source!"
 816     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 817
 818   return "Can't delete an account which is a (svc_forward) destination!"
 819     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 820
 821   return "Can't delete an account with (svc_www) web service!"
 822     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 823
 824   # what about records in session ? (they should refer to history table)
 825
 826   local $SIG{HUP} = 'IGNORE';
 827   local $SIG{INT} = 'IGNORE';
 828   local $SIG{QUIT} = 'IGNORE';
 829   local $SIG{TERM} = 'IGNORE';
 830   local $SIG{TSTP} = 'IGNORE';
 831   local $SIG{PIPE} = 'IGNORE';
 832
 833   my $oldAutoCommit = $FS::UID::AutoCommit;
 834   local $FS::UID::AutoCommit = 0;
 835   my $dbh = dbh;
 836
 837   foreach my $svc_domain (
 838     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 839   ) {
 840     my %hash = new FS::svc_domain->hash;
 841     $hash{'catchall'} = '';
 842     my $new = new FS::svc_domain \%hash;
 843     my $error = $new->replace($svc_domain);
 844     if ( $error ) {
 845       $dbh->rollback if $oldAutoCommit;
 846       return $error;
 847     }
 848   }
 849
 850   my $error = $self->delete_password_history
 851            || $self->SUPER::delete; # usergroup here
 852   if ( $error ) {
 853     $dbh->rollback if $oldAutoCommit;
 854     return $error;
 855   }
 856
 857   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 858   '';
 859 }
 860
 861 =item replace OLD_RECORD
 862
 863 Replaces OLD_RECORD with this one in the database.  If there is an error,
 864 returns the error, otherwise returns false.
 865
 866 The additional field I<usergroup> can optionally be defined; if so it should
 867 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 868
 869
 870 =cut
 871
 872 sub replace {
 873   my $new = shift;
 874
 875   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 876               ? shift
 877               : $new->replace_old;
 878
 879   warn "$me replacing $old with $new\n" if $DEBUG;
 880
 881   my $error;
 882
 883   return "can't modify system account" if $old->_check_system;
 884
 885   {
 886     #no warnings 'numeric';  #alas, a 5.006-ism
 887     local($^W) = 0;
 888
 889     foreach my $xid (qw( uid gid )) {
 890
 891       return "Can't change $xid!"
 892         if ! $conf->exists("svc_acct-edit_$xid")
 893            && $old->$xid() != $new->$xid()
 894            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 895     }
 896
 897   }
 898
 899   return "can't change username"
 900     if $old->username ne $new->username
 901     && $conf->exists('svc_acct-no_edit_username');
 902
 903   #change homdir when we change username
 904   $new->setfield('dir', '') if $old->username ne $new->username;
 905
 906   local $SIG{HUP} = 'IGNORE';
 907   local $SIG{INT} = 'IGNORE';
 908   local $SIG{QUIT} = 'IGNORE';
 909   local $SIG{TERM} = 'IGNORE';
 910   local $SIG{TSTP} = 'IGNORE';
 911   local $SIG{PIPE} = 'IGNORE';
 912
 913   my $oldAutoCommit = $FS::UID::AutoCommit;
 914   local $FS::UID::AutoCommit = 0;
 915   my $dbh = dbh;
 916
 917   $error = $new->SUPER::replace($old, @_); # usergroup here
 918
 919   # don't need to record this unless the password was changed
 920   if ( $old->_password ne $new->_password ) {
 921     $error ||= $new->insert_password_history;
 922   }
 923
 924   if ( $error ) {
 925     $dbh->rollback if $oldAutoCommit;
 926     return $error if $error;
 927   }
 928
 929   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
 930     $error = $new->queue_fuzzyfiles_update;
 931     if ( $error ) {
 932       $dbh->rollback if $oldAutoCommit;
 933       return "updating fuzzy search cache: $error";
 934     }
 935   }
 936
 937   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 938   ''; #no error
 939 }
 940
 941 =item queue_fuzzyfiles_update
 942
 943 Used by insert & replace to update the fuzzy search cache
 944
 945 =cut
 946
 947 sub queue_fuzzyfiles_update {
 948   my $self = shift;
 949
 950   local $SIG{HUP} = 'IGNORE';
 951   local $SIG{INT} = 'IGNORE';
 952   local $SIG{QUIT} = 'IGNORE';
 953   local $SIG{TERM} = 'IGNORE';
 954   local $SIG{TSTP} = 'IGNORE';
 955   local $SIG{PIPE} = 'IGNORE';
 956
 957   my $oldAutoCommit = $FS::UID::AutoCommit;
 958   local $FS::UID::AutoCommit = 0;
 959   my $dbh = dbh;
 960
 961   my $queue = new FS::queue {
 962     'svcnum' => $self->svcnum,
 963     'job'    => 'FS::svc_acct::append_fuzzyfiles'
 964   };
 965   my $error = $queue->insert($self->username);
 966   if ( $error ) {
 967     $dbh->rollback if $oldAutoCommit;
 968     return "queueing job (transaction rolled back): $error";
 969   }
 970
 971   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 972   '';
 973
 974 }
 975
 976
 977 =item suspend
 978
 979 Suspends this account by calling export-specific suspend hooks.  If there is
 980 an error, returns the error, otherwise returns false.
 981
 982 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 983
 984 =cut
 985
 986 sub suspend {
 987   my $self = shift;
 988   return "can't suspend system account" if $self->_check_system;
 989   $self->SUPER::suspend(@_);
 990 }
 991
 992 =item unsuspend
 993
 994 Unsuspends this account by by calling export-specific suspend hooks.  If there
 995 is an error, returns the error, otherwise returns false.
 996
 997 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 998
 999 =cut
1000
1001 sub unsuspend {
1002   my $self = shift;
1003   my %hash = $self->hash;
1004   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1005     $hash{_password} = $1;
1006     my $new = new FS::svc_acct ( \%hash );
1007     my $error = $new->replace($self);
1008     return $error if $error;
1009   }
1010
1011   $self->SUPER::unsuspend(@_);
1012 }
1013
1014 =item cancel
1015
1016 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1017
1018 If the B<auto_unset_catchall> configuration option is set, this method will
1019 automatically remove any references to the canceled service in the catchall
1020 field of svc_domain.  This allows packages that contain both a svc_domain and
1021 its catchall svc_acct to be canceled in one step.
1022
1023 =cut
1024
1025 sub cancel {
1026   # Only one thing to do at this level
1027   my $self = shift;
1028   foreach my $svc_domain (
1029       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1030     if($conf->exists('auto_unset_catchall')) {
1031       my %hash = $svc_domain->hash;
1032       $hash{catchall} = '';
1033       my $new = new FS::svc_domain ( \%hash );
1034       my $error = $new->replace($svc_domain);
1035       return $error if $error;
1036     } else {
1037       return "cannot unprovision svc_acct #".$self->svcnum.
1038           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1039     }
1040   }
1041
1042   $self->SUPER::cancel(@_);
1043 }
1044
1045
1046 =item check
1047
1048 Checks all fields to make sure this is a valid service.  If there is an error,
1049 returns the error, otherwise returns false.  Called by the insert and replace
1050 methods.
1051
1052 Sets any fixed values; see L<FS::part_svc>.
1053
1054 =cut
1055
1056 sub check {
1057   my $self = shift;
1058
1059   my($recref) = $self->hashref;
1060
1061   my $x = $self->setfixed;
1062   return $x unless ref($x);
1063   my $part_svc = $x;
1064
1065   my $error = $self->ut_numbern('svcnum')
1066               #|| $self->ut_number('domsvc')
1067               || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1068               || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx',    'svcnum' )
1069               || $self->ut_foreign_keyn('sectornum','tower_sector','sectornum')
1070               || $self->ut_foreign_keyn('routernum','router','routernum')
1071               || $self->ut_foreign_keyn('blocknum','addr_block','blocknum')
1072               || $self->ut_textn('sec_phrase')
1073               || $self->ut_snumbern('seconds')
1074               || $self->ut_snumbern('upbytes')
1075               || $self->ut_snumbern('downbytes')
1076               || $self->ut_snumbern('totalbytes')
1077               || $self->ut_snumbern('seconds_threshold')
1078               || $self->ut_snumbern('upbytes_threshold')
1079               || $self->ut_snumbern('downbytes_threshold')
1080               || $self->ut_snumbern('totalbytes_threshold')
1081               || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1082               || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1083               || $self->ut_enum('password_recover',    [ '', 'Y' ])
1084               #cardfortress
1085               || $self->ut_anything('cf_privatekey')
1086               #communigate
1087               || $self->ut_textn('cgp_accessmodes')
1088               || $self->ut_alphan('cgp_type')
1089               || $self->ut_textn('cgp_aliases' ) #well
1090               # settings
1091               || $self->ut_alphasn('cgp_rulesallowed')
1092               || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1093               || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1094               || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1095               || $self->ut_snumbern('cgp_archiveafter')
1096               # preferences
1097               || $self->ut_alphasn('cgp_deletemode')
1098               || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1099               || $self->ut_alphan('cgp_language')
1100               || $self->ut_textn('cgp_timezone')
1101               || $self->ut_textn('cgp_skinname')
1102               || $self->ut_textn('cgp_prontoskinname')
1103               || $self->ut_alphan('cgp_sendmdnmode')
1104   ;
1105   return $error if $error;
1106
1107   # assign IP address, etc.
1108   if ( $conf->exists('svc_acct-ip_addr') ) {
1109     my $error = $self->svc_ip_check;
1110     return $error if $error;
1111   } else { # I think this is correct
1112     $self->routernum('');
1113     $self->blocknum('');
1114   }
1115
1116   my $cust_pkg;
1117   local $username_letter = $username_letter;
1118   local $username_uppercase = $username_uppercase;
1119   if ($self->svcnum) {
1120     my $cust_svc = $self->cust_svc
1121       or return "no cust_svc record found for svcnum ". $self->svcnum;
1122     my $cust_pkg = $cust_svc->cust_pkg;
1123   }
1124   if ($self->pkgnum) {
1125     $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1126   }
1127   if ($cust_pkg) {
1128     $username_letter =
1129       $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1130     $username_uppercase =
1131       $conf->exists('username-uppercase', $cust_pkg->cust_main->agentnum);
1132   }
1133
1134   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1135
1136   $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#\!]{$usernamemin,$ulen})$/i
1137     or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1138   $recref->{username} = $1;
1139
1140   my $uerror = gettext('illegal_username'). ': '. $recref->{username};
1141
1142   unless ( $username_uppercase ) {
1143     $recref->{username} =~ /[A-Z]/ and return $uerror;
1144   }
1145   if ( $username_letterfirst ) {
1146     $recref->{username} =~ /^[a-z]/ or return $uerror;
1147   } elsif ( $username_letter ) {
1148     $recref->{username} =~ /[a-z]/ or return $uerror;
1149   }
1150   if ( $username_noperiod ) {
1151     $recref->{username} =~ /\./ and return $uerror;
1152   }
1153   if ( $username_nounderscore ) {
1154     $recref->{username} =~ /_/ and return $uerror;
1155   }
1156   if ( $username_nodash ) {
1157     $recref->{username} =~ /\-/ and return $uerror;
1158   }
1159   unless ( $username_ampersand ) {
1160     $recref->{username} =~ /\&/ and return $uerror;
1161   }
1162   unless ( $username_percent ) {
1163     $recref->{username} =~ /\%/ and return $uerror;
1164   }
1165   unless ( $username_colon ) {
1166     $recref->{username} =~ /\:/ and return $uerror;
1167   }
1168   unless ( $username_slash ) {
1169     $recref->{username} =~ /\// and return $uerror;
1170   }
1171   unless ( $username_equals ) {
1172     $recref->{username} =~ /\=/ and return $uerror;
1173   }
1174   unless ( $username_pound ) {
1175     $recref->{username} =~ /\#/ and return $uerror;
1176   }
1177   unless ( $username_exclamation ) {
1178     $recref->{username} =~ /\!/ and return $uerror;
1179   }
1180
1181
1182   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1183   $recref->{popnum} = $1;
1184   return "Unknown popnum" unless
1185     ! $recref->{popnum} ||
1186     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1187
1188   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1189
1190     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1191     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1192
1193     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1194     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1195     #not all systems use gid=uid
1196     #you can set a fixed gid in part_svc
1197
1198     return "Only root can have uid 0"
1199       if $recref->{uid} == 0
1200          && $recref->{username} !~ /^(root|toor|smtp)$/;
1201
1202     unless ( $recref->{username} eq 'sync' ) {
1203       if ( grep $_ eq $recref->{shell}, @shells ) {
1204         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1205       } else {
1206         return "Illegal shell \`". $self->shell. "\'; ".
1207                "shells configuration value contains: @shells";
1208       }
1209     } else {
1210       $recref->{shell} = '/bin/sync';
1211     }
1212
1213   } else {
1214     $recref->{gid} ne '' ?
1215       return "Can't have gid without uid" : ( $recref->{gid}='' );
1216     #$recref->{dir} ne '' ?
1217     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1218     $recref->{shell} ne '' ?
1219       return "Can't have shell without uid" : ( $recref->{shell}='' );
1220   }
1221
1222   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1223
1224     $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1225       or return "Illegal directory: ". $recref->{dir};
1226     $recref->{dir} = $1;
1227     return "Illegal directory"
1228       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1229     return "Illegal directory"
1230       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1231     unless ( $recref->{dir} ) {
1232       $recref->{dir} = $dir_prefix . '/';
1233       if ( $dirhash > 0 ) {
1234         for my $h ( 1 .. $dirhash ) {
1235           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1236         }
1237       } elsif ( $dirhash < 0 ) {
1238         for my $h ( reverse $dirhash .. -1 ) {
1239           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1240         }
1241       }
1242       $recref->{dir} .= $recref->{username};
1243     ;
1244     }
1245
1246   }
1247
1248   if ( $self->getfield('finger') eq '' ) {
1249     my $cust_pkg = $self->svcnum
1250       ? $self->cust_svc->cust_pkg
1251       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1252     if ( $cust_pkg ) {
1253       my $cust_main = $cust_pkg->cust_main;
1254       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1255     }
1256   }
1257   #  $error = $self->ut_textn('finger');
1258   #  return $error if $error;
1259   $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]*)$/
1260       or return "Illegal finger: ". $self->getfield('finger');
1261   $self->setfield('finger', $1);
1262
1263   for (qw( quota file_quota file_maxsize )) {
1264     $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1265     $recref->{$_} = $1;
1266   }
1267   $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1268   $recref->{file_maxnum} = $1;
1269
1270   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1271     if ( $recref->{slipip} eq '' ) {
1272       $recref->{slipip} = ''; # eh?
1273     } elsif ( $recref->{slipip} eq '0e0' ) {
1274       $recref->{slipip} = '0e0';
1275     } else {
1276       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1277         or return "Illegal slipip: ". $self->slipip;
1278       $recref->{slipip} = $1;
1279     }
1280   }
1281
1282   #arbitrary RADIUS stuff; allow ut_textn for now
1283   foreach ( grep /^radius_/, fields('svc_acct') ) {
1284     $self->ut_textn($_);
1285   }
1286
1287   # First, if _password is blank, generate one and set default encoding.
1288   if ( ! $recref->{_password} ) {
1289     $error = $self->set_password('');
1290   }
1291   # But if there's a _password but no encoding, assume it's plaintext and
1292   # set it to default encoding.
1293   elsif ( ! $recref->{_password_encoding} ) {
1294     $error = $self->set_password($recref->{_password});
1295   }
1296   return $error if $error;
1297
1298   # Next, check _password to ensure compliance with the encoding.
1299   if ( $recref->{_password_encoding} eq 'ldap' ) {
1300
1301     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1302       $recref->{_password} = uc($1).$2;
1303     } else {
1304       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1305     }
1306
1307   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1308
1309     if ( $recref->{_password} =~
1310            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1311            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1312        ) {
1313
1314       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1315
1316     } else {
1317       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1318     }
1319
1320   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1321     # Password randomization is now in set_password.
1322     # Strip whitespace characters, check length requirements, etc.
1323     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1324       $recref->{_password} = $1;
1325     } else {
1326       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1327              FS::Msgcat::_gettext('illegal_password_characters').
1328              ": ". $recref->{_password};
1329     }
1330
1331     if ( $password_noampersand ) {
1332       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1333     }
1334     if ( $password_noexclamation ) {
1335       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1336     }
1337   }
1338   else {
1339     return "invalid password encoding ('".$recref->{_password_encoding}."'";
1340   }
1341
1342   $self->SUPER::check;
1343
1344 }
1345
1346
1347 sub _password_encryption {
1348   my $self = shift;
1349   my $encoding = lc($self->_password_encoding);
1350   return if !$encoding;
1351   return 'plain' if $encoding eq 'plain';
1352   if($encoding eq 'crypt') {
1353     my $pass = $self->_password;
1354     $pass =~ s/^\*SUSPENDED\* //;
1355     $pass =~ s/^!!?//;
1356     return 'md5' if $pass =~ /^\$1\$/;
1357     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1358     return 'des' if length($pass) == 13;
1359     return;
1360   }
1361   if($encoding eq 'ldap') {
1362     uc($self->_password) =~ /^\{([\w-]+)\}/;
1363     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1364     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1365     return 'md5' if $1 eq 'MD5';
1366     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1367
1368     return;
1369   }
1370   return;
1371 }
1372
1373 sub get_cleartext_password {
1374   my $self = shift;
1375   if($self->_password_encryption eq 'plain') {
1376     if($self->_password_encoding eq 'ldap') {
1377       $self->_password =~ /\{\w+\}(.*)$/;
1378       return $1;
1379     }
1380     else {
1381       return $self->_password;
1382     }
1383   }
1384   return;
1385 }
1386
1387
1388 =item set_password
1389
1390 Set the cleartext password for the account.  If _password_encoding is set, the
1391 new password will be encoded according to the existing method (including
1392 encryption mode, if it can be determined).  Otherwise,
1393 config('default-password-encoding') is used.
1394
1395 If no password is supplied (or a zero-length password when minimum password length
1396 is >0), one will be generated randomly.
1397
1398 =cut
1399
1400 sub set_password {
1401   my( $self, $pass ) = ( shift, shift );
1402
1403   warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1404      if $DEBUG;
1405
1406   my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1407                 FS::Msgcat::_gettext('illegal_password_characters').
1408                 ": ". $pass;
1409
1410   my( $encoding, $encryption ) = ('', '');
1411
1412   if ( $self->_password_encoding ) {
1413     $encoding = $self->_password_encoding;
1414     # identify existing encryption method, try to use it.
1415     $encryption = $self->_password_encryption;
1416     if (!$encryption) {
1417       # use the system default
1418       undef $encoding;
1419     }
1420   }
1421
1422   if ( !$encoding ) {
1423     # set encoding to system default
1424     ($encoding, $encryption) =
1425       split(/-/, lc($conf->config('default-password-encoding') || ''));
1426     $encoding ||= 'legacy';
1427     $self->_password_encoding($encoding);
1428   }
1429
1430   if ( $encoding eq 'legacy' ) {
1431
1432     # The legacy behavior from check():
1433     # If the password is blank, randomize it and set encoding to 'plain'.
1434     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1435       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1436       $self->_password_encoding('plain');
1437     } else {
1438       # Prefix + valid-length password
1439       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1440         $pass = $1.$3;
1441         $self->_password_encoding('plain');
1442       # Prefix + crypt string
1443       } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1444         $pass = $1.$3;
1445         $self->_password_encoding('crypt');
1446       # Various disabled crypt passwords
1447       } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1448         $self->_password_encoding('crypt');
1449       } else {
1450         return $failure;
1451       }
1452     }
1453
1454     $self->_password($pass);
1455     return;
1456
1457   }
1458
1459   return $failure
1460     if $passwordmin && length($pass) < $passwordmin
1461     or $passwordmax && length($pass) > $passwordmax;
1462
1463   if ( $encoding eq 'crypt' ) {
1464     if ($encryption eq 'md5') {
1465       $pass = unix_md5_crypt($pass);
1466     } elsif ($encryption eq 'des') {
1467       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1468     }
1469
1470   } elsif ( $encoding eq 'ldap' ) {
1471     if ($encryption eq 'md5') {
1472       $pass = md5_base64($pass);
1473     } elsif ($encryption eq 'sha1') {
1474       $pass = sha1_base64($pass);
1475     } elsif ($encryption eq 'crypt') {
1476       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1477     }
1478     # else $encryption eq 'plain', do nothing
1479     $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1480       if $encryption eq 'md5' || $encryption eq 'sha1';
1481     $pass = '{'.uc($encryption).'}'.$pass;
1482   }
1483   # else encoding eq 'plain'
1484
1485   $self->_password($pass);
1486   return;
1487 }
1488
1489 =item _check_system
1490
1491 Internal function to check the username against the list of system usernames
1492 from the I<system_usernames> configuration value.  Returns true if the username
1493 is listed on the system username list.
1494
1495 =cut
1496
1497 sub _check_system {
1498   my $self = shift;
1499   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1500                $conf->config('system_usernames')
1501         );
1502 }
1503
1504 =item _check_duplicate
1505
1506 Internal method to check for duplicates usernames, username@domain pairs and
1507 uids.
1508
1509 If the I<global_unique-username> configuration value is set to B<username> or
1510 B<username@domain>, enforces global username or username@domain uniqueness.
1511
1512 In all cases, check for duplicate uids and usernames or username@domain pairs
1513 per export and with identical I<svcpart> values.
1514
1515 =cut
1516
1517 sub _check_duplicate {
1518   my $self = shift;
1519
1520   my $global_unique = $conf->config('global_unique-username') || 'none';
1521   return '' if $global_unique eq 'disabled';
1522
1523   $self->lock_table;
1524
1525   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1526   unless ( $part_svc ) {
1527     return 'unknown svcpart '. $self->svcpart;
1528   }
1529
1530   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1531                  qsearch( 'svc_acct', { 'username' => $self->username } );
1532   return gettext('username_in_use')
1533     if $global_unique eq 'username' && @dup_user;
1534
1535   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1536                        qsearch( 'svc_acct', { 'username' => $self->username,
1537                                               'domsvc'   => $self->domsvc } );
1538   return gettext('username_in_use')
1539     if $global_unique eq 'username@domain' && @dup_userdomain;
1540
1541   my @dup_uid;
1542   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1543        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1544     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1545                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1546   } else {
1547     @dup_uid = ();
1548   }
1549
1550   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1551     my $exports = FS::part_export::export_info('svc_acct');
1552     my %conflict_user_svcpart;
1553     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1554
1555     foreach my $part_export ( $part_svc->part_export ) {
1556
1557       #this will catch to the same exact export
1558       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1559
1560       #this will catch to exports w/same exporthost+type ???
1561       #my @other_part_export = qsearch('part_export', {
1562       #  'machine'    => $part_export->machine,
1563       #  'exporttype' => $part_export->exporttype,
1564       #} );
1565       #foreach my $other_part_export ( @other_part_export ) {
1566       #  push @svcparts, map { $_->svcpart }
1567       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1568       #}
1569
1570       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1571       #silly kludge to avoid uninitialized value errors
1572       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1573                      ? $exports->{$part_export->exporttype}{'nodomain'}
1574                      : '';
1575       if ( $nodomain =~ /^Y/i ) {
1576         $conflict_user_svcpart{$_} = $part_export->exportnum
1577           foreach @svcparts;
1578       } else {
1579         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1580           foreach @svcparts;
1581       }
1582     }
1583
1584     foreach my $dup_user ( @dup_user ) {
1585       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1586       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1587         return "duplicate username ". $self->username.
1588                ": conflicts with svcnum ". $dup_user->svcnum.
1589                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1590       }
1591     }
1592
1593     foreach my $dup_userdomain ( @dup_userdomain ) {
1594       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1595       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1596         return "duplicate username\@domain ". $self->email.
1597                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1598                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1599       }
1600     }
1601
1602     foreach my $dup_uid ( @dup_uid ) {
1603       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1604       if ( exists($conflict_user_svcpart{$dup_svcpart})
1605            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1606         return "duplicate uid ". $self->uid.
1607                ": conflicts with svcnum ". $dup_uid->svcnum.
1608                " via exportnum ".
1609                ( $conflict_user_svcpart{$dup_svcpart}
1610                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1611       }
1612     }
1613
1614   }
1615
1616   return '';
1617
1618 }
1619
1620 =item radius
1621
1622 Depriciated, use radius_reply instead.
1623
1624 =cut
1625
1626 sub radius {
1627   carp "FS::svc_acct::radius depriciated, use radius_reply";
1628   $_[0]->radius_reply;
1629 }
1630
1631 =item radius_reply
1632
1633 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1634 reply attributes of this record.
1635
1636 Note that this is now the preferred method for reading RADIUS attributes -
1637 accessing the columns directly is discouraged, as the column names are
1638 expected to change in the future.
1639
1640 =cut
1641
1642 sub radius_reply {
1643   my $self = shift;
1644
1645   return %{ $self->{'radius_reply'} }
1646     if exists $self->{'radius_reply'};
1647
1648   my %reply =
1649     map {
1650       /^(radius_(.*))$/;
1651       my($column, $attrib) = ($1, $2);
1652       #$attrib =~ s/_/\-/g;
1653       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1654     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1655
1656   if ( $self->slipip && $self->slipip ne '0e0' ) {
1657     $reply{$radius_ip} = $self->slipip;
1658   }
1659
1660   if ( $self->seconds !~ /^$/ ) {
1661     $reply{'Session-Timeout'} = $self->seconds;
1662   }
1663
1664   if ( $conf->exists('radius-chillispot-max') ) {
1665     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1666
1667     #hmm.  just because sqlradius.pm says so?
1668     my %whatis = (
1669       'input'  => 'up',
1670       'output' => 'down',
1671       'total'  => 'total',
1672     );
1673
1674     foreach my $what (qw( input output total )) {
1675       my $is = $whatis{$what}.'bytes';
1676       if ( $self->$is() =~ /\d/ ) {
1677         my $big = new Math::BigInt $self->$is();
1678         $big = new Math::BigInt '0' if $big->is_neg();
1679         my $att = "Chillispot-Max-\u$what";
1680         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1681         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1682       }
1683     }
1684
1685   }
1686
1687   %reply;
1688 }
1689
1690 =item radius_check
1691
1692 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1693 check attributes of this record.
1694
1695 Note that this is now the preferred method for reading RADIUS attributes -
1696 accessing the columns directly is discouraged, as the column names are
1697 expected to change in the future.
1698
1699 =cut
1700
1701 sub radius_check {
1702   my $self = shift;
1703
1704   return %{ $self->{'radius_check'} }
1705     if exists $self->{'radius_check'};
1706
1707   my %check =
1708     map {
1709       /^(rc_(.*))$/;
1710       my($column, $attrib) = ($1, $2);
1711       #$attrib =~ s/_/\-/g;
1712       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1713     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1714
1715
1716   my($pw_attrib, $password) = $self->radius_password;
1717   $check{$pw_attrib} = $password;
1718
1719   my $cust_svc = $self->cust_svc;
1720   if ( $cust_svc ) {
1721     my $cust_pkg = $cust_svc->cust_pkg;
1722     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1723       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1724     }
1725   } else {
1726     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1727          "; can't set Expiration\n"
1728       unless $cust_svc;
1729   }
1730
1731   %check;
1732
1733 }
1734
1735 =item radius_password
1736
1737 Returns a key/value pair containing the RADIUS attribute name and value
1738 for the password.
1739
1740 =cut
1741
1742 sub radius_password {
1743   my $self = shift;
1744
1745   my $pw_attrib;
1746   if ( $self->_password_encoding eq 'ldap' ) {
1747     $pw_attrib = 'Password-With-Header';
1748   } elsif ( $self->_password_encoding eq 'crypt' ) {
1749     $pw_attrib = 'Crypt-Password';
1750   } elsif ( $self->_password_encoding eq 'plain' ) {
1751     $pw_attrib = $radius_password;
1752   } else {
1753     $pw_attrib = length($self->_password) <= 12
1754                    ? $radius_password
1755                    : 'Crypt-Password';
1756   }
1757
1758   ($pw_attrib, $self->_password);
1759
1760 }
1761
1762 =item snapshot
1763
1764 This method instructs the object to "snapshot" or freeze RADIUS check and
1765 reply attributes to the current values.
1766
1767 =cut
1768
1769 #bah, my english is too broken this morning
1770 #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
1771 #the FS::cust_pkg's replace method to trigger the correct export updates when
1772 #package dates change)
1773
1774 sub snapshot {
1775   my $self = shift;
1776
1777   $self->{$_} = { $self->$_() }
1778     foreach qw( radius_reply radius_check );
1779
1780 }
1781
1782 =item forget_snapshot
1783
1784 This methos instructs the object to forget any previously snapshotted
1785 RADIUS check and reply attributes.
1786
1787 =cut
1788
1789 sub forget_snapshot {
1790   my $self = shift;
1791
1792   delete $self->{$_}
1793     foreach qw( radius_reply radius_check );
1794
1795 }
1796
1797 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1798
1799 Returns the domain associated with this account.
1800
1801 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1802 history records.
1803
1804 =cut
1805
1806 sub domain {
1807   my $self = shift;
1808   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1809   my $svc_domain = $self->svc_domain(@_)
1810     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1811   $svc_domain->domain;
1812 }
1813
1814 =item cust_svc
1815
1816 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1817
1818 =cut
1819
1820 #inherited from svc_Common
1821
1822 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1823
1824 Returns an email address associated with the account.
1825
1826 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1827 history records.
1828
1829 =cut
1830
1831 sub email {
1832   my $self = shift;
1833   $self->username. '@'. $self->domain(@_);
1834 }
1835
1836
1837 =item acct_snarf
1838
1839 Returns an array of FS::acct_snarf records associated with the account.
1840
1841 =cut
1842
1843 # unused as originally intended, but now by Communigate Pro "RPOP"
1844
1845 =item cgp_rpop_hashref
1846
1847 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1848
1849 =cut
1850
1851 sub cgp_rpop_hashref {
1852   my $self = shift;
1853   { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1854 }
1855
1856 =item decrement_upbytes OCTETS
1857
1858 Decrements the I<upbytes> field of this record by the given amount.  If there
1859 is an error, returns the error, otherwise returns false.
1860
1861 =cut
1862
1863 sub decrement_upbytes {
1864   shift->_op_usage('-', 'upbytes', @_);
1865 }
1866
1867 =item increment_upbytes OCTETS
1868
1869 Increments the I<upbytes> field of this record by the given amount.  If there
1870 is an error, returns the error, otherwise returns false.
1871
1872 =cut
1873
1874 sub increment_upbytes {
1875   shift->_op_usage('+', 'upbytes', @_);
1876 }
1877
1878 =item decrement_downbytes OCTETS
1879
1880 Decrements the I<downbytes> field of this record by the given amount.  If there
1881 is an error, returns the error, otherwise returns false.
1882
1883 =cut
1884
1885 sub decrement_downbytes {
1886   shift->_op_usage('-', 'downbytes', @_);
1887 }
1888
1889 =item increment_downbytes OCTETS
1890
1891 Increments the I<downbytes> field of this record by the given amount.  If there
1892 is an error, returns the error, otherwise returns false.
1893
1894 =cut
1895
1896 sub increment_downbytes {
1897   shift->_op_usage('+', 'downbytes', @_);
1898 }
1899
1900 =item decrement_totalbytes OCTETS
1901
1902 Decrements the I<totalbytes> field of this record by the given amount.  If there
1903 is an error, returns the error, otherwise returns false.
1904
1905 =cut
1906
1907 sub decrement_totalbytes {
1908   shift->_op_usage('-', 'totalbytes', @_);
1909 }
1910
1911 =item increment_totalbytes OCTETS
1912
1913 Increments the I<totalbytes> field of this record by the given amount.  If there
1914 is an error, returns the error, otherwise returns false.
1915
1916 =cut
1917
1918 sub increment_totalbytes {
1919   shift->_op_usage('+', 'totalbytes', @_);
1920 }
1921
1922 =item decrement_seconds SECONDS
1923
1924 Decrements the I<seconds> field of this record by the given amount.  If there
1925 is an error, returns the error, otherwise returns false.
1926
1927 =cut
1928
1929 sub decrement_seconds {
1930   shift->_op_usage('-', 'seconds', @_);
1931 }
1932
1933 =item increment_seconds SECONDS
1934
1935 Increments the I<seconds> field of this record by the given amount.  If there
1936 is an error, returns the error, otherwise returns false.
1937
1938 =cut
1939
1940 sub increment_seconds {
1941   shift->_op_usage('+', 'seconds', @_);
1942 }
1943
1944
1945 my %op2action = (
1946   '-' => 'suspend',
1947   '+' => 'unsuspend',
1948 );
1949 my %op2condition = (
1950   '-' => sub { my($self, $column, $amount) = @_;
1951                $self->$column - $amount <= 0;
1952              },
1953   '+' => sub { my($self, $column, $amount) = @_;
1954                ($self->$column || 0) + $amount > 0;
1955              },
1956 );
1957 my %op2warncondition = (
1958   '-' => sub { my($self, $column, $amount) = @_;
1959                my $threshold = $column . '_threshold';
1960                $self->$column - $amount <= $self->$threshold + 0;
1961              },
1962   '+' => sub { my($self, $column, $amount) = @_;
1963                ($self->$column || 0) + $amount > 0;
1964              },
1965 );
1966
1967 sub _op_usage {
1968   my( $self, $op, $column, $amount ) = @_;
1969
1970   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
1971        ' ('. $self->email. "): $op $amount\n"
1972     if $DEBUG;
1973
1974   return '' unless $amount;
1975
1976   local $SIG{HUP} = 'IGNORE';
1977   local $SIG{INT} = 'IGNORE';
1978   local $SIG{QUIT} = 'IGNORE';
1979   local $SIG{TERM} = 'IGNORE';
1980   local $SIG{TSTP} = 'IGNORE';
1981   local $SIG{PIPE} = 'IGNORE';
1982
1983   my $oldAutoCommit = $FS::UID::AutoCommit;
1984   local $FS::UID::AutoCommit = 0;
1985   my $dbh = dbh;
1986
1987   my $sql = "UPDATE svc_acct SET $column = ".
1988             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
1989             " $op ? WHERE svcnum = ?";
1990   warn "$me $sql\n"
1991     if $DEBUG;
1992
1993   my $sth = $dbh->prepare( $sql )
1994     or die "Error preparing $sql: ". $dbh->errstr;
1995   my $rv = $sth->execute($amount, $self->svcnum);
1996   die "Error executing $sql: ". $sth->errstr
1997     unless defined($rv);
1998   die "Can't update $column for svcnum". $self->svcnum
1999     if $rv == 0;
2000
2001   #$self->snapshot; #not necessary, we retain the old values
2002   #create an object with the updated usage values
2003   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2004   #call exports
2005   my $error = $new->replace($self);
2006   if ( $error ) {
2007     $dbh->rollback if $oldAutoCommit;
2008     return "Error replacing: $error";
2009   }
2010
2011   #overlimit_action eq 'cancel' handling
2012   my $cust_pkg = $self->cust_svc->cust_pkg;
2013   if ( $cust_pkg
2014        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2015        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2016      )
2017   {
2018
2019     my $error = $cust_pkg->cancel; #XXX should have a reason
2020     if ( $error ) {
2021       $dbh->rollback if $oldAutoCommit;
2022       return "Error cancelling: $error";
2023     }
2024
2025     #nothing else is relevant if we're cancelling, so commit & return success
2026     warn "$me update successful; committing\n"
2027       if $DEBUG;
2028     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2029     return '';
2030
2031   }
2032
2033   my $action = $op2action{$op};
2034
2035   if ( &{$op2condition{$op}}($self, $column, $amount) &&
2036         ( $action eq 'suspend'   && !$self->overlimit
2037        || $action eq 'unsuspend' &&  $self->overlimit )
2038      ) {
2039
2040     my $error = $self->_op_overlimit($action);
2041     if ( $error ) {
2042       $dbh->rollback if $oldAutoCommit;
2043       return $error;
2044     }
2045
2046   }
2047
2048   if ( $conf->exists("svc_acct-usage_$action")
2049        && &{$op2condition{$op}}($self, $column, $amount)    ) {
2050     #my $error = $self->$action();
2051     my $error = $self->cust_svc->cust_pkg->$action();
2052     # $error ||= $self->overlimit($action);
2053     if ( $error ) {
2054       $dbh->rollback if $oldAutoCommit;
2055       return "Error ${action}ing: $error";
2056     }
2057   }
2058
2059   if ($warning_msgnum && &{$op2warncondition{$op}}($self, $column, $amount)) {
2060     my $wqueue = new FS::queue {
2061       'svcnum' => $self->svcnum,
2062       'job'    => 'FS::svc_acct::reached_threshold',
2063     };
2064
2065     # x_threshold race
2066     my $error = $wqueue->insert(
2067       'svcnum' => $self->svcnum,
2068       'op'     => $op,
2069       'column' => $column
2070     );
2071     if ( $error ) {
2072       $dbh->rollback if $oldAutoCommit;
2073       return "Error queuing threshold activity: $error";
2074     }
2075   }
2076
2077   warn "$me update successful; committing\n"
2078     if $DEBUG;
2079   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2080   '';
2081
2082 }
2083
2084 sub _op_overlimit {
2085   my( $self, $action ) = @_;
2086
2087   local $SIG{HUP} = 'IGNORE';
2088   local $SIG{INT} = 'IGNORE';
2089   local $SIG{QUIT} = 'IGNORE';
2090   local $SIG{TERM} = 'IGNORE';
2091   local $SIG{TSTP} = 'IGNORE';
2092   local $SIG{PIPE} = 'IGNORE';
2093
2094   my $oldAutoCommit = $FS::UID::AutoCommit;
2095   local $FS::UID::AutoCommit = 0;
2096   my $dbh = dbh;
2097
2098   my $cust_pkg = $self->cust_svc->cust_pkg;
2099
2100   my @conf_overlimit =
2101     $cust_pkg
2102       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2103       : $conf->config('overlimit_groups');
2104
2105   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2106
2107     my @groups = scalar(@conf_overlimit) ? @conf_overlimit
2108                                          : split(' ',$part_export->option('overlimit_groups'));
2109     next unless scalar(@groups);
2110
2111     my $other = new FS::svc_acct $self->hashref;
2112     $other->usergroup(\@groups);
2113
2114     my($new,$old);
2115     if ($action eq 'suspend') {
2116       $new = $other;
2117       $old = $self;
2118     } else { # $action eq 'unsuspend'
2119       $new = $self;
2120       $old = $other;
2121     }
2122
2123     my $error = $part_export->export_replace($new, $old)
2124                 || $self->overlimit($action);
2125
2126     if ( $error ) {
2127       $dbh->rollback if $oldAutoCommit;
2128       return "Error replacing radius groups: $error";
2129     }
2130
2131   }
2132
2133   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2134   '';
2135
2136 }
2137
2138 sub set_usage {
2139   my( $self, $valueref, %options ) = @_;
2140
2141   warn "$me set_usage called for svcnum ". $self->svcnum.
2142        ' ('. $self->email. "): ".
2143        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2144     if $DEBUG;
2145
2146   local $SIG{HUP} = 'IGNORE';
2147   local $SIG{INT} = 'IGNORE';
2148   local $SIG{QUIT} = 'IGNORE';
2149   local $SIG{TERM} = 'IGNORE';
2150   local $SIG{TSTP} = 'IGNORE';
2151   local $SIG{PIPE} = 'IGNORE';
2152
2153   local $FS::svc_Common::noexport_hack = 1;
2154   my $oldAutoCommit = $FS::UID::AutoCommit;
2155   local $FS::UID::AutoCommit = 0;
2156   my $dbh = dbh;
2157
2158   my $reset = 0;
2159   my %handyhash = ();
2160   if ( $options{null} ) {
2161     %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2162                    qw( seconds upbytes downbytes totalbytes )
2163                  );
2164   }
2165   foreach my $field (keys %$valueref){
2166     $reset = 1 if $valueref->{$field};
2167     $self->setfield($field, $valueref->{$field});
2168     $self->setfield( $field.'_threshold',
2169                      int($self->getfield($field)
2170                          * ( $conf->exists('svc_acct-usage_threshold')
2171                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2172                              : 0.20
2173                            )
2174                        )
2175                      );
2176     $handyhash{$field} = $self->getfield($field);
2177     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2178   }
2179   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2180   #die $error if $error;         #services not explicity changed via the UI
2181
2182   my $sql = "UPDATE svc_acct SET " .
2183     join (',', map { "$_ =  ?" } (keys %handyhash) ).
2184     " WHERE svcnum = ". $self->svcnum;
2185
2186   warn "$me $sql\n"
2187     if $DEBUG;
2188
2189   if (scalar(keys %handyhash)) {
2190     my $sth = $dbh->prepare( $sql )
2191       or die "Error preparing $sql: ". $dbh->errstr;
2192     my $rv = $sth->execute(values %handyhash);
2193     die "Error executing $sql: ". $sth->errstr
2194       unless defined($rv);
2195     die "Can't update usage for svcnum ". $self->svcnum
2196       if $rv == 0;
2197   }
2198
2199   #$self->snapshot; #not necessary, we retain the old values
2200   #create an object with the updated usage values
2201   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2202   local($FS::Record::nowarn_identical) = 1;
2203   my $error = $new->replace($self); #call exports
2204   if ( $error ) {
2205     $dbh->rollback if $oldAutoCommit;
2206     return "Error replacing: $error";
2207   }
2208
2209   if ( $reset ) {
2210
2211     my $error = '';
2212
2213     $error = $self->_op_overlimit('unsuspend')
2214       if $self->overlimit;;
2215
2216     $error ||= $self->cust_svc->cust_pkg->unsuspend
2217       if $conf->exists("svc_acct-usage_unsuspend");
2218
2219     if ( $error ) {
2220       $dbh->rollback if $oldAutoCommit;
2221       return "Error unsuspending: $error";
2222     }
2223
2224   }
2225
2226   warn "$me update successful; committing\n"
2227     if $DEBUG;
2228   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2229   '';
2230
2231 }
2232
2233
2234 =item recharge HASHREF
2235
2236   Increments usage columns by the amount specified in HASHREF as
2237   column=>amount pairs.
2238
2239 =cut
2240
2241 sub recharge {
2242   my ($self, $vhash) = @_;
2243
2244   if ( $DEBUG ) {
2245     warn "[$me] recharge called on $self: ". Dumper($self).
2246          "\nwith vhash: ". Dumper($vhash);
2247   }
2248
2249   my $oldAutoCommit = $FS::UID::AutoCommit;
2250   local $FS::UID::AutoCommit = 0;
2251   my $dbh = dbh;
2252   my $error = '';
2253
2254   foreach my $column (keys %$vhash){
2255     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2256   }
2257
2258   if ( $error ) {
2259     $dbh->rollback if $oldAutoCommit;
2260   }else{
2261     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2262   }
2263   return $error;
2264 }
2265
2266 =item is_rechargeable
2267
2268 Returns true if this svc_account can be "recharged" and false otherwise.
2269
2270 =cut
2271
2272 sub is_rechargable {
2273   my $self = shift;
2274   $self->seconds ne ''
2275     || $self->upbytes ne ''
2276     || $self->downbytes ne ''
2277     || $self->totalbytes ne '';
2278 }
2279
2280 =item seconds_since TIMESTAMP
2281
2282 Returns the number of seconds this account has been online since TIMESTAMP,
2283 according to the session monitor (see L<FS::Session>).
2284
2285 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2286 L<Time::Local> and L<Date::Parse> for conversion functions.
2287
2288 =cut
2289
2290 #note: POD here, implementation in FS::cust_svc
2291 sub seconds_since {
2292   my $self = shift;
2293   $self->cust_svc->seconds_since(@_);
2294 }
2295
2296 =item last_login_text
2297
2298 Returns text describing the time of last login.
2299
2300 =cut
2301
2302 sub last_login_text {
2303   my $self = shift;
2304   $self->last_login ? ctime($self->last_login) : 'unknown';
2305 }
2306
2307 =item psearch_cdrs OPTIONS
2308
2309 Returns a paged search (L<FS::PagedSearch>) for Call Detail Records
2310 associated with this service. For svc_acct, "associated with" means that
2311 either the "src" or the "charged_party" field of the CDR matches the
2312 "username" field of the service.
2313
2314 =cut
2315
2316 sub psearch_cdrs {
2317   my($self, %options) = @_;
2318   my @fields;
2319   my %hash;
2320   my @where;
2321
2322   my $did = dbh->quote($self->username);
2323
2324   my $prefix = $options{'default_prefix'} || ''; #convergent.au '+61'
2325   my $prefixdid = dbh->quote($prefix . $self->username);
2326
2327   my $for_update = $options{'for_update'} ? 'FOR UPDATE' : '';
2328
2329   if ( $options{inbound} ) {
2330     # these will be selected under their DIDs
2331     push @where, "FALSE";
2332   }
2333
2334   my @orwhere;
2335   if (!$options{'disable_charged_party'}) {
2336     push @orwhere,
2337       "charged_party = $did",
2338       "charged_party = $prefixdid";
2339   }
2340   if (!$options{'disable_src'}) {
2341     push @orwhere,
2342       "src = $did AND charged_party IS NULL",
2343       "src = $prefixdid AND charged_party IS NULL";
2344   }
2345   push @where, '(' . join(' OR ', @orwhere) . ')';
2346
2347   # $options{'status'} = '' is meaningful; for the rest of them it's not
2348   if ( exists $options{'status'} ) {
2349     $hash{'freesidestatus'} = $options{'status'};
2350   }
2351   if ( $options{'cdrtypenum'} ) {
2352     $hash{'cdrtypenum'} = $options{'cdrtypenum'};
2353   }
2354   if ( $options{'calltypenum'} ) {
2355     $hash{'calltypenum'} = $options{'calltypenum'};
2356   }
2357   if ( $options{'begin'} ) {
2358     push @where, 'startdate >= '. $options{'begin'};
2359   }
2360   if ( $options{'end'} ) {
2361     push @where, 'startdate < '.  $options{'end'};
2362   }
2363   if ( $options{'nonzero'} ) {
2364     push @where, 'duration > 0';
2365   }
2366
2367   my $extra_sql = join(' AND ', @where);
2368   if ($extra_sql) {
2369     if (keys %hash) {
2370       $extra_sql = " AND ".$extra_sql;
2371     } else {
2372       $extra_sql = " WHERE ".$extra_sql;
2373     }
2374   }
2375   return psearch({
2376     'select'    => '*',
2377     'table'     => 'cdr',
2378     'hashref'   => \%hash,
2379     'extra_sql' => $extra_sql,
2380     'order_by'  => "ORDER BY startdate $for_update",
2381   });
2382 }
2383
2384 =item get_cdrs (DEPRECATED)
2385
2386 Like psearch_cdrs, but returns all the L<FS::cdr> objects at once, in a
2387 single list. Arguments are the same as for psearch_cdrs.
2388
2389 =cut
2390
2391 sub get_cdrs {
2392   my $self = shift;
2393   my $psearch = $self->psearch_cdrs(@_);
2394   qsearch ( $psearch->{query} )
2395 }
2396
2397 # sub radius_groups has moved to svc_Radius_Mixin
2398
2399 =item clone_suspended
2400
2401 Constructor used by FS::part_export::_export_suspend fallback.  Document
2402 better.
2403
2404 =cut
2405
2406 sub clone_suspended {
2407   my $self = shift;
2408   my %hash = $self->hash;
2409   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2410   new FS::svc_acct \%hash;
2411 }
2412
2413 =item clone_kludge_unsuspend
2414
2415 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2416 better.
2417
2418 =cut
2419
2420 sub clone_kludge_unsuspend {
2421   my $self = shift;
2422   my %hash = $self->hash;
2423   $hash{_password} = '';
2424   new FS::svc_acct \%hash;
2425 }
2426
2427 =item check_password
2428
2429 Checks the supplied password against the (possibly encrypted) password in the
2430 database.  Returns true for a successful authentication, false for no match.
2431
2432 Currently supported encryptions are: classic DES crypt() and MD5
2433
2434 =cut
2435
2436 sub check_password {
2437   my($self, $check_password) = @_;
2438
2439   #remove old-style SUSPENDED kludge, they should be allowed to login to
2440   #self-service and pay up
2441   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2442
2443   if ( $self->_password_encoding eq 'ldap' ) {
2444
2445     $password =~ s/^{PLAIN}/{CLEARTEXT}/;
2446     my $auth = from_rfc2307 Authen::Passphrase $password;
2447     return $auth->match($check_password);
2448
2449   } elsif ( $self->_password_encoding eq 'crypt' ) {
2450
2451     my $auth = from_crypt Authen::Passphrase $self->_password;
2452     return $auth->match($check_password);
2453
2454   } elsif ( $self->_password_encoding eq 'plain' ) {
2455
2456     return $check_password eq $password;
2457
2458   } else {
2459
2460     #XXX this could be replaced with Authen::Passphrase stuff
2461
2462     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2463       return 0;
2464     } elsif ( length($password) < 13 ) { #plaintext
2465       $check_password eq $password;
2466     } elsif ( length($password) == 13 ) { #traditional DES crypt
2467       crypt($check_password, $password) eq $password;
2468     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2469       unix_md5_crypt($check_password, $password) eq $password;
2470     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2471       warn "Can't check password: Blowfish encryption not yet supported, ".
2472            "svcnum ".  $self->svcnum. "\n";
2473       0;
2474     } else {
2475       warn "Can't check password: Unrecognized encryption for svcnum ".
2476            $self->svcnum. "\n";
2477       0;
2478     }
2479
2480   }
2481
2482 }
2483
2484 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2485
2486 Returns an encrypted password, either by passing through an encrypted password
2487 in the database or by encrypting a plaintext password from the database.
2488
2489 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2490 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2491 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2492 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2493 encryption type is only used if the password is not already encrypted in the
2494 database.
2495
2496 =cut
2497
2498 sub crypt_password {
2499   my $self = shift;
2500
2501   if ( $self->_password_encoding eq 'ldap' ) {
2502
2503     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2504       my $plain = $2;
2505
2506       #XXX this could be replaced with Authen::Passphrase stuff
2507
2508       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2509       if ( $encryption eq 'crypt' ) {
2510         return crypt(
2511           $self->_password,
2512           $saltset[int(rand(64))].$saltset[int(rand(64))]
2513         );
2514       } elsif ( $encryption eq 'md5' ) {
2515         return unix_md5_crypt( $self->_password );
2516       } elsif ( $encryption eq 'blowfish' ) {
2517         croak "unknown encryption method $encryption";
2518       } else {
2519         croak "unknown encryption method $encryption";
2520       }
2521
2522     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2523       return $1;
2524     }
2525
2526   } elsif ( $self->_password_encoding eq 'crypt' ) {
2527
2528     return $self->_password;
2529
2530   } elsif ( $self->_password_encoding eq 'plain' ) {
2531
2532     #XXX this could be replaced with Authen::Passphrase stuff
2533
2534     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2535     if ( $encryption eq 'crypt' ) {
2536       return crypt(
2537         $self->_password,
2538         $saltset[int(rand(64))].$saltset[int(rand(64))]
2539       );
2540     } elsif ( $encryption eq 'md5' ) {
2541       return unix_md5_crypt( $self->_password );
2542     } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2543       my $pass = sha1_base64( $self->_password );
2544       $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2545       return $pass;
2546     } elsif ( $encryption eq 'blowfish' ) {
2547       croak "unknown encryption method $encryption";
2548     } else {
2549       croak "unknown encryption method $encryption";
2550     }
2551
2552   } else {
2553
2554     if ( length($self->_password) == 13
2555          || $self->_password =~ /^\$(1|2a?)\$/
2556          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2557        )
2558     {
2559       $self->_password;
2560     } else {
2561
2562       #XXX this could be replaced with Authen::Passphrase stuff
2563
2564       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2565       if ( $encryption eq 'crypt' ) {
2566         return crypt(
2567           $self->_password,
2568           $saltset[int(rand(64))].$saltset[int(rand(64))]
2569         );
2570       } elsif ( $encryption eq 'md5' ) {
2571         return unix_md5_crypt( $self->_password );
2572       } elsif ( $encryption eq 'blowfish' ) {
2573         croak "unknown encryption method $encryption";
2574       } else {
2575         croak "unknown encryption method $encryption";
2576       }
2577
2578     }
2579
2580   }
2581
2582 }
2583
2584 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2585
2586 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2587 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2588 "{MD5}5426824942db4253f87a1009fd5d2d4".
2589
2590 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2591 to work the same as the B</crypt_password> method.
2592
2593 =cut
2594
2595 sub ldap_password {
2596   my $self = shift;
2597   #eventually should check a "password-encoding" field
2598
2599   if ( $self->_password_encoding eq 'ldap' ) {
2600
2601     return $self->_password;
2602
2603   } elsif ( $self->_password_encoding eq 'crypt' ) {
2604
2605     if ( length($self->_password) == 13 ) { #crypt
2606       return '{CRYPT}'. $self->_password;
2607     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2608       return '{MD5}'. $1;
2609     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2610     #  die "Blowfish encryption not supported in this context, svcnum ".
2611     #      $self->svcnum. "\n";
2612     } else {
2613       warn "encryption method not (yet?) supported in LDAP context";
2614       return '{CRYPT}*'; #unsupported, should not auth
2615     }
2616
2617   } elsif ( $self->_password_encoding eq 'plain' ) {
2618
2619     return '{PLAIN}'. $self->_password;
2620
2621     #return '{CLEARTEXT}'. $self->_password; #?
2622
2623   } else {
2624
2625     if ( length($self->_password) == 13 ) { #crypt
2626       return '{CRYPT}'. $self->_password;
2627     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2628       return '{MD5}'. $1;
2629     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2630       warn "Blowfish encryption not supported in this context, svcnum ".
2631           $self->svcnum. "\n";
2632       return '{CRYPT}*';
2633
2634     #are these two necessary anymore?
2635     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2636       return '{SSHA}'. $1;
2637     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2638       return '{NS-MTA-MD5}'. $1;
2639
2640     } else { #plaintext
2641       return '{PLAIN}'. $self->_password;
2642
2643       #return '{CLEARTEXT}'. $self->_password; #?
2644
2645       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2646       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2647       #if ( $encryption eq 'crypt' ) {
2648       #  return '{CRYPT}'. crypt(
2649       #    $self->_password,
2650       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2651       #  );
2652       #} elsif ( $encryption eq 'md5' ) {
2653       #  unix_md5_crypt( $self->_password );
2654       #} elsif ( $encryption eq 'blowfish' ) {
2655       #  croak "unknown encryption method $encryption";
2656       #} else {
2657       #  croak "unknown encryption method $encryption";
2658       #}
2659     }
2660
2661   }
2662
2663 }
2664
2665 =item domain_slash_username
2666
2667 Returns $domain/$username/
2668
2669 =cut
2670
2671 sub domain_slash_username {
2672   my $self = shift;
2673   $self->domain. '/'. $self->username. '/';
2674 }
2675
2676 =item virtual_maildir
2677
2678 Returns $domain/maildirs/$username/
2679
2680 =cut
2681
2682 sub virtual_maildir {
2683   my $self = shift;
2684   $self->domain. '/maildirs/'. $self->username. '/';
2685 }
2686
2687 =item password_svc_check
2688
2689 Override, for L<FS::Password_Mixin>.  Not really intended for other use.
2690
2691 =cut
2692
2693 sub password_svc_check {
2694   my ($self, $password) = @_;
2695   foreach my $field ( qw(username finger) ) {
2696     foreach my $word (split(/\W+/,$self->get($field))) {
2697       next unless length($word) > 2;
2698       if ($password =~ /$word/i) {
2699         return qq(Password contains account information '$word');
2700       }
2701     }
2702   }
2703   return '';
2704 }
2705
2706 =back
2707
2708 =head1 CLASS METHODS
2709
2710 =over 4
2711
2712 =item search HASHREF
2713
2714 Class method which returns a qsearch hash expression to search for parameters
2715 specified in HASHREF.  Valid parameters are
2716
2717 =over 4
2718
2719 =item domain
2720
2721 =item domsvc
2722
2723 =item unlinked
2724
2725 =item agentnum
2726
2727 =item pkgpart
2728
2729 Arrayref of pkgparts
2730
2731 =item pkgpart
2732
2733 =item where
2734
2735 Arrayref of additional WHERE clauses, will be ANDed together.
2736
2737 =item order_by
2738
2739 =item cust_fields
2740
2741 =back
2742
2743 =cut
2744
2745 sub _search_svc {
2746   my( $class, $params, $from, $where ) = @_;
2747
2748   #these two should probably move to svc_Domain_Mixin ?
2749
2750   # domain
2751   if ( $params->{'domain'} ) {
2752     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2753     #preserve previous behavior & bubble up an error if $svc_domain not found?
2754     push @$where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2755   }
2756
2757   # domsvc
2758   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2759     push @$where, "domsvc = $1";
2760   }
2761
2762
2763   # popnum
2764   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2765     push @$where, "popnum = $1";
2766   }
2767
2768
2769   #and these in svc_Tower_Mixin, or maybe we never should have done svc_acct
2770   # towers (or, as mark thought, never should have done svc_broadband)
2771
2772   # sector and tower
2773   my @where_sector = $class->tower_sector_sql($params);
2774   if ( @where_sector ) {
2775     push @$where, @where_sector;
2776     push @$from, ' LEFT JOIN tower_sector USING ( sectornum )';
2777   }
2778
2779 }
2780
2781 =back
2782
2783 =head1 SUBROUTINES
2784
2785 =over 4
2786
2787 =item check_and_rebuild_fuzzyfiles
2788
2789 =cut
2790
2791 sub check_and_rebuild_fuzzyfiles {
2792   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2793   -e "$dir/svc_acct.username"
2794     or &rebuild_fuzzyfiles;
2795 }
2796
2797 =item rebuild_fuzzyfiles
2798
2799 =cut
2800
2801 sub rebuild_fuzzyfiles {
2802
2803   use Fcntl qw(:flock);
2804
2805   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2806
2807   #username
2808
2809   open(USERNAMELOCK,">>$dir/svc_acct.username")
2810     or die "can't open $dir/svc_acct.username: $!";
2811   flock(USERNAMELOCK,LOCK_EX)
2812     or die "can't lock $dir/svc_acct.username: $!";
2813
2814   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
2815
2816   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
2817     or die "can't open $dir/svc_acct.username.tmp: $!";
2818   print USERNAMECACHE join("\n", @all_username), "\n";
2819   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
2820
2821   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
2822   close USERNAMELOCK;
2823
2824 }
2825
2826 =item all_username
2827
2828 =cut
2829
2830 sub all_username {
2831   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2832   open(USERNAMECACHE,"<$dir/svc_acct.username")
2833     or die "can't open $dir/svc_acct.username: $!";
2834   my @array = map { chomp; $_; } <USERNAMECACHE>;
2835   close USERNAMECACHE;
2836   \@array;
2837 }
2838
2839 =item append_fuzzyfiles USERNAME
2840
2841 =cut
2842
2843 sub append_fuzzyfiles {
2844   my $username = shift;
2845
2846   &check_and_rebuild_fuzzyfiles;
2847
2848   use Fcntl qw(:flock);
2849
2850   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2851
2852   open(USERNAME,">>$dir/svc_acct.username")
2853     or die "can't open $dir/svc_acct.username: $!";
2854   flock(USERNAME,LOCK_EX)
2855     or die "can't lock $dir/svc_acct.username: $!";
2856
2857   print USERNAME "$username\n";
2858
2859   flock(USERNAME,LOCK_UN)
2860     or die "can't unlock $dir/svc_acct.username: $!";
2861   close USERNAME;
2862
2863   1;
2864 }
2865
2866
2867 =item reached_threshold
2868
2869 Performs some activities when svc_acct thresholds (such as number of seconds
2870 remaining) are reached.
2871
2872 =cut
2873
2874 sub reached_threshold {
2875   my %opt = @_;
2876
2877   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
2878   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
2879
2880   if ( $opt{'op'} eq '+' ){
2881     $svc_acct->setfield( $opt{'column'}.'_threshold',
2882                          int($svc_acct->getfield($opt{'column'})
2883                              * ( $conf->exists('svc_acct-usage_threshold')
2884                                  ? $conf->config('svc_acct-usage_threshold')/100
2885                                  : 0.80
2886                                )
2887                          )
2888                        );
2889     my $error = $svc_acct->replace;
2890     die $error if $error;
2891   }elsif ( $opt{'op'} eq '-' ){
2892
2893     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
2894     return '' if ($threshold eq '' );
2895
2896     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
2897     my $error = $svc_acct->replace;
2898     die $error if $error; # email next time, i guess
2899
2900     if ( $warning_msgnum ) {
2901
2902       my $msg_template = qsearchs('msg_template',{ msgnum => $warning_msgnum });
2903       die "Could not load template for threshold_warning_msgnum ($warning_msgnum)" unless $msg_template;
2904
2905       my $cust_main = $svc_acct->cust_svc->cust_pkg->cust_main;
2906
2907       my $to = join(', ', $cust_main->invoicing_list_emailonly );
2908
2909       my $error = $msg_template->send(
2910         cust_main     => $cust_main,
2911         object        => $svc_acct,
2912         to            => $to,
2913         substitutions => {
2914           # have to override these, because we changed threshold above
2915           'column'    => $opt{'column'},
2916           'amount'    => $opt{'column'} =~/bytes/
2917                          ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
2918                          : $svc_acct->getfield($opt{'column'}),
2919           'threshold' => $opt{'column'} =~/bytes/
2920                          ? FS::UI::bytecount::display_bytecount($threshold)
2921                          : $threshold,
2922         },
2923       );
2924
2925       die "Error sending threshold warning email: $error" if $error;
2926
2927     }
2928   }else{
2929     die "unknown op: " . $opt{'op'};
2930   }
2931 }
2932
2933 =back
2934
2935 =head1 BUGS
2936
2937 The $recref stuff in sub check should be cleaned up.
2938
2939 The suspend, unsuspend and cancel methods update the database, but not the
2940 current object.  This is probably a bug as it's unexpected and
2941 counterintuitive.
2942
2943 insertion of RADIUS group stuff in insert could be done with child_objects now
2944 (would probably clean up export of them too)
2945
2946 _op_usage and set_usage bypass the history... maybe they shouldn't
2947
2948 =head1 SEE ALSO
2949
2950 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
2951 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
2952 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
2953 L<freeside-queued>), L<FS::svc_acct_pop>,
2954 schema.html from the base documentation.
2955
2956 =cut
2957
2958 1;