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