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