FS/FS/svc_acct.pm

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