FS/FS/svc_acct.pm

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