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