FS/FS/svc_acct.pm

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