FS/FS/svc_acct.pm

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