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