FS/FS/svc_acct.pm

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