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_table => 'svc_domain',
 341                          select_key   => 'svcnum',
 342                          select_label => 'domain',
 343                          disable_inventory => 1,
 344                          required => 1,
 345                        },
 346         'pbxsvc'    => { label => 'PBX',
 347                          type  => 'select-svc_pbx.html',
 348                          disable_inventory => 1,
 349                          disable_select => 1, #UI wonky, pry works otherwise
 350                        },
 351         'sectornum' => 'Tower sector',
 352         'usergroup' => {
 353                          label => 'RADIUS groups',
 354                          type  => 'select-radius_group.html',
 355                          disable_inventory => 1,
 356                          disable_select => 1,
 357                          multiple => 1,
 358                        },
 359         'seconds'   => { label => 'Seconds',
 360                          label_sort => 'with Time Remaining',
 361                          type  => 'text',
 362                          disable_inventory => 1,
 363                          disable_select => 1,
 364                          disable_part_svc_column => 1,
 365                        },
 366         'upbytes'   => { label => 'Upload',
 367                          type  => 'text',
 368                          disable_inventory => 1,
 369                          disable_select => 1,
 370                          'format' => \&FS::UI::bytecount::display_bytecount,
 371                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 372                          disable_part_svc_column => 1,
 373                        },
 374         'downbytes' => { label => 'Download',
 375                          type  => 'text',
 376                          disable_inventory => 1,
 377                          disable_select => 1,
 378                          'format' => \&FS::UI::bytecount::display_bytecount,
 379                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 380                          disable_part_svc_column => 1,
 381                        },
 382         'totalbytes'=> { label => 'Total up and download',
 383                          type  => 'text',
 384                          disable_inventory => 1,
 385                          disable_select => 1,
 386                          'format' => \&FS::UI::bytecount::display_bytecount,
 387                          'parse' => \&FS::UI::bytecount::parse_bytecount,
 388                          disable_part_svc_column => 1,
 389                        },
 390         'seconds_threshold'   => { label => 'Seconds threshold',
 391                                    type  => 'text',
 392                                    disable_inventory => 1,
 393                                    disable_select => 1,
 394                                    disable_part_svc_column => 1,
 395                                  },
 396         'upbytes_threshold'   => { label => 'Upload threshold',
 397                                    type  => 'text',
 398                                    disable_inventory => 1,
 399                                    disable_select => 1,
 400                                    'format' => \&FS::UI::bytecount::display_bytecount,
 401                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 402                                    disable_part_svc_column => 1,
 403                                  },
 404         'downbytes_threshold' => { label => 'Download threshold',
 405                                    type  => 'text',
 406                                    disable_inventory => 1,
 407                                    disable_select => 1,
 408                                    'format' => \&FS::UI::bytecount::display_bytecount,
 409                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 410                                    disable_part_svc_column => 1,
 411                                  },
 412         'totalbytes_threshold'=> { label => 'Total up and download threshold',
 413                                    type  => 'text',
 414                                    disable_inventory => 1,
 415                                    disable_select => 1,
 416                                    'format' => \&FS::UI::bytecount::display_bytecount,
 417                                    'parse' => \&FS::UI::bytecount::parse_bytecount,
 418                                    disable_part_svc_column => 1,
 419                                  },
 420         'last_login'=>           {
 421                                    label     => 'Last login',
 422                                    type      => 'disabled',
 423                                  },
 424         'last_logout'=>          {
 425                                    label     => 'Last logout',
 426                                    type      => 'disabled',
 427                                  },
 428
 429         'cgp_aliases' => {
 430                            label => 'Communigate aliases',
 431                            type  => 'text',
 432                            disable_inventory => 1,
 433                            disable_select    => 1,
 434                          },
 435         #settings
 436         'cgp_type'=> {
 437                        label => 'Communigate account type',
 438                        type => 'select',
 439                        select_list => [qw( MultiMailbox TextMailbox MailDirMailbox AGrade BGrade CGrade )],
 440                        disable_inventory => 1,
 441                        disable_select    => 1,
 442                      },
 443         'cgp_accessmodes' => {
 444                                label => 'Communigate enabled services',
 445                                type  => 'communigate_pro-accessmodes',
 446                                disable_inventory => 1,
 447                                disable_select    => 1,
 448                              },
 449         'cgp_rulesallowed'   => {
 450           label       => 'Allowed mail rules',
 451           type        => 'select',
 452           select_list => [ '', 'No', 'Filter Only', 'All But Exec', 'Any' ],
 453           disable_inventory => 1,
 454           disable_select    => 1,
 455         },
 456         'cgp_rpopallowed'    => { label => 'RPOP modifications',
 457                                   type  => 'checkbox',
 458                                 },
 459         'cgp_mailtoall'      => { label => 'Accepts mail to "all"',
 460                                   type  => 'checkbox',
 461                                 },
 462         'cgp_addmailtrailer' => { label => 'Add trailer to sent mail',
 463                                   type  => 'checkbox',
 464                                 },
 465         'cgp_archiveafter'   => {
 466           label       => 'Archive messages after',
 467           type        => 'select',
 468           select_hash => [
 469                            -2 => 'default(730 days)',
 470                            0 => 'Never',
 471                            86400 => '24 hours',
 472                            172800 => '2 days',
 473                            259200 => '3 days',
 474                            432000 => '5 days',
 475                            604800 => '7 days',
 476                            1209600 => '2 weeks',
 477                            2592000 => '30 days',
 478                            7776000 => '90 days',
 479                            15552000 => '180 days',
 480                            31536000 => '365 days',
 481                            63072000 => '730 days',
 482                          ],
 483           disable_inventory => 1,
 484           disable_select    => 1,
 485         },
 486         #XXX mailing lists
 487
 488         #preferences
 489         'cgp_deletemode' => {
 490                               label => 'Communigate message delete method',
 491                               type  => 'select',
 492                               select_list => [ 'Move To Trash', 'Immediately', 'Mark' ],
 493                               disable_inventory => 1,
 494                               disable_select    => 1,
 495                             },
 496         'cgp_emptytrash' => {
 497                               label     => 'Communigate on logout remove trash',
 498                               type        => 'select',
 499                               select_list => __PACKAGE__->cgp_emptytrash_values,
 500                               disable_inventory => 1,
 501                               disable_select    => 1,
 502                             },
 503         'cgp_language' => {
 504                             label => 'Communigate language',
 505                             type  => 'select',
 506                             select_list => [ '', qw( English Arabic Chinese Dutch French German Hebrew Italian Japanese Portuguese Russian Slovak Spanish Thai ) ],
 507                             disable_inventory => 1,
 508                             disable_select    => 1,
 509                           },
 510         'cgp_timezone' => {
 511                             label       => 'Communigate time zone',
 512                             type        => 'select',
 513                             select_list => __PACKAGE__->cgp_timezone_values,
 514                             disable_inventory => 1,
 515                             disable_select    => 1,
 516                           },
 517         'cgp_skinname' => {
 518                             label => 'Communigate layout',
 519                             type  => 'select',
 520                             select_list => [ '', '***', 'GoldFleece', 'Skin2' ],
 521                             disable_inventory => 1,
 522                             disable_select    => 1,
 523                           },
 524         'cgp_prontoskinname' => {
 525                             label => 'Communigate Pronto style',
 526                             type  => 'select',
 527                             select_list => [ '', 'Pronto', 'Pronto-darkflame', 'Pronto-steel', 'Pronto-twilight', ],
 528                             disable_inventory => 1,
 529                             disable_select    => 1,
 530                           },
 531         'cgp_sendmdnmode' => {
 532           label => 'Communigate send read receipts',
 533           type  => 'select',
 534           select_list => [ '', 'Never', 'Manually', 'Automatically' ],
 535           disable_inventory => 1,
 536           disable_select    => 1,
 537         },
 538
 539         #mail
 540         #XXX RPOP settings
 541
 542     },
 543   };
 544 }
 545
 546 sub table { 'svc_acct'; }
 547
 548 sub table_dupcheck_fields { ( 'username', 'domsvc' ); }
 549
 550 sub last_login {
 551   shift->_lastlog('in', @_);
 552 }
 553
 554 sub last_logout {
 555   shift->_lastlog('out', @_);
 556 }
 557
 558 sub _lastlog {
 559   my( $self, $op, $time ) = @_;
 560
 561   if ( defined($time) ) {
 562     warn "$me last_log$op called on svcnum ". $self->svcnum.
 563          ' ('. $self->email. "): $time\n"
 564       if $DEBUG;
 565
 566     my $dbh = dbh;
 567
 568     my $sql = "UPDATE svc_acct SET last_log$op = ? WHERE svcnum = ?";
 569     warn "$me $sql\n"
 570       if $DEBUG;
 571
 572     my $sth = $dbh->prepare( $sql )
 573       or die "Error preparing $sql: ". $dbh->errstr;
 574     my $rv = $sth->execute($time, $self->svcnum);
 575     die "Error executing $sql: ". $sth->errstr
 576       unless defined($rv);
 577     die "Can't update last_log$op for svcnum". $self->svcnum
 578       if $rv == 0;
 579
 580     $self->{'Hash'}->{"last_log$op"} = $time;
 581   }else{
 582     $self->getfield("last_log$op");
 583   }
 584 }
 585
 586 =item search_sql STRING
 587
 588 Class method which returns an SQL fragment to search for the given string.
 589
 590 =cut
 591
 592 sub search_sql {
 593   my( $class, $string ) = @_;
 594   if ( $string =~ /^([^@]+)@([^@]+)$/ ) {
 595     my( $username, $domain ) = ( $1, $2 );
 596     my $q_username = dbh->quote($username);
 597     my @svc_domain = qsearch('svc_domain', { 'domain' => $domain } );
 598     if ( @svc_domain ) {
 599       "svc_acct.username = $q_username AND ( ".
 600         join( ' OR ', map { "svc_acct.domsvc = ". $_->svcnum; } @svc_domain ).
 601       " )";
 602     } else {
 603       '1 = 0'; #false
 604     }
 605   } elsif ( $string =~ /^(\d{1,3}\.){3}\d{1,3}$/ ) {
 606     ' ( '.
 607       $class->search_sql_field('slipip',   $string ).
 608     ' OR '.
 609       $class->search_sql_field('username', $string ).
 610     ' ) ';
 611   } else {
 612     $class->search_sql_field('username', $string);
 613   }
 614 }
 615
 616 =item label [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 617
 618 Returns the "username@domain" string for this account.
 619
 620 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 621 history records.
 622
 623 =cut
 624
 625 sub label {
 626   my $self = shift;
 627   $self->email(@_);
 628 }
 629
 630 =item label_long [ END_TIMESTAMP [ START_TIMESTAMP ] ]
 631
 632 Returns a longer string label for this acccount ("Real Name <username@domain>"
 633 if available, or "username@domain").
 634
 635 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
 636 history records.
 637
 638 =cut
 639
 640 sub label_long {
 641   my $self = shift;
 642   my $label = $self->label(@_);
 643   my $finger = $self->finger;
 644   return $label unless $finger =~ /\S/;
 645   my $maxlen = 40 - length($label) - length($self->cust_svc->part_svc->svc);
 646   $finger = substr($finger, 0, $maxlen-3).'...' if length($finger) > $maxlen;
 647   "$finger <$label>";
 648 }
 649
 650 =item insert [ , OPTION => VALUE ... ]
 651
 652 Adds this account to the database.  If there is an error, returns the error,
 653 otherwise returns false.
 654
 655 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 656 defined.  An FS::cust_svc record will be created and inserted.
 657
 658 The additional field I<usergroup> can optionally be defined; if so it should
 659 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 660
 661 The additional field I<child_objects> can optionally be defined; if so it
 662 should contain an arrayref of FS::tablename objects.  They will have their
 663 svcnum fields set and will be inserted after this record, but before any
 664 exports are run.  Each element of the array can also optionally be a
 665 two-element array reference containing the child object and the name of an
 666 alternate field to be filled in with the newly-inserted svcnum, for example
 667 C<[ $svc_forward, 'srcsvc' ]>
 668
 669 Currently available options are: I<depend_jobnum>
 670
 671 If I<depend_jobnum> is set (to a scalar jobnum or an array reference of
 672 jobnums), all provisioning jobs will have a dependancy on the supplied
 673 jobnum(s) (they will not run until the specific job(s) complete(s)).
 674
 675 (TODOC: L<FS::queue> and L<freeside-queued>)
 676
 677 (TODOC: new exports!)
 678
 679 =cut
 680
 681 sub insert {
 682   my $self = shift;
 683   my %options = @_;
 684
 685   if ( $DEBUG ) {
 686     warn "[$me] insert called on $self: ". Dumper($self).
 687          "\nwith options: ". Dumper(%options);
 688   }
 689
 690   local $SIG{HUP} = 'IGNORE';
 691   local $SIG{INT} = 'IGNORE';
 692   local $SIG{QUIT} = 'IGNORE';
 693   local $SIG{TERM} = 'IGNORE';
 694   local $SIG{TSTP} = 'IGNORE';
 695   local $SIG{PIPE} = 'IGNORE';
 696
 697   my $oldAutoCommit = $FS::UID::AutoCommit;
 698   local $FS::UID::AutoCommit = 0;
 699   my $dbh = dbh;
 700
 701   my @jobnums;
 702   my $error = $self->SUPER::insert( # usergroup is here
 703     'jobnums'       => \@jobnums,
 704     'child_objects' => $self->child_objects,
 705     %options,
 706   );
 707
 708   $error ||= $self->insert_password_history;
 709
 710   if ( $error ) {
 711     $dbh->rollback if $oldAutoCommit;
 712     return $error;
 713   }
 714
 715   unless ( $skip_fuzzyfiles ) {
 716     $error = $self->queue_fuzzyfiles_update;
 717     if ( $error ) {
 718       $dbh->rollback if $oldAutoCommit;
 719       return "updating fuzzy search cache: $error";
 720     }
 721   }
 722
 723   my $cust_pkg = $self->cust_svc->cust_pkg;
 724
 725   if ( $cust_pkg ) {
 726     my $cust_main = $cust_pkg->cust_main;
 727     my $agentnum = $cust_main->agentnum;
 728
 729     if (   $conf->exists('emailinvoiceautoalways')
 730         || $conf->exists('emailinvoiceauto')
 731         && ! $cust_main->invoicing_list_emailonly
 732        ) {
 733       my @invoicing_list = $cust_main->invoicing_list;
 734       push @invoicing_list, $self->email;
 735       $cust_main->invoicing_list(\@invoicing_list);
 736     }
 737
 738     #welcome email
 739     my @welcome_exclude_svcparts = $conf->config('svc_acct_welcome_exclude');
 740     unless ( grep { $_ eq $self->svcpart } @welcome_exclude_svcparts ) {
 741         my $error = '';
 742         my $msgnum = $conf->config('welcome_msgnum', $agentnum);
 743         if ( $msgnum ) {
 744           my $msg_template = qsearchs('msg_template', { msgnum => $msgnum });
 745           $error = $msg_template->send('cust_main' => $cust_main,
 746                                        'object'    => $self);
 747         }
 748         else { #!$msgnum
 749           my ($to,$welcome_template,$welcome_from,$welcome_subject,$welcome_subject_template,$welcome_mimetype)
 750             = ('','','','','','');
 751
 752           if ( $conf->exists('welcome_email', $agentnum) ) {
 753             $welcome_template = new Text::Template (
 754               TYPE   => 'ARRAY',
 755               SOURCE => [ map "$_\n", $conf->config('welcome_email', $agentnum) ]
 756             ) or warn "can't create welcome email template: $Text::Template::ERROR";
 757             $welcome_from = $conf->config('welcome_email-from', $agentnum);
 758               # || 'your-isp-is-dum'
 759             $welcome_subject = $conf->config('welcome_email-subject', $agentnum)
 760               || 'Welcome';
 761             $welcome_subject_template = new Text::Template (
 762               TYPE   => 'STRING',
 763               SOURCE => $welcome_subject,
 764             ) or warn "can't create welcome email subject template: $Text::Template::ERROR";
 765             $welcome_mimetype = $conf->config('welcome_email-mimetype', $agentnum)
 766               || 'text/plain';
 767           }
 768           if ( $welcome_template ) {
 769             my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ } $cust_main->invoicing_list );
 770             if ( $to ) {
 771
 772               my %hash = (
 773                            'custnum'  => $self->custnum,
 774                            'username' => $self->username,
 775                            'password' => $self->_password,
 776                            'first'    => $cust_main->first,
 777                            'last'     => $cust_main->getfield('last'),
 778                            'pkg'      => $cust_pkg->part_pkg->pkg,
 779                          );
 780               my $wqueue = new FS::queue {
 781                 'svcnum' => $self->svcnum,
 782                 'job'    => 'FS::svc_acct::send_email'
 783               };
 784               my $error = $wqueue->insert(
 785                 'to'       => $to,
 786                 'from'     => $welcome_from,
 787                 'subject'  => $welcome_subject_template->fill_in( HASH => \%hash, ),
 788                 'mimetype' => $welcome_mimetype,
 789                 'body'     => $welcome_template->fill_in( HASH => \%hash, ),
 790               );
 791               if ( $error ) {
 792                 $dbh->rollback if $oldAutoCommit;
 793                 return "error queuing welcome email: $error";
 794               }
 795
 796               if ( $options{'depend_jobnum'} ) {
 797                 warn "$me depend_jobnum found; adding to welcome email dependancies"
 798                   if $DEBUG;
 799                 if ( ref($options{'depend_jobnum'}) ) {
 800                   warn "$me adding jobs ". join(', ', @{$options{'depend_jobnum'}} ).
 801                        "to welcome email dependancies"
 802                     if $DEBUG;
 803                   push @jobnums, @{ $options{'depend_jobnum'} };
 804                 } else {
 805                   warn "$me adding job $options{'depend_jobnum'} ".
 806                        "to welcome email dependancies"
 807                     if $DEBUG;
 808                   push @jobnums, $options{'depend_jobnum'};
 809                 }
 810               }
 811
 812               foreach my $jobnum ( @jobnums ) {
 813                 my $error = $wqueue->depend_insert($jobnum);
 814                 if ( $error ) {
 815                   $dbh->rollback if $oldAutoCommit;
 816                   return "error queuing welcome email job dependancy: $error";
 817                 }
 818               }
 819
 820             }
 821
 822           } # if $welcome_template
 823         } # if !$msgnum
 824     }
 825   } # if $cust_pkg
 826
 827   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 828   ''; #no error
 829 }
 830
 831 # set usage fields and thresholds if unset but set in a package def
 832 # AND the package already has a last bill date (otherwise they get double added)
 833 sub preinsert_hook_first {
 834   my $self = shift;
 835
 836   return '' unless $self->pkgnum;
 837
 838   my $cust_pkg = qsearchs( 'cust_pkg', { 'pkgnum' => $self->pkgnum } );
 839   return '' unless $cust_pkg && $cust_pkg->last_bill;
 840
 841   my $part_pkg = $cust_pkg->part_pkg;
 842   return '' unless $part_pkg && $part_pkg->can('usage_valuehash');
 843
 844   my %values = $part_pkg->usage_valuehash;
 845   my $multiplier = $conf->exists('svc_acct-usage_threshold')
 846                      ? 1 - $conf->config('svc_acct-usage_threshold')/100
 847                      : 0.20; #doesn't matter
 848
 849   foreach ( keys %values ) {
 850     next if $self->getfield($_);
 851     $self->setfield( $_, $values{$_} );
 852     $self->setfield( $_. '_threshold', int( $values{$_} * $multiplier ) )
 853       if $conf->exists('svc_acct-usage_threshold');
 854   }
 855
 856   ''; #no error
 857 }
 858
 859 =item delete
 860
 861 Deletes this account from the database.  If there is an error, returns the
 862 error, otherwise returns false.
 863
 864 The corresponding FS::cust_svc record will be deleted as well.
 865
 866 (TODOC: new exports!)
 867
 868 =cut
 869
 870 sub delete {
 871   my $self = shift;
 872
 873   return "can't delete system account" if $self->_check_system;
 874
 875   return "Can't delete an account which is a (svc_forward) source!"
 876     if qsearch( 'svc_forward', { 'srcsvc' => $self->svcnum } );
 877
 878   return "Can't delete an account which is a (svc_forward) destination!"
 879     if qsearch( 'svc_forward', { 'dstsvc' => $self->svcnum } );
 880
 881   return "Can't delete an account with (svc_www) web service!"
 882     if qsearch( 'svc_www', { 'usersvc' => $self->svcnum } );
 883
 884   # what about records in session ? (they should refer to history table)
 885
 886   local $SIG{HUP} = 'IGNORE';
 887   local $SIG{INT} = 'IGNORE';
 888   local $SIG{QUIT} = 'IGNORE';
 889   local $SIG{TERM} = 'IGNORE';
 890   local $SIG{TSTP} = 'IGNORE';
 891   local $SIG{PIPE} = 'IGNORE';
 892
 893   my $oldAutoCommit = $FS::UID::AutoCommit;
 894   local $FS::UID::AutoCommit = 0;
 895   my $dbh = dbh;
 896
 897   foreach my $cust_main_invoice (
 898     qsearch( 'cust_main_invoice', { 'dest' => $self->svcnum } )
 899   ) {
 900     unless ( defined($cust_main_invoice) ) {
 901       warn "WARNING: something's wrong with qsearch";
 902       next;
 903     }
 904     my %hash = $cust_main_invoice->hash;
 905     $hash{'dest'} = $self->email;
 906     my $new = new FS::cust_main_invoice \%hash;
 907     my $error = $new->replace($cust_main_invoice);
 908     if ( $error ) {
 909       $dbh->rollback if $oldAutoCommit;
 910       return $error;
 911     }
 912   }
 913
 914   foreach my $svc_domain (
 915     qsearch( 'svc_domain', { 'catchall' => $self->svcnum } )
 916   ) {
 917     my %hash = new FS::svc_domain->hash;
 918     $hash{'catchall'} = '';
 919     my $new = new FS::svc_domain \%hash;
 920     my $error = $new->replace($svc_domain);
 921     if ( $error ) {
 922       $dbh->rollback if $oldAutoCommit;
 923       return $error;
 924     }
 925   }
 926
 927   foreach my $svc_phone (
 928     qsearch( 'svc_phone', { 'forward_svcnum' => $self->svcnum })
 929   ) {
 930     $svc_phone->set('forward_svcnum', '');
 931     my $error = $svc_phone->replace;
 932     if ( $error ) {
 933       $dbh->rollback if $oldAutoCommit;
 934       return $error;
 935     }
 936   }
 937
 938   my $error = $self->delete_password_history
 939            || $self->SUPER::delete; # usergroup here
 940   if ( $error ) {
 941     $dbh->rollback if $oldAutoCommit;
 942     return $error;
 943   }
 944
 945   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 946   '';
 947 }
 948
 949 =item replace OLD_RECORD
 950
 951 Replaces OLD_RECORD with this one in the database.  If there is an error,
 952 returns the error, otherwise returns false.
 953
 954 The additional field I<usergroup> can optionally be defined; if so it should
 955 contain an arrayref of group names.  See L<FS::radius_usergroup>.
 956
 957
 958 =cut
 959
 960 sub replace {
 961   my $new = shift;
 962
 963   my $old = ( blessed($_[0]) && $_[0]->isa('FS::Record') )
 964               ? shift
 965               : $new->replace_old;
 966
 967   warn "$me replacing $old with $new\n" if $DEBUG;
 968
 969   my $error;
 970
 971   return "can't modify system account" if $old->_check_system;
 972
 973   {
 974     #no warnings 'numeric';  #alas, a 5.006-ism
 975     local($^W) = 0;
 976
 977     foreach my $xid (qw( uid gid )) {
 978
 979       return "Can't change $xid!"
 980         if ! $conf->exists("svc_acct-edit_$xid")
 981            && $old->$xid() != $new->$xid()
 982            && $new->cust_svc->part_svc->part_svc_column($xid)->columnflag ne 'F'
 983     }
 984
 985   }
 986
 987   return "can't change username"
 988     if $old->username ne $new->username
 989     && $conf->exists('svc_acct-no_edit_username');
 990
 991   #change homdir when we change username
 992   $new->setfield('dir', '') if $old->username ne $new->username;
 993
 994   local $SIG{HUP} = 'IGNORE';
 995   local $SIG{INT} = 'IGNORE';
 996   local $SIG{QUIT} = 'IGNORE';
 997   local $SIG{TERM} = 'IGNORE';
 998   local $SIG{TSTP} = 'IGNORE';
 999   local $SIG{PIPE} = 'IGNORE';
1000
1001   my $oldAutoCommit = $FS::UID::AutoCommit;
1002   local $FS::UID::AutoCommit = 0;
1003   my $dbh = dbh;
1004
1005   $error = $new->SUPER::replace($old, @_); # usergroup here
1006
1007   # don't need to record this unless the password was changed
1008   if ( $old->_password ne $new->_password ) {
1009     $error ||= $new->insert_password_history;
1010   }
1011
1012   if ( $error ) {
1013     $dbh->rollback if $oldAutoCommit;
1014     return $error if $error;
1015   }
1016
1017   if ( $new->username ne $old->username && ! $skip_fuzzyfiles ) {
1018     $error = $new->queue_fuzzyfiles_update;
1019     if ( $error ) {
1020       $dbh->rollback if $oldAutoCommit;
1021       return "updating fuzzy search cache: $error";
1022     }
1023   }
1024
1025   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1026   ''; #no error
1027 }
1028
1029 =item queue_fuzzyfiles_update
1030
1031 Used by insert & replace to update the fuzzy search cache
1032
1033 =cut
1034
1035 sub queue_fuzzyfiles_update {
1036   my $self = shift;
1037
1038   local $SIG{HUP} = 'IGNORE';
1039   local $SIG{INT} = 'IGNORE';
1040   local $SIG{QUIT} = 'IGNORE';
1041   local $SIG{TERM} = 'IGNORE';
1042   local $SIG{TSTP} = 'IGNORE';
1043   local $SIG{PIPE} = 'IGNORE';
1044
1045   my $oldAutoCommit = $FS::UID::AutoCommit;
1046   local $FS::UID::AutoCommit = 0;
1047   my $dbh = dbh;
1048
1049   my $queue = new FS::queue {
1050     'svcnum' => $self->svcnum,
1051     'job'    => 'FS::svc_acct::append_fuzzyfiles'
1052   };
1053   my $error = $queue->insert($self->username);
1054   if ( $error ) {
1055     $dbh->rollback if $oldAutoCommit;
1056     return "queueing job (transaction rolled back): $error";
1057   }
1058
1059   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
1060   '';
1061
1062 }
1063
1064
1065 =item suspend
1066
1067 Suspends this account by calling export-specific suspend hooks.  If there is
1068 an error, returns the error, otherwise returns false.
1069
1070 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1071
1072 =cut
1073
1074 sub suspend {
1075   my $self = shift;
1076   return "can't suspend system account" if $self->_check_system;
1077   $self->SUPER::suspend(@_);
1078 }
1079
1080 =item unsuspend
1081
1082 Unsuspends this account by by calling export-specific suspend hooks.  If there
1083 is an error, returns the error, otherwise returns false.
1084
1085 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
1086
1087 =cut
1088
1089 sub unsuspend {
1090   my $self = shift;
1091   my %hash = $self->hash;
1092   if ( $hash{_password} =~ /^\*SUSPENDED\* (.*)$/ ) {
1093     $hash{_password} = $1;
1094     my $new = new FS::svc_acct ( \%hash );
1095     my $error = $new->replace($self);
1096     return $error if $error;
1097   }
1098
1099   $self->SUPER::unsuspend(@_);
1100 }
1101
1102 =item cancel
1103
1104 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
1105
1106 If the B<auto_unset_catchall> configuration option is set, this method will
1107 automatically remove any references to the canceled service in the catchall
1108 field of svc_domain.  This allows packages that contain both a svc_domain and
1109 its catchall svc_acct to be canceled in one step.
1110
1111 =cut
1112
1113 sub cancel {
1114   # Only one thing to do at this level
1115   my $self = shift;
1116   foreach my $svc_domain (
1117       qsearch( 'svc_domain', { catchall => $self->svcnum } ) ) {
1118     if($conf->exists('auto_unset_catchall')) {
1119       my %hash = $svc_domain->hash;
1120       $hash{catchall} = '';
1121       my $new = new FS::svc_domain ( \%hash );
1122       my $error = $new->replace($svc_domain);
1123       return $error if $error;
1124     } else {
1125       return "cannot unprovision svc_acct #".$self->svcnum.
1126           " while assigned as catchall for svc_domain #".$svc_domain->svcnum;
1127     }
1128   }
1129
1130   $self->SUPER::cancel(@_);
1131 }
1132
1133
1134 =item check
1135
1136 Checks all fields to make sure this is a valid service.  If there is an error,
1137 returns the error, otherwise returns false.  Called by the insert and replace
1138 methods.
1139
1140 Sets any fixed values; see L<FS::part_svc>.
1141
1142 =cut
1143
1144 sub check {
1145   my $self = shift;
1146
1147   my($recref) = $self->hashref;
1148
1149   my $x = $self->setfixed;
1150   return $x unless ref($x);
1151   my $part_svc = $x;
1152
1153   my $error = $self->ut_numbern('svcnum')
1154               #|| $self->ut_number('domsvc')
1155               || $self->ut_foreign_key( 'domsvc', 'svc_domain', 'svcnum' )
1156               || $self->ut_foreign_keyn('pbxsvc', 'svc_pbx',    'svcnum' )
1157               || $self->ut_foreign_keyn('sectornum','tower_sector','sectornum')
1158               || $self->ut_foreign_keyn('routernum','router','routernum')
1159               || $self->ut_foreign_keyn('blocknum','addr_block','blocknum')
1160               || $self->ut_textn('sec_phrase')
1161               || $self->ut_snumbern('seconds')
1162               || $self->ut_snumbern('upbytes')
1163               || $self->ut_snumbern('downbytes')
1164               || $self->ut_snumbern('totalbytes')
1165               || $self->ut_snumbern('seconds_threshold')
1166               || $self->ut_snumbern('upbytes_threshold')
1167               || $self->ut_snumbern('downbytes_threshold')
1168               || $self->ut_snumbern('totalbytes_threshold')
1169               || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1170               || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1171               || $self->ut_enum('password_recover',    [ '', 'Y' ])
1172               #cardfortress
1173               || $self->ut_anything('cf_privatekey')
1174               #communigate
1175               || $self->ut_textn('cgp_accessmodes')
1176               || $self->ut_alphan('cgp_type')
1177               || $self->ut_textn('cgp_aliases' ) #well
1178               # settings
1179               || $self->ut_alphasn('cgp_rulesallowed')
1180               || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1181               || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1182               || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1183               || $self->ut_snumbern('cgp_archiveafter')
1184               # preferences
1185               || $self->ut_alphasn('cgp_deletemode')
1186               || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1187               || $self->ut_alphan('cgp_language')
1188               || $self->ut_textn('cgp_timezone')
1189               || $self->ut_textn('cgp_skinname')
1190               || $self->ut_textn('cgp_prontoskinname')
1191               || $self->ut_alphan('cgp_sendmdnmode')
1192   ;
1193   return $error if $error;
1194
1195   # assign IP address, etc.
1196   if ( $conf->exists('svc_acct-ip_addr') ) {
1197     my $error = $self->svc_ip_check;
1198     return $error if $error;
1199   } else { # I think this is correct
1200     $self->routernum('');
1201     $self->blocknum('');
1202   }
1203
1204   my $cust_pkg;
1205   local $username_letter = $username_letter;
1206   local $username_uppercase = $username_uppercase;
1207   if ($self->svcnum) {
1208     my $cust_svc = $self->cust_svc
1209       or return "no cust_svc record found for svcnum ". $self->svcnum;
1210     my $cust_pkg = $cust_svc->cust_pkg;
1211   }
1212   if ($self->pkgnum) {
1213     $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1214   }
1215   if ($cust_pkg) {
1216     $username_letter =
1217       $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1218     $username_uppercase =
1219       $conf->exists('username-uppercase', $cust_pkg->cust_main->agentnum);
1220   }
1221
1222   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1223
1224   $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#\!]{$usernamemin,$ulen})$/i
1225     or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1226   $recref->{username} = $1;
1227
1228   my $uerror = gettext('illegal_username'). ': '. $recref->{username};
1229
1230   unless ( $username_uppercase ) {
1231     $recref->{username} =~ /[A-Z]/ and return $uerror;
1232   }
1233   if ( $username_letterfirst ) {
1234     $recref->{username} =~ /^[a-z]/ or return $uerror;
1235   } elsif ( $username_letter ) {
1236     $recref->{username} =~ /[a-z]/ or return $uerror;
1237   }
1238   if ( $username_noperiod ) {
1239     $recref->{username} =~ /\./ and return $uerror;
1240   }
1241   if ( $username_nounderscore ) {
1242     $recref->{username} =~ /_/ and return $uerror;
1243   }
1244   if ( $username_nodash ) {
1245     $recref->{username} =~ /\-/ and return $uerror;
1246   }
1247   unless ( $username_ampersand ) {
1248     $recref->{username} =~ /\&/ and return $uerror;
1249   }
1250   unless ( $username_percent ) {
1251     $recref->{username} =~ /\%/ and return $uerror;
1252   }
1253   unless ( $username_colon ) {
1254     $recref->{username} =~ /\:/ and return $uerror;
1255   }
1256   unless ( $username_slash ) {
1257     $recref->{username} =~ /\// and return $uerror;
1258   }
1259   unless ( $username_equals ) {
1260     $recref->{username} =~ /\=/ and return $uerror;
1261   }
1262   unless ( $username_pound ) {
1263     $recref->{username} =~ /\#/ and return $uerror;
1264   }
1265   unless ( $username_exclamation ) {
1266     $recref->{username} =~ /\!/ and return $uerror;
1267   }
1268
1269
1270   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1271   $recref->{popnum} = $1;
1272   return "Unknown popnum" unless
1273     ! $recref->{popnum} ||
1274     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1275
1276   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1277
1278     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1279     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1280
1281     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1282     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1283     #not all systems use gid=uid
1284     #you can set a fixed gid in part_svc
1285
1286     return "Only root can have uid 0"
1287       if $recref->{uid} == 0
1288          && $recref->{username} !~ /^(root|toor|smtp)$/;
1289
1290     unless ( $recref->{username} eq 'sync' ) {
1291       if ( grep $_ eq $recref->{shell}, @shells ) {
1292         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1293       } else {
1294         return "Illegal shell \`". $self->shell. "\'; ".
1295                "shells configuration value contains: @shells";
1296       }
1297     } else {
1298       $recref->{shell} = '/bin/sync';
1299     }
1300
1301   } else {
1302     $recref->{gid} ne '' ?
1303       return "Can't have gid without uid" : ( $recref->{gid}='' );
1304     #$recref->{dir} ne '' ?
1305     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1306     $recref->{shell} ne '' ?
1307       return "Can't have shell without uid" : ( $recref->{shell}='' );
1308   }
1309
1310   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1311
1312     $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1313       or return "Illegal directory: ". $recref->{dir};
1314     $recref->{dir} = $1;
1315     return "Illegal directory"
1316       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1317     return "Illegal directory"
1318       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1319     unless ( $recref->{dir} ) {
1320       $recref->{dir} = $dir_prefix . '/';
1321       if ( $dirhash > 0 ) {
1322         for my $h ( 1 .. $dirhash ) {
1323           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1324         }
1325       } elsif ( $dirhash < 0 ) {
1326         for my $h ( reverse $dirhash .. -1 ) {
1327           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1328         }
1329       }
1330       $recref->{dir} .= $recref->{username};
1331     ;
1332     }
1333
1334   }
1335
1336   if ( $self->getfield('finger') eq '' ) {
1337     my $cust_pkg = $self->svcnum
1338       ? $self->cust_svc->cust_pkg
1339       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1340     if ( $cust_pkg ) {
1341       my $cust_main = $cust_pkg->cust_main;
1342       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1343     }
1344   }
1345   #  $error = $self->ut_textn('finger');
1346   #  return $error if $error;
1347   $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]*)$/
1348       or return "Illegal finger: ". $self->getfield('finger');
1349   $self->setfield('finger', $1);
1350
1351   for (qw( quota file_quota file_maxsize )) {
1352     $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1353     $recref->{$_} = $1;
1354   }
1355   $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1356   $recref->{file_maxnum} = $1;
1357
1358   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1359     if ( $recref->{slipip} eq '' ) {
1360       $recref->{slipip} = ''; # eh?
1361     } elsif ( $recref->{slipip} eq '0e0' ) {
1362       $recref->{slipip} = '0e0';
1363     } else {
1364       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1365         or return "Illegal slipip: ". $self->slipip;
1366       $recref->{slipip} = $1;
1367     }
1368   }
1369
1370   #arbitrary RADIUS stuff; allow ut_textn for now
1371   foreach ( grep /^radius_/, fields('svc_acct') ) {
1372     $self->ut_textn($_);
1373   }
1374
1375   # First, if _password is blank, generate one and set default encoding.
1376   if ( ! $recref->{_password} ) {
1377     $error = $self->set_password('');
1378   }
1379   # But if there's a _password but no encoding, assume it's plaintext and
1380   # set it to default encoding.
1381   elsif ( ! $recref->{_password_encoding} ) {
1382     $error = $self->set_password($recref->{_password});
1383   }
1384   return $error if $error;
1385
1386   # Next, check _password to ensure compliance with the encoding.
1387   if ( $recref->{_password_encoding} eq 'ldap' ) {
1388
1389     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1390       $recref->{_password} = uc($1).$2;
1391     } else {
1392       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1393     }
1394
1395   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1396
1397     if ( $recref->{_password} =~
1398            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1399            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1400        ) {
1401
1402       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1403
1404     } else {
1405       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1406     }
1407
1408   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1409     # Password randomization is now in set_password.
1410     # Strip whitespace characters, check length requirements, etc.
1411     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1412       $recref->{_password} = $1;
1413     } else {
1414       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1415              FS::Msgcat::_gettext('illegal_password_characters').
1416              ": ". $recref->{_password};
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;