FS/FS/svc_acct.pm

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