FS/FS/svc_acct.pm

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