FS/FS/svc_acct.pm

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