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