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