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