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