FS/FS/svc_acct.pm

   1 package FS::svc_acct;
   2
   3 use strict;
   4 use base qw( FS::svc_Domain_Mixin
   5              FS::svc_CGP_Mixin
   6              FS::svc_CGPRule_Mixin
   7              FS::svc_Radius_Mixin
   8              FS::svc_Tower_Mixin
   9              FS::svc_Common );
  10 use vars qw( $DEBUG $me $conf $skip_fuzzyfiles
  11              $dir_prefix @shells $usernamemin
  12              $usernamemax $passwordmin $passwordmax
  13              $username_ampersand $username_letter $username_letterfirst
  14              $username_noperiod $username_nounderscore $username_nodash
  15              $username_uppercase $username_percent $username_colon
  16              $username_slash $username_equals $username_pound
  17              $username_exclamation
  18              $password_noampersand $password_noexclamation
  19              $warning_template $warning_from $warning_subject $warning_mimetype
  20              $warning_cc
  21              $smtpmachine
  22              $radius_password $radius_ip
  23              $dirhash
  24              @saltset @pw_set );
  25 use Scalar::Util qw( blessed );
  26 use Math::BigInt;
  27 use Carp;
  28 use Fcntl qw(:flock);
  29 use Date::Format;
  30 use Crypt::PasswdMD5 1.2;
  31 use Digest::SHA 'sha1_base64';
  32 use Digest::MD5 'md5_base64';
  33 use Data::Dumper;
  34 use Text::Template;
  35 use Authen::Passphrase;
  36 use FS::UID qw( datasrc driver_name );
  37 use FS::Conf;
  38 use FS::Record qw( qsearch qsearchs fields dbh dbdef );
  39 use FS::Msgcat qw(gettext);
  40 use FS::UI::bytecount;
  41 use FS::UI::Web;
  42 use FS::part_pkg;
  43 use FS::part_svc;
  44 use FS::svc_acct_pop;
  45 use FS::cust_main_invoice;
  46 use FS::svc_domain;
  47 use FS::svc_pbx;
  48 use FS::raddb;
  49 use FS::queue;
  50 use FS::radius_usergroup;
  51 use FS::radius_group;
  52 use FS::export_svc;
  53 use FS::part_export;
  54 use FS::svc_forward;
  55 use FS::svc_www;
  56 use FS::cdr;
  57 use FS::acct_snarf;
  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_textn('sec_phrase')
1132               || $self->ut_snumbern('seconds')
1133               || $self->ut_snumbern('upbytes')
1134               || $self->ut_snumbern('downbytes')
1135               || $self->ut_snumbern('totalbytes')
1136               || $self->ut_snumbern('seconds_threshold')
1137               || $self->ut_snumbern('upbytes_threshold')
1138               || $self->ut_snumbern('downbytes_threshold')
1139               || $self->ut_snumbern('totalbytes_threshold')
1140               || $self->ut_enum('_password_encoding', ['',qw(plain crypt ldap)])
1141               || $self->ut_enum('password_selfchange', [ '', 'Y' ])
1142               || $self->ut_enum('password_recover',    [ '', 'Y' ])
1143               #cardfortress
1144               || $self->ut_anything('cf_privatekey')
1145               #communigate
1146               || $self->ut_textn('cgp_accessmodes')
1147               || $self->ut_alphan('cgp_type')
1148               || $self->ut_textn('cgp_aliases' ) #well
1149               # settings
1150               || $self->ut_alphasn('cgp_rulesallowed')
1151               || $self->ut_enum('cgp_rpopallowed', [ '', 'Y' ])
1152               || $self->ut_enum('cgp_mailtoall', [ '', 'Y' ])
1153               || $self->ut_enum('cgp_addmailtrailer', [ '', 'Y' ])
1154               || $self->ut_snumbern('cgp_archiveafter')
1155               # preferences
1156               || $self->ut_alphasn('cgp_deletemode')
1157               || $self->ut_enum('cgp_emptytrash', $self->cgp_emptytrash_values)
1158               || $self->ut_alphan('cgp_language')
1159               || $self->ut_textn('cgp_timezone')
1160               || $self->ut_textn('cgp_skinname')
1161               || $self->ut_textn('cgp_prontoskinname')
1162               || $self->ut_alphan('cgp_sendmdnmode')
1163   ;
1164   return $error if $error;
1165
1166   my $cust_pkg;
1167   local $username_letter = $username_letter;
1168   local $username_uppercase = $username_uppercase;
1169   if ($self->svcnum) {
1170     my $cust_svc = $self->cust_svc
1171       or return "no cust_svc record found for svcnum ". $self->svcnum;
1172     my $cust_pkg = $cust_svc->cust_pkg;
1173   }
1174   if ($self->pkgnum) {
1175     $cust_pkg = qsearchs('cust_pkg', { 'pkgnum' => $self->pkgnum } );#complain?
1176   }
1177   if ($cust_pkg) {
1178     $username_letter =
1179       $conf->exists('username-letter', $cust_pkg->cust_main->agentnum);
1180     $username_uppercase =
1181       $conf->exists('username-uppercase', $cust_pkg->cust_main->agentnum);
1182   }
1183
1184   my $ulen = $usernamemax || $self->dbdef_table->column('username')->length;
1185
1186   $recref->{username} =~ /^([a-z0-9_\-\.\&\%\:\/\=\#\!]{$usernamemin,$ulen})$/i
1187     or return gettext('illegal_username'). " ($usernamemin-$ulen): ". $recref->{username};
1188   $recref->{username} = $1;
1189
1190   my $uerror = gettext('illegal_username'). ': '. $recref->{username};
1191
1192   unless ( $username_uppercase ) {
1193     $recref->{username} =~ /[A-Z]/ and return $uerror;
1194   }
1195   if ( $username_letterfirst ) {
1196     $recref->{username} =~ /^[a-z]/ or return $uerror;
1197   } elsif ( $username_letter ) {
1198     $recref->{username} =~ /[a-z]/ or return $uerror;
1199   }
1200   if ( $username_noperiod ) {
1201     $recref->{username} =~ /\./ and return $uerror;
1202   }
1203   if ( $username_nounderscore ) {
1204     $recref->{username} =~ /_/ and return $uerror;
1205   }
1206   if ( $username_nodash ) {
1207     $recref->{username} =~ /\-/ and return $uerror;
1208   }
1209   unless ( $username_ampersand ) {
1210     $recref->{username} =~ /\&/ and return $uerror;
1211   }
1212   unless ( $username_percent ) {
1213     $recref->{username} =~ /\%/ and return $uerror;
1214   }
1215   unless ( $username_colon ) {
1216     $recref->{username} =~ /\:/ and return $uerror;
1217   }
1218   unless ( $username_slash ) {
1219     $recref->{username} =~ /\// and return $uerror;
1220   }
1221   unless ( $username_equals ) {
1222     $recref->{username} =~ /\=/ and return $uerror;
1223   }
1224   unless ( $username_pound ) {
1225     $recref->{username} =~ /\#/ and return $uerror;
1226   }
1227   unless ( $username_exclamation ) {
1228     $recref->{username} =~ /\!/ and return $uerror;
1229   }
1230
1231
1232   $recref->{popnum} =~ /^(\d*)$/ or return "Illegal popnum: ".$recref->{popnum};
1233   $recref->{popnum} = $1;
1234   return "Unknown popnum" unless
1235     ! $recref->{popnum} ||
1236     qsearchs('svc_acct_pop',{'popnum'=> $recref->{popnum} } );
1237
1238   unless ( $part_svc->part_svc_column('uid')->columnflag eq 'F' ) {
1239
1240     $recref->{uid} =~ /^(\d*)$/ or return "Illegal uid";
1241     $recref->{uid} = $1 eq '' ? $self->unique('uid') : $1;
1242
1243     $recref->{gid} =~ /^(\d*)$/ or return "Illegal gid";
1244     $recref->{gid} = $1 eq '' ? $recref->{uid} : $1;
1245     #not all systems use gid=uid
1246     #you can set a fixed gid in part_svc
1247
1248     return "Only root can have uid 0"
1249       if $recref->{uid} == 0
1250          && $recref->{username} !~ /^(root|toor|smtp)$/;
1251
1252     unless ( $recref->{username} eq 'sync' ) {
1253       if ( grep $_ eq $recref->{shell}, @shells ) {
1254         $recref->{shell} = (grep $_ eq $recref->{shell}, @shells)[0];
1255       } else {
1256         return "Illegal shell \`". $self->shell. "\'; ".
1257                "shells configuration value contains: @shells";
1258       }
1259     } else {
1260       $recref->{shell} = '/bin/sync';
1261     }
1262
1263   } else {
1264     $recref->{gid} ne '' ?
1265       return "Can't have gid without uid" : ( $recref->{gid}='' );
1266     #$recref->{dir} ne '' ?
1267     #  return "Can't have directory without uid" : ( $recref->{dir}='' );
1268     $recref->{shell} ne '' ?
1269       return "Can't have shell without uid" : ( $recref->{shell}='' );
1270   }
1271
1272   unless ( $part_svc->part_svc_column('dir')->columnflag eq 'F' ) {
1273
1274     $recref->{dir} =~ /^([\/\w\-\.\&\:\#]*)$/
1275       or return "Illegal directory: ". $recref->{dir};
1276     $recref->{dir} = $1;
1277     return "Illegal directory"
1278       if $recref->{dir} =~ /(^|\/)\.+(\/|$)/; #no .. component
1279     return "Illegal directory"
1280       if $recref->{dir} =~ /\&/ && ! $username_ampersand;
1281     unless ( $recref->{dir} ) {
1282       $recref->{dir} = $dir_prefix . '/';
1283       if ( $dirhash > 0 ) {
1284         for my $h ( 1 .. $dirhash ) {
1285           $recref->{dir} .= substr($recref->{username}, $h-1, 1). '/';
1286         }
1287       } elsif ( $dirhash < 0 ) {
1288         for my $h ( reverse $dirhash .. -1 ) {
1289           $recref->{dir} .= substr($recref->{username}, $h, 1). '/';
1290         }
1291       }
1292       $recref->{dir} .= $recref->{username};
1293     ;
1294     }
1295
1296   }
1297
1298   if ( $self->getfield('finger') eq '' ) {
1299     my $cust_pkg = $self->svcnum
1300       ? $self->cust_svc->cust_pkg
1301       : qsearchs('cust_pkg', { 'pkgnum' => $self->getfield('pkgnum') } );
1302     if ( $cust_pkg ) {
1303       my $cust_main = $cust_pkg->cust_main;
1304       $self->setfield('finger', $cust_main->first.' '.$cust_main->get('last') );
1305     }
1306   }
1307   #  $error = $self->ut_textn('finger');
1308   #  return $error if $error;
1309   $self->getfield('finger') =~ /^([\w \,\.\-\'\&\t\!\@\#\$\%\(\)\+\;\"\?\/\*\<\>]*)$/
1310       or return "Illegal finger: ". $self->getfield('finger');
1311   $self->setfield('finger', $1);
1312
1313   for (qw( quota file_quota file_maxsize )) {
1314     $recref->{$_} =~ /^(\w*)$/ or return "Illegal $_";
1315     $recref->{$_} = $1;
1316   }
1317   $recref->{file_maxnum} =~ /^\s*(\d*)\s*$/ or return "Illegal file_maxnum";
1318   $recref->{file_maxnum} = $1;
1319
1320   unless ( $part_svc->part_svc_column('slipip')->columnflag eq 'F' ) {
1321     if ( $recref->{slipip} eq '' ) {
1322       $recref->{slipip} = '';
1323     } elsif ( $recref->{slipip} eq '0e0' ) {
1324       $recref->{slipip} = '0e0';
1325     } else {
1326       $recref->{slipip} =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/
1327         or return "Illegal slipip: ". $self->slipip;
1328       $recref->{slipip} = $1;
1329     }
1330
1331   }
1332
1333   #arbitrary RADIUS stuff; allow ut_textn for now
1334   foreach ( grep /^radius_/, fields('svc_acct') ) {
1335     $self->ut_textn($_);
1336   }
1337
1338   # First, if _password is blank, generate one and set default encoding.
1339   if ( ! $recref->{_password} ) {
1340     $error = $self->set_password('');
1341   }
1342   # But if there's a _password but no encoding, assume it's plaintext and
1343   # set it to default encoding.
1344   elsif ( ! $recref->{_password_encoding} ) {
1345     $error = $self->set_password($recref->{_password});
1346   }
1347   return $error if $error;
1348
1349   # Next, check _password to ensure compliance with the encoding.
1350   if ( $recref->{_password_encoding} eq 'ldap' ) {
1351
1352     if ( $recref->{_password} =~ /^(\{[\w\-]+\})(!?.{0,64})$/ ) {
1353       $recref->{_password} = uc($1).$2;
1354     } else {
1355       return 'Illegal (ldap-encoded) password: '. $recref->{_password};
1356     }
1357
1358   } elsif ( $recref->{_password_encoding} eq 'crypt' ) {
1359
1360     if ( $recref->{_password} =~
1361            #/^(\$\w+\$.*|[\w\+\/]{13}|_[\w\+\/]{19}|\*)$/
1362            /^(!!?)?(\$\w+\$.*|[\w\+\/\.]{13}|_[\w\+\/\.]{19}|\*)$/
1363        ) {
1364
1365       $recref->{_password} = ( defined($1) ? $1 : '' ). $2;
1366
1367     } else {
1368       return 'Illegal (crypt-encoded) password: '. $recref->{_password};
1369     }
1370
1371   } elsif ( $recref->{_password_encoding} eq 'plain' ) {
1372     # Password randomization is now in set_password.
1373     # Strip whitespace characters, check length requirements, etc.
1374     if ( $recref->{_password} =~ /^([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1375       $recref->{_password} = $1;
1376     } else {
1377       return gettext('illegal_password'). " $passwordmin-$passwordmax ".
1378              FS::Msgcat::_gettext('illegal_password_characters').
1379              ": ". $recref->{_password};
1380     }
1381
1382     if ( $password_noampersand ) {
1383       $recref->{_password} =~ /\&/ and return gettext('illegal_password');
1384     }
1385     if ( $password_noexclamation ) {
1386       $recref->{_password} =~ /\!/ and return gettext('illegal_password');
1387     }
1388   }
1389   else {
1390     return "invalid password encoding ('".$recref->{_password_encoding}."'";
1391   }
1392   $self->SUPER::check;
1393
1394 }
1395
1396
1397 sub _password_encryption {
1398   my $self = shift;
1399   my $encoding = lc($self->_password_encoding);
1400   return if !$encoding;
1401   return 'plain' if $encoding eq 'plain';
1402   if($encoding eq 'crypt') {
1403     my $pass = $self->_password;
1404     $pass =~ s/^\*SUSPENDED\* //;
1405     $pass =~ s/^!!?//;
1406     return 'md5' if $pass =~ /^\$1\$/;
1407     #return 'blowfish' if $self->_password =~ /^\$2\$/;
1408     return 'des' if length($pass) == 13;
1409     return;
1410   }
1411   if($encoding eq 'ldap') {
1412     uc($self->_password) =~ /^\{([\w-]+)\}/;
1413     return 'crypt' if $1 eq 'CRYPT' or $1 eq 'DES';
1414     return 'plain' if $1 eq 'PLAIN' or $1 eq 'CLEARTEXT';
1415     return 'md5' if $1 eq 'MD5';
1416     return 'sha1' if $1 eq 'SHA' or $1 eq 'SHA-1';
1417
1418     return;
1419   }
1420   return;
1421 }
1422
1423 sub get_cleartext_password {
1424   my $self = shift;
1425   if($self->_password_encryption eq 'plain') {
1426     if($self->_password_encoding eq 'ldap') {
1427       $self->_password =~ /\{\w+\}(.*)$/;
1428       return $1;
1429     }
1430     else {
1431       return $self->_password;
1432     }
1433   }
1434   return;
1435 }
1436
1437
1438 =item set_password
1439
1440 Set the cleartext password for the account.  If _password_encoding is set, the
1441 new password will be encoded according to the existing method (including
1442 encryption mode, if it can be determined).  Otherwise,
1443 config('default-password-encoding') is used.
1444
1445 If no password is supplied (or a zero-length password when minimum password length
1446 is >0), one will be generated randomly.
1447
1448 =cut
1449
1450 sub set_password {
1451   my( $self, $pass ) = ( shift, shift );
1452
1453   warn "[$me] set_password (to $pass) called on $self: ". Dumper($self)
1454      if $DEBUG;
1455
1456   my $failure = gettext('illegal_password'). " $passwordmin-$passwordmax ".
1457                 FS::Msgcat::_gettext('illegal_password_characters').
1458                 ": ". $pass;
1459
1460   my( $encoding, $encryption ) = ('', '');
1461
1462   if ( $self->_password_encoding ) {
1463     $encoding = $self->_password_encoding;
1464     # identify existing encryption method, try to use it.
1465     $encryption = $self->_password_encryption;
1466     if (!$encryption) {
1467       # use the system default
1468       undef $encoding;
1469     }
1470   }
1471
1472   if ( !$encoding ) {
1473     # set encoding to system default
1474     ($encoding, $encryption) =
1475       split(/-/, lc($conf->config('default-password-encoding') || ''));
1476     $encoding ||= 'legacy';
1477     $self->_password_encoding($encoding);
1478   }
1479
1480   if ( $encoding eq 'legacy' ) {
1481
1482     # The legacy behavior from check():
1483     # If the password is blank, randomize it and set encoding to 'plain'.
1484     if(!defined($pass) or (length($pass) == 0 and $passwordmin)) {
1485       $pass = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
1486       $self->_password_encoding('plain');
1487     } else {
1488       # Prefix + valid-length password
1489       if ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([^\t\n]{$passwordmin,$passwordmax})$/ ) {
1490         $pass = $1.$3;
1491         $self->_password_encoding('plain');
1492       # Prefix + crypt string
1493       } elsif ( $pass =~ /^((\*SUSPENDED\* |!!?)?)([\w\.\/\$\;\+]{13,64})$/ ) {
1494         $pass = $1.$3;
1495         $self->_password_encoding('crypt');
1496       # Various disabled crypt passwords
1497       } elsif ( $pass eq '*' || $pass eq '!' || $pass eq '!!' ) {
1498         $self->_password_encoding('crypt');
1499       } else {
1500         return $failure;
1501       }
1502     }
1503
1504     $self->_password($pass);
1505     return;
1506
1507   }
1508
1509   return $failure
1510     if $passwordmin && length($pass) < $passwordmin
1511     or $passwordmax && length($pass) > $passwordmax;
1512
1513   if ( $encoding eq 'crypt' ) {
1514     if ($encryption eq 'md5') {
1515       $pass = unix_md5_crypt($pass);
1516     } elsif ($encryption eq 'des') {
1517       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1518     }
1519
1520   } elsif ( $encoding eq 'ldap' ) {
1521     if ($encryption eq 'md5') {
1522       $pass = md5_base64($pass);
1523     } elsif ($encryption eq 'sha1') {
1524       $pass = sha1_base64($pass);
1525     } elsif ($encryption eq 'crypt') {
1526       $pass = crypt($pass, $saltset[int(rand(64))].$saltset[int(rand(64))]);
1527     }
1528     # else $encryption eq 'plain', do nothing
1529     $pass .= '=' x (4 - length($pass) % 4) #properly padded base64
1530       if $encryption eq 'md5' || $encryption eq 'sha1';
1531     $pass = '{'.uc($encryption).'}'.$pass;
1532   }
1533   # else encoding eq 'plain'
1534
1535   $self->_password($pass);
1536   return;
1537 }
1538
1539 =item _check_system
1540
1541 Internal function to check the username against the list of system usernames
1542 from the I<system_usernames> configuration value.  Returns true if the username
1543 is listed on the system username list.
1544
1545 =cut
1546
1547 sub _check_system {
1548   my $self = shift;
1549   scalar( grep { $self->username eq $_ || $self->email eq $_ }
1550                $conf->config('system_usernames')
1551         );
1552 }
1553
1554 =item _check_duplicate
1555
1556 Internal method to check for duplicates usernames, username@domain pairs and
1557 uids.
1558
1559 If the I<global_unique-username> configuration value is set to B<username> or
1560 B<username@domain>, enforces global username or username@domain uniqueness.
1561
1562 In all cases, check for duplicate uids and usernames or username@domain pairs
1563 per export and with identical I<svcpart> values.
1564
1565 =cut
1566
1567 sub _check_duplicate {
1568   my $self = shift;
1569
1570   my $global_unique = $conf->config('global_unique-username') || 'none';
1571   return '' if $global_unique eq 'disabled';
1572
1573   $self->lock_table;
1574
1575   my $part_svc = qsearchs('part_svc', { 'svcpart' => $self->svcpart } );
1576   unless ( $part_svc ) {
1577     return 'unknown svcpart '. $self->svcpart;
1578   }
1579
1580   my @dup_user = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1581                  qsearch( 'svc_acct', { 'username' => $self->username } );
1582   return gettext('username_in_use')
1583     if $global_unique eq 'username' && @dup_user;
1584
1585   my @dup_userdomain = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1586                        qsearch( 'svc_acct', { 'username' => $self->username,
1587                                               'domsvc'   => $self->domsvc } );
1588   return gettext('username_in_use')
1589     if $global_unique eq 'username@domain' && @dup_userdomain;
1590
1591   my @dup_uid;
1592   if ( $part_svc->part_svc_column('uid')->columnflag ne 'F'
1593        && $self->username !~ /^(toor|(hyla)?fax)$/          ) {
1594     @dup_uid = grep { !$self->svcnum || $_->svcnum != $self->svcnum }
1595                qsearch( 'svc_acct', { 'uid' => $self->uid } );
1596   } else {
1597     @dup_uid = ();
1598   }
1599
1600   if ( @dup_user || @dup_userdomain || @dup_uid ) {
1601     my $exports = FS::part_export::export_info('svc_acct');
1602     my %conflict_user_svcpart;
1603     my %conflict_userdomain_svcpart = ( $self->svcpart => 'SELF', );
1604
1605     foreach my $part_export ( $part_svc->part_export ) {
1606
1607       #this will catch to the same exact export
1608       my @svcparts = map { $_->svcpart } $part_export->export_svc;
1609
1610       #this will catch to exports w/same exporthost+type ???
1611       #my @other_part_export = qsearch('part_export', {
1612       #  'machine'    => $part_export->machine,
1613       #  'exporttype' => $part_export->exporttype,
1614       #} );
1615       #foreach my $other_part_export ( @other_part_export ) {
1616       #  push @svcparts, map { $_->svcpart }
1617       #    qsearch('export_svc', { 'exportnum' => $part_export->exportnum });
1618       #}
1619
1620       #my $nodomain = $exports->{$part_export->exporttype}{'nodomain'};
1621       #silly kludge to avoid uninitialized value errors
1622       my $nodomain = exists( $exports->{$part_export->exporttype}{'nodomain'} )
1623                      ? $exports->{$part_export->exporttype}{'nodomain'}
1624                      : '';
1625       if ( $nodomain =~ /^Y/i ) {
1626         $conflict_user_svcpart{$_} = $part_export->exportnum
1627           foreach @svcparts;
1628       } else {
1629         $conflict_userdomain_svcpart{$_} = $part_export->exportnum
1630           foreach @svcparts;
1631       }
1632     }
1633
1634     foreach my $dup_user ( @dup_user ) {
1635       my $dup_svcpart = $dup_user->cust_svc->svcpart;
1636       if ( exists($conflict_user_svcpart{$dup_svcpart}) ) {
1637         return "duplicate username ". $self->username.
1638                ": conflicts with svcnum ". $dup_user->svcnum.
1639                " via exportnum ". $conflict_user_svcpart{$dup_svcpart};
1640       }
1641     }
1642
1643     foreach my $dup_userdomain ( @dup_userdomain ) {
1644       my $dup_svcpart = $dup_userdomain->cust_svc->svcpart;
1645       if ( exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1646         return "duplicate username\@domain ". $self->email.
1647                ": conflicts with svcnum ". $dup_userdomain->svcnum.
1648                " via exportnum ". $conflict_userdomain_svcpart{$dup_svcpart};
1649       }
1650     }
1651
1652     foreach my $dup_uid ( @dup_uid ) {
1653       my $dup_svcpart = $dup_uid->cust_svc->svcpart;
1654       if ( exists($conflict_user_svcpart{$dup_svcpart})
1655            || exists($conflict_userdomain_svcpart{$dup_svcpart}) ) {
1656         return "duplicate uid ". $self->uid.
1657                ": conflicts with svcnum ". $dup_uid->svcnum.
1658                " via exportnum ".
1659                ( $conflict_user_svcpart{$dup_svcpart}
1660                  || $conflict_userdomain_svcpart{$dup_svcpart} );
1661       }
1662     }
1663
1664   }
1665
1666   return '';
1667
1668 }
1669
1670 =item radius
1671
1672 Depriciated, use radius_reply instead.
1673
1674 =cut
1675
1676 sub radius {
1677   carp "FS::svc_acct::radius depriciated, use radius_reply";
1678   $_[0]->radius_reply;
1679 }
1680
1681 =item radius_reply
1682
1683 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1684 reply attributes of this record.
1685
1686 Note that this is now the preferred method for reading RADIUS attributes -
1687 accessing the columns directly is discouraged, as the column names are
1688 expected to change in the future.
1689
1690 =cut
1691
1692 sub radius_reply {
1693   my $self = shift;
1694
1695   return %{ $self->{'radius_reply'} }
1696     if exists $self->{'radius_reply'};
1697
1698   my %reply =
1699     map {
1700       /^(radius_(.*))$/;
1701       my($column, $attrib) = ($1, $2);
1702       #$attrib =~ s/_/\-/g;
1703       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1704     } grep { /^radius_/ && $self->getfield($_) } fields( $self->table );
1705
1706   if ( $self->slipip && $self->slipip ne '0e0' ) {
1707     $reply{$radius_ip} = $self->slipip;
1708   }
1709
1710   if ( $self->seconds !~ /^$/ ) {
1711     $reply{'Session-Timeout'} = $self->seconds;
1712   }
1713
1714   if ( $conf->exists('radius-chillispot-max') ) {
1715     #http://dev.coova.org/svn/coova-chilli/doc/dictionary.chillispot
1716
1717     #hmm.  just because sqlradius.pm says so?
1718     my %whatis = (
1719       'input'  => 'up',
1720       'output' => 'down',
1721       'total'  => 'total',
1722     );
1723
1724     foreach my $what (qw( input output total )) {
1725       my $is = $whatis{$what}.'bytes';
1726       if ( $self->$is() =~ /\d/ ) {
1727         my $big = new Math::BigInt $self->$is();
1728         $big = new Math::BigInt '0' if $big->is_neg();
1729         my $att = "Chillispot-Max-\u$what";
1730         $reply{"$att-Octets"}    = $big->copy->band(0xffffffff)->bstr;
1731         $reply{"$att-Gigawords"} = $big->copy->brsft(32)->bstr;
1732       }
1733     }
1734
1735   }
1736
1737   %reply;
1738 }
1739
1740 =item radius_check
1741
1742 Returns key/value pairs, suitable for assigning to a hash, for any RADIUS
1743 check attributes of this record.
1744
1745 Note that this is now the preferred method for reading RADIUS attributes -
1746 accessing the columns directly is discouraged, as the column names are
1747 expected to change in the future.
1748
1749 =cut
1750
1751 sub radius_check {
1752   my $self = shift;
1753
1754   return %{ $self->{'radius_check'} }
1755     if exists $self->{'radius_check'};
1756
1757   my %check =
1758     map {
1759       /^(rc_(.*))$/;
1760       my($column, $attrib) = ($1, $2);
1761       #$attrib =~ s/_/\-/g;
1762       ( $FS::raddb::attrib{lc($attrib)}, $self->getfield($column) );
1763     } grep { /^rc_/ && $self->getfield($_) } fields( $self->table );
1764
1765
1766   my($pw_attrib, $password) = $self->radius_password;
1767   $check{$pw_attrib} = $password;
1768
1769   my $cust_svc = $self->cust_svc;
1770   if ( $cust_svc ) {
1771     my $cust_pkg = $cust_svc->cust_pkg;
1772     if ( $cust_pkg && $cust_pkg->part_pkg->is_prepaid && $cust_pkg->bill ) {
1773       $check{'Expiration'} = time2str('%B %e %Y %T', $cust_pkg->bill ); #http://lists.cistron.nl/pipermail/freeradius-users/2005-January/040184.html
1774     }
1775   } else {
1776     warn "WARNING: no cust_svc record for svc_acct.svcnum ". $self->svcnum.
1777          "; can't set Expiration\n"
1778       unless $cust_svc;
1779   }
1780
1781   %check;
1782
1783 }
1784
1785 =item radius_password
1786
1787 Returns a key/value pair containing the RADIUS attribute name and value
1788 for the password.
1789
1790 =cut
1791
1792 sub radius_password {
1793   my $self = shift;
1794
1795   my $pw_attrib;
1796   if ( $self->_password_encoding eq 'ldap' ) {
1797     $pw_attrib = 'Password-With-Header';
1798   } elsif ( $self->_password_encoding eq 'crypt' ) {
1799     $pw_attrib = 'Crypt-Password';
1800   } elsif ( $self->_password_encoding eq 'plain' ) {
1801     $pw_attrib = $radius_password;
1802   } else {
1803     $pw_attrib = length($self->_password) <= 12
1804                    ? $radius_password
1805                    : 'Crypt-Password';
1806   }
1807
1808   ($pw_attrib, $self->_password);
1809
1810 }
1811
1812 =item snapshot
1813
1814 This method instructs the object to "snapshot" or freeze RADIUS check and
1815 reply attributes to the current values.
1816
1817 =cut
1818
1819 #bah, my english is too broken this morning
1820 #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
1821 #the FS::cust_pkg's replace method to trigger the correct export updates when
1822 #package dates change)
1823
1824 sub snapshot {
1825   my $self = shift;
1826
1827   $self->{$_} = { $self->$_() }
1828     foreach qw( radius_reply radius_check );
1829
1830 }
1831
1832 =item forget_snapshot
1833
1834 This methos instructs the object to forget any previously snapshotted
1835 RADIUS check and reply attributes.
1836
1837 =cut
1838
1839 sub forget_snapshot {
1840   my $self = shift;
1841
1842   delete $self->{$_}
1843     foreach qw( radius_reply radius_check );
1844
1845 }
1846
1847 =item domain [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1848
1849 Returns the domain associated with this account.
1850
1851 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1852 history records.
1853
1854 =cut
1855
1856 sub domain {
1857   my $self = shift;
1858   die "svc_acct.domsvc is null for svcnum ". $self->svcnum unless $self->domsvc;
1859   my $svc_domain = $self->svc_domain(@_)
1860     or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc;
1861   $svc_domain->domain;
1862 }
1863
1864 =item cust_svc
1865
1866 Returns the FS::cust_svc record for this account (see L<FS::cust_svc>).
1867
1868 =cut
1869
1870 #inherited from svc_Common
1871
1872 =item email [ END_TIMESTAMP [ START_TIMESTAMP ] ]
1873
1874 Returns an email address associated with the account.
1875
1876 END_TIMESTAMP and START_TIMESTAMP can optionally be passed when dealing with
1877 history records.
1878
1879 =cut
1880
1881 sub email {
1882   my $self = shift;
1883   $self->username. '@'. $self->domain(@_);
1884 }
1885
1886
1887 =item acct_snarf
1888
1889 Returns an array of FS::acct_snarf records associated with the account.
1890
1891 =cut
1892
1893 # unused as originally intended, but now by Communigate Pro "RPOP"
1894 sub acct_snarf {
1895   my $self = shift;
1896   qsearch({
1897     'table'    => 'acct_snarf',
1898     'hashref'  => { 'svcnum' => $self->svcnum },
1899     #'order_by' => 'ORDER BY priority ASC',
1900   });
1901 }
1902
1903 =item cgp_rpop_hashref
1904
1905 Returns an arrayref of RPOP data suitable for Communigate Pro API commands.
1906
1907 =cut
1908
1909 sub cgp_rpop_hashref {
1910   my $self = shift;
1911   { map { $_->snarfname => $_->cgp_hashref } $self->acct_snarf };
1912 }
1913
1914 =item decrement_upbytes OCTETS
1915
1916 Decrements the I<upbytes> field of this record by the given amount.  If there
1917 is an error, returns the error, otherwise returns false.
1918
1919 =cut
1920
1921 sub decrement_upbytes {
1922   shift->_op_usage('-', 'upbytes', @_);
1923 }
1924
1925 =item increment_upbytes OCTETS
1926
1927 Increments the I<upbytes> field of this record by the given amount.  If there
1928 is an error, returns the error, otherwise returns false.
1929
1930 =cut
1931
1932 sub increment_upbytes {
1933   shift->_op_usage('+', 'upbytes', @_);
1934 }
1935
1936 =item decrement_downbytes OCTETS
1937
1938 Decrements the I<downbytes> field of this record by the given amount.  If there
1939 is an error, returns the error, otherwise returns false.
1940
1941 =cut
1942
1943 sub decrement_downbytes {
1944   shift->_op_usage('-', 'downbytes', @_);
1945 }
1946
1947 =item increment_downbytes OCTETS
1948
1949 Increments the I<downbytes> field of this record by the given amount.  If there
1950 is an error, returns the error, otherwise returns false.
1951
1952 =cut
1953
1954 sub increment_downbytes {
1955   shift->_op_usage('+', 'downbytes', @_);
1956 }
1957
1958 =item decrement_totalbytes OCTETS
1959
1960 Decrements the I<totalbytes> field of this record by the given amount.  If there
1961 is an error, returns the error, otherwise returns false.
1962
1963 =cut
1964
1965 sub decrement_totalbytes {
1966   shift->_op_usage('-', 'totalbytes', @_);
1967 }
1968
1969 =item increment_totalbytes OCTETS
1970
1971 Increments the I<totalbytes> field of this record by the given amount.  If there
1972 is an error, returns the error, otherwise returns false.
1973
1974 =cut
1975
1976 sub increment_totalbytes {
1977   shift->_op_usage('+', 'totalbytes', @_);
1978 }
1979
1980 =item decrement_seconds SECONDS
1981
1982 Decrements the I<seconds> field of this record by the given amount.  If there
1983 is an error, returns the error, otherwise returns false.
1984
1985 =cut
1986
1987 sub decrement_seconds {
1988   shift->_op_usage('-', 'seconds', @_);
1989 }
1990
1991 =item increment_seconds SECONDS
1992
1993 Increments the I<seconds> field of this record by the given amount.  If there
1994 is an error, returns the error, otherwise returns false.
1995
1996 =cut
1997
1998 sub increment_seconds {
1999   shift->_op_usage('+', 'seconds', @_);
2000 }
2001
2002
2003 my %op2action = (
2004   '-' => 'suspend',
2005   '+' => 'unsuspend',
2006 );
2007 my %op2condition = (
2008   '-' => sub { my($self, $column, $amount) = @_;
2009                $self->$column - $amount <= 0;
2010              },
2011   '+' => sub { my($self, $column, $amount) = @_;
2012                ($self->$column || 0) + $amount > 0;
2013              },
2014 );
2015 my %op2warncondition = (
2016   '-' => sub { my($self, $column, $amount) = @_;
2017                my $threshold = $column . '_threshold';
2018                $self->$column - $amount <= $self->$threshold + 0;
2019              },
2020   '+' => sub { my($self, $column, $amount) = @_;
2021                ($self->$column || 0) + $amount > 0;
2022              },
2023 );
2024
2025 sub _op_usage {
2026   my( $self, $op, $column, $amount ) = @_;
2027
2028   warn "$me _op_usage called for $column on svcnum ". $self->svcnum.
2029        ' ('. $self->email. "): $op $amount\n"
2030     if $DEBUG;
2031
2032   return '' unless $amount;
2033
2034   local $SIG{HUP} = 'IGNORE';
2035   local $SIG{INT} = 'IGNORE';
2036   local $SIG{QUIT} = 'IGNORE';
2037   local $SIG{TERM} = 'IGNORE';
2038   local $SIG{TSTP} = 'IGNORE';
2039   local $SIG{PIPE} = 'IGNORE';
2040
2041   my $oldAutoCommit = $FS::UID::AutoCommit;
2042   local $FS::UID::AutoCommit = 0;
2043   my $dbh = dbh;
2044
2045   my $sql = "UPDATE svc_acct SET $column = ".
2046             " CASE WHEN $column IS NULL THEN 0 ELSE $column END ". #$column||0
2047             " $op ? WHERE svcnum = ?";
2048   warn "$me $sql\n"
2049     if $DEBUG;
2050
2051   my $sth = $dbh->prepare( $sql )
2052     or die "Error preparing $sql: ". $dbh->errstr;
2053   my $rv = $sth->execute($amount, $self->svcnum);
2054   die "Error executing $sql: ". $sth->errstr
2055     unless defined($rv);
2056   die "Can't update $column for svcnum". $self->svcnum
2057     if $rv == 0;
2058
2059   #$self->snapshot; #not necessary, we retain the old values
2060   #create an object with the updated usage values
2061   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2062   #call exports
2063   my $error = $new->replace($self);
2064   if ( $error ) {
2065     $dbh->rollback if $oldAutoCommit;
2066     return "Error replacing: $error";
2067   }
2068
2069   #overlimit_action eq 'cancel' handling
2070   my $cust_pkg = $self->cust_svc->cust_pkg;
2071   if ( $cust_pkg
2072        && $cust_pkg->part_pkg->option('overlimit_action', 1) eq 'cancel'
2073        && $op eq '-' && &{$op2condition{$op}}($self, $column, $amount)
2074      )
2075   {
2076
2077     my $error = $cust_pkg->cancel; #XXX should have a reason
2078     if ( $error ) {
2079       $dbh->rollback if $oldAutoCommit;
2080       return "Error cancelling: $error";
2081     }
2082
2083     #nothing else is relevant if we're cancelling, so commit & return success
2084     warn "$me update successful; committing\n"
2085       if $DEBUG;
2086     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2087     return '';
2088
2089   }
2090
2091   my $action = $op2action{$op};
2092
2093   if ( &{$op2condition{$op}}($self, $column, $amount) &&
2094         ( $action eq 'suspend'   && !$self->overlimit
2095        || $action eq 'unsuspend' &&  $self->overlimit )
2096      ) {
2097
2098     my $error = $self->_op_overlimit($action);
2099     if ( $error ) {
2100       $dbh->rollback if $oldAutoCommit;
2101       return $error;
2102     }
2103
2104   }
2105
2106   if ( $conf->exists("svc_acct-usage_$action")
2107        && &{$op2condition{$op}}($self, $column, $amount)    ) {
2108     #my $error = $self->$action();
2109     my $error = $self->cust_svc->cust_pkg->$action();
2110     # $error ||= $self->overlimit($action);
2111     if ( $error ) {
2112       $dbh->rollback if $oldAutoCommit;
2113       return "Error ${action}ing: $error";
2114     }
2115   }
2116
2117   if ($warning_template && &{$op2warncondition{$op}}($self, $column, $amount)) {
2118     my $wqueue = new FS::queue {
2119       'svcnum' => $self->svcnum,
2120       'job'    => 'FS::svc_acct::reached_threshold',
2121     };
2122
2123     my $to = '';
2124     if ($op eq '-'){
2125       $to = $warning_cc if &{$op2condition{$op}}($self, $column, $amount);
2126     }
2127
2128     # x_threshold race
2129     my $error = $wqueue->insert(
2130       'svcnum' => $self->svcnum,
2131       'op'     => $op,
2132       'column' => $column,
2133       'to'     => $to,
2134     );
2135     if ( $error ) {
2136       $dbh->rollback if $oldAutoCommit;
2137       return "Error queuing threshold activity: $error";
2138     }
2139   }
2140
2141   warn "$me update successful; committing\n"
2142     if $DEBUG;
2143   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2144   '';
2145
2146 }
2147
2148 sub _op_overlimit {
2149   my( $self, $action ) = @_;
2150
2151   local $SIG{HUP} = 'IGNORE';
2152   local $SIG{INT} = 'IGNORE';
2153   local $SIG{QUIT} = 'IGNORE';
2154   local $SIG{TERM} = 'IGNORE';
2155   local $SIG{TSTP} = 'IGNORE';
2156   local $SIG{PIPE} = 'IGNORE';
2157
2158   my $oldAutoCommit = $FS::UID::AutoCommit;
2159   local $FS::UID::AutoCommit = 0;
2160   my $dbh = dbh;
2161
2162   my $cust_pkg = $self->cust_svc->cust_pkg;
2163
2164   my @conf_overlimit =
2165     $cust_pkg
2166       ? $conf->config('overlimit_groups', $cust_pkg->cust_main->agentnum )
2167       : $conf->config('overlimit_groups');
2168
2169   foreach my $part_export ( $self->cust_svc->part_svc->part_export ) {
2170
2171     my @groups = scalar(@conf_overlimit) ? @conf_overlimit
2172                                          : split(' ',$part_export->option('overlimit_groups'));
2173     next unless scalar(@groups);
2174
2175     my $other = new FS::svc_acct $self->hashref;
2176     $other->usergroup(\@groups);
2177
2178     my($new,$old);
2179     if ($action eq 'suspend') {
2180       $new = $other;
2181       $old = $self;
2182     } else { # $action eq 'unsuspend'
2183       $new = $self;
2184       $old = $other;
2185     }
2186
2187     my $error = $part_export->export_replace($new, $old)
2188                 || $self->overlimit($action);
2189
2190     if ( $error ) {
2191       $dbh->rollback if $oldAutoCommit;
2192       return "Error replacing radius groups: $error";
2193     }
2194
2195   }
2196
2197   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2198   '';
2199
2200 }
2201
2202 sub set_usage {
2203   my( $self, $valueref, %options ) = @_;
2204
2205   warn "$me set_usage called for svcnum ". $self->svcnum.
2206        ' ('. $self->email. "): ".
2207        join(', ', map { "$_ => " . $valueref->{$_}} keys %$valueref) . "\n"
2208     if $DEBUG;
2209
2210   local $SIG{HUP} = 'IGNORE';
2211   local $SIG{INT} = 'IGNORE';
2212   local $SIG{QUIT} = 'IGNORE';
2213   local $SIG{TERM} = 'IGNORE';
2214   local $SIG{TSTP} = 'IGNORE';
2215   local $SIG{PIPE} = 'IGNORE';
2216
2217   local $FS::svc_Common::noexport_hack = 1;
2218   my $oldAutoCommit = $FS::UID::AutoCommit;
2219   local $FS::UID::AutoCommit = 0;
2220   my $dbh = dbh;
2221
2222   my $reset = 0;
2223   my %handyhash = ();
2224   if ( $options{null} ) {
2225     %handyhash = ( map { ( $_ => undef, $_."_threshold" => undef ) }
2226                    qw( seconds upbytes downbytes totalbytes )
2227                  );
2228   }
2229   foreach my $field (keys %$valueref){
2230     $reset = 1 if $valueref->{$field};
2231     $self->setfield($field, $valueref->{$field});
2232     $self->setfield( $field.'_threshold',
2233                      int($self->getfield($field)
2234                          * ( $conf->exists('svc_acct-usage_threshold')
2235                              ? 1 - $conf->config('svc_acct-usage_threshold')/100
2236                              : 0.20
2237                            )
2238                        )
2239                      );
2240     $handyhash{$field} = $self->getfield($field);
2241     $handyhash{$field.'_threshold'} = $self->getfield($field.'_threshold');
2242   }
2243   #my $error = $self->replace;   #NO! we avoid the call to ->check for
2244   #die $error if $error;         #services not explicity changed via the UI
2245
2246   my $sql = "UPDATE svc_acct SET " .
2247     join (',', map { "$_ =  ?" } (keys %handyhash) ).
2248     " WHERE svcnum = ". $self->svcnum;
2249
2250   warn "$me $sql\n"
2251     if $DEBUG;
2252
2253   if (scalar(keys %handyhash)) {
2254     my $sth = $dbh->prepare( $sql )
2255       or die "Error preparing $sql: ". $dbh->errstr;
2256     my $rv = $sth->execute(values %handyhash);
2257     die "Error executing $sql: ". $sth->errstr
2258       unless defined($rv);
2259     die "Can't update usage for svcnum ". $self->svcnum
2260       if $rv == 0;
2261   }
2262
2263   #$self->snapshot; #not necessary, we retain the old values
2264   #create an object with the updated usage values
2265   my $new = qsearchs('svc_acct', { 'svcnum' => $self->svcnum });
2266   local($FS::Record::nowarn_identical) = 1;
2267   my $error = $new->replace($self); #call exports
2268   if ( $error ) {
2269     $dbh->rollback if $oldAutoCommit;
2270     return "Error replacing: $error";
2271   }
2272
2273   if ( $reset ) {
2274
2275     my $error = '';
2276
2277     $error = $self->_op_overlimit('unsuspend')
2278       if $self->overlimit;;
2279
2280     $error ||= $self->cust_svc->cust_pkg->unsuspend
2281       if $conf->exists("svc_acct-usage_unsuspend");
2282
2283     if ( $error ) {
2284       $dbh->rollback if $oldAutoCommit;
2285       return "Error unsuspending: $error";
2286     }
2287
2288   }
2289
2290   warn "$me update successful; committing\n"
2291     if $DEBUG;
2292   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2293   '';
2294
2295 }
2296
2297
2298 =item recharge HASHREF
2299
2300   Increments usage columns by the amount specified in HASHREF as
2301   column=>amount pairs.
2302
2303 =cut
2304
2305 sub recharge {
2306   my ($self, $vhash) = @_;
2307
2308   if ( $DEBUG ) {
2309     warn "[$me] recharge called on $self: ". Dumper($self).
2310          "\nwith vhash: ". Dumper($vhash);
2311   }
2312
2313   my $oldAutoCommit = $FS::UID::AutoCommit;
2314   local $FS::UID::AutoCommit = 0;
2315   my $dbh = dbh;
2316   my $error = '';
2317
2318   foreach my $column (keys %$vhash){
2319     $error ||= $self->_op_usage('+', $column, $vhash->{$column});
2320   }
2321
2322   if ( $error ) {
2323     $dbh->rollback if $oldAutoCommit;
2324   }else{
2325     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2326   }
2327   return $error;
2328 }
2329
2330 =item is_rechargeable
2331
2332 Returns true if this svc_account can be "recharged" and false otherwise.
2333
2334 =cut
2335
2336 sub is_rechargable {
2337   my $self = shift;
2338   $self->seconds ne ''
2339     || $self->upbytes ne ''
2340     || $self->downbytes ne ''
2341     || $self->totalbytes ne '';
2342 }
2343
2344 =item seconds_since TIMESTAMP
2345
2346 Returns the number of seconds this account has been online since TIMESTAMP,
2347 according to the session monitor (see L<FS::Session>).
2348
2349 TIMESTAMP is specified as a UNIX timestamp; see L<perlfunc/"time">.  Also see
2350 L<Time::Local> and L<Date::Parse> for conversion functions.
2351
2352 =cut
2353
2354 #note: POD here, implementation in FS::cust_svc
2355 sub seconds_since {
2356   my $self = shift;
2357   $self->cust_svc->seconds_since(@_);
2358 }
2359
2360 =item seconds_since_sqlradacct TIMESTAMP_START TIMESTAMP_END
2361
2362 Returns the numbers of seconds this account has been online between
2363 TIMESTAMP_START (inclusive) and TIMESTAMP_END (exclusive), according to an
2364 external SQL radacct table, specified via sqlradius export.  Sessions which
2365 started in the specified range but are still open are counted from session
2366 start to the end of the range (unless they are over 1 day old, in which case
2367 they are presumed missing their stop record and not counted).  Also, sessions
2368 which end in the range but started earlier are counted from the start of the
2369 range to session end.  Finally, sessions which start before the range but end
2370 after are counted for the entire range.
2371
2372 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2373 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2374 functions.
2375
2376 =cut
2377
2378 #note: POD here, implementation in FS::cust_svc
2379 sub seconds_since_sqlradacct {
2380   my $self = shift;
2381   $self->cust_svc->seconds_since_sqlradacct(@_);
2382 }
2383
2384 =item attribute_since_sqlradacct TIMESTAMP_START TIMESTAMP_END ATTRIBUTE
2385
2386 Returns the sum of the given attribute for all accounts (see L<FS::svc_acct>)
2387 in this package for sessions ending between TIMESTAMP_START (inclusive) and
2388 TIMESTAMP_END (exclusive).
2389
2390 TIMESTAMP_START and TIMESTAMP_END are specified as UNIX timestamps; see
2391 L<perlfunc/"time">.  Also see L<Time::Local> and L<Date::Parse> for conversion
2392 functions.
2393
2394 =cut
2395
2396 #note: POD here, implementation in FS::cust_svc
2397 sub attribute_since_sqlradacct {
2398   my $self = shift;
2399   $self->cust_svc->attribute_since_sqlradacct(@_);
2400 }
2401
2402 =item get_session_history TIMESTAMP_START TIMESTAMP_END
2403
2404 Returns an array of hash references of this customers login history for the
2405 given time range.  (document this better)
2406
2407 =cut
2408
2409 sub get_session_history {
2410   my $self = shift;
2411   $self->cust_svc->get_session_history(@_);
2412 }
2413
2414 =item last_login_text
2415
2416 Returns text describing the time of last login.
2417
2418 =cut
2419
2420 sub last_login_text {
2421   my $self = shift;
2422   $self->last_login ? ctime($self->last_login) : 'unknown';
2423 }
2424
2425 =item get_cdrs TIMESTAMP_START TIMESTAMP_END [ 'OPTION' => 'VALUE ... ]
2426
2427 =cut
2428
2429 sub get_cdrs {
2430   my($self, $start, $end, %opt ) = @_;
2431
2432   my $did = $self->username; #yup
2433
2434   my $prefix = $opt{'default_prefix'}; #convergent.au '+61'
2435
2436   my $for_update = $opt{'for_update'} ? 'FOR UPDATE' : '';
2437
2438   #SELECT $for_update * FROM cdr
2439   #  WHERE calldate >= $start #need a conversion
2440   #    AND calldate <  $end   #ditto
2441   #    AND (    charged_party = "$did"
2442   #          OR charged_party = "$prefix$did" #if length($prefix);
2443   #          OR ( ( charged_party IS NULL OR charged_party = '' )
2444   #               AND
2445   #               ( src = "$did" OR src = "$prefix$did" ) # if length($prefix)
2446   #             )
2447   #        )
2448   #    AND ( freesidestatus IS NULL OR freesidestatus = '' )
2449
2450   my $charged_or_src;
2451   if ( length($prefix) ) {
2452     $charged_or_src =
2453       " AND (    charged_party = '$did'
2454               OR charged_party = '$prefix$did'
2455               OR ( ( charged_party IS NULL OR charged_party = '' )
2456                    AND
2457                    ( src = '$did' OR src = '$prefix$did' )
2458                  )
2459             )
2460       ";
2461   } else {
2462     $charged_or_src =
2463       " AND (    charged_party = '$did'
2464               OR ( ( charged_party IS NULL OR charged_party = '' )
2465                    AND
2466                    src = '$did'
2467                  )
2468             )
2469       ";
2470
2471   }
2472
2473   qsearch(
2474     'select'    => "$for_update *",
2475     'table'     => 'cdr',
2476     'hashref'   => {
2477                      #( freesidestatus IS NULL OR freesidestatus = '' )
2478                      'freesidestatus' => '',
2479                    },
2480     'extra_sql' => $charged_or_src,
2481
2482   );
2483
2484 }
2485
2486 # sub radius_groups has moved to svc_Radius_Mixin
2487
2488 =item clone_suspended
2489
2490 Constructor used by FS::part_export::_export_suspend fallback.  Document
2491 better.
2492
2493 =cut
2494
2495 sub clone_suspended {
2496   my $self = shift;
2497   my %hash = $self->hash;
2498   $hash{_password} = join('',map($pw_set[ int(rand $#pw_set) ], (0..7) ) );
2499   new FS::svc_acct \%hash;
2500 }
2501
2502 =item clone_kludge_unsuspend
2503
2504 Constructor used by FS::part_export::_export_unsuspend fallback.  Document
2505 better.
2506
2507 =cut
2508
2509 sub clone_kludge_unsuspend {
2510   my $self = shift;
2511   my %hash = $self->hash;
2512   $hash{_password} = '';
2513   new FS::svc_acct \%hash;
2514 }
2515
2516 =item check_password
2517
2518 Checks the supplied password against the (possibly encrypted) password in the
2519 database.  Returns true for a successful authentication, false for no match.
2520
2521 Currently supported encryptions are: classic DES crypt() and MD5
2522
2523 =cut
2524
2525 sub check_password {
2526   my($self, $check_password) = @_;
2527
2528   #remove old-style SUSPENDED kludge, they should be allowed to login to
2529   #self-service and pay up
2530   ( my $password = $self->_password ) =~ s/^\*SUSPENDED\* //;
2531
2532   if ( $self->_password_encoding eq 'ldap' ) {
2533
2534     $password =~ s/^{PLAIN}/{CLEARTEXT}/;
2535     my $auth = from_rfc2307 Authen::Passphrase $password;
2536     return $auth->match($check_password);
2537
2538   } elsif ( $self->_password_encoding eq 'crypt' ) {
2539
2540     my $auth = from_crypt Authen::Passphrase $self->_password;
2541     return $auth->match($check_password);
2542
2543   } elsif ( $self->_password_encoding eq 'plain' ) {
2544
2545     return $check_password eq $password;
2546
2547   } else {
2548
2549     #XXX this could be replaced with Authen::Passphrase stuff
2550
2551     if ( $password =~ /^(\*|!!?)$/ ) { #no self-service login
2552       return 0;
2553     } elsif ( length($password) < 13 ) { #plaintext
2554       $check_password eq $password;
2555     } elsif ( length($password) == 13 ) { #traditional DES crypt
2556       crypt($check_password, $password) eq $password;
2557     } elsif ( $password =~ /^\$1\$/ ) { #MD5 crypt
2558       unix_md5_crypt($check_password, $password) eq $password;
2559     } elsif ( $password =~ /^\$2a?\$/ ) { #Blowfish
2560       warn "Can't check password: Blowfish encryption not yet supported, ".
2561            "svcnum ".  $self->svcnum. "\n";
2562       0;
2563     } else {
2564       warn "Can't check password: Unrecognized encryption for svcnum ".
2565            $self->svcnum. "\n";
2566       0;
2567     }
2568
2569   }
2570
2571 }
2572
2573 =item crypt_password [ DEFAULT_ENCRYPTION_TYPE ]
2574
2575 Returns an encrypted password, either by passing through an encrypted password
2576 in the database or by encrypting a plaintext password from the database.
2577
2578 The optional DEFAULT_ENCRYPTION_TYPE parameter can be set to I<crypt> (classic
2579 UNIX DES crypt), I<md5> (md5 crypt supported by most modern Linux and BSD
2580 distrubtions), or (eventually) I<blowfish> (blowfish hashing supported by
2581 OpenBSD, SuSE, other Linux distibutions with pam_unix2, etc.).  The default
2582 encryption type is only used if the password is not already encrypted in the
2583 database.
2584
2585 =cut
2586
2587 sub crypt_password {
2588   my $self = shift;
2589
2590   if ( $self->_password_encoding eq 'ldap' ) {
2591
2592     if ( $self->_password =~ /^\{(PLAIN|CLEARTEXT)\}(.+)$/ ) {
2593       my $plain = $2;
2594
2595       #XXX this could be replaced with Authen::Passphrase stuff
2596
2597       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2598       if ( $encryption eq 'crypt' ) {
2599         return crypt(
2600           $self->_password,
2601           $saltset[int(rand(64))].$saltset[int(rand(64))]
2602         );
2603       } elsif ( $encryption eq 'md5' ) {
2604         return unix_md5_crypt( $self->_password );
2605       } elsif ( $encryption eq 'blowfish' ) {
2606         croak "unknown encryption method $encryption";
2607       } else {
2608         croak "unknown encryption method $encryption";
2609       }
2610
2611     } elsif ( $self->_password =~ /^\{CRYPT\}(.+)$/ ) {
2612       return $1;
2613     }
2614
2615   } elsif ( $self->_password_encoding eq 'crypt' ) {
2616
2617     return $self->_password;
2618
2619   } elsif ( $self->_password_encoding eq 'plain' ) {
2620
2621     #XXX this could be replaced with Authen::Passphrase stuff
2622
2623     my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2624     if ( $encryption eq 'crypt' ) {
2625       return crypt(
2626         $self->_password,
2627         $saltset[int(rand(64))].$saltset[int(rand(64))]
2628       );
2629     } elsif ( $encryption eq 'md5' ) {
2630       return unix_md5_crypt( $self->_password );
2631     } elsif ( $encryption eq 'sha1_base64' ) { #for acct_sql
2632       my $pass = sha1_base64( $self->_password );
2633       $pass .= '=' x (4 - length($pass) % 4); #properly padded base64
2634       return $pass;
2635     } elsif ( $encryption eq 'blowfish' ) {
2636       croak "unknown encryption method $encryption";
2637     } else {
2638       croak "unknown encryption method $encryption";
2639     }
2640
2641   } else {
2642
2643     if ( length($self->_password) == 13
2644          || $self->_password =~ /^\$(1|2a?)\$/
2645          || $self->_password =~ /^(\*|NP|\*LK\*|!!?)$/
2646        )
2647     {
2648       $self->_password;
2649     } else {
2650
2651       #XXX this could be replaced with Authen::Passphrase stuff
2652
2653       my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2654       if ( $encryption eq 'crypt' ) {
2655         return crypt(
2656           $self->_password,
2657           $saltset[int(rand(64))].$saltset[int(rand(64))]
2658         );
2659       } elsif ( $encryption eq 'md5' ) {
2660         return unix_md5_crypt( $self->_password );
2661       } elsif ( $encryption eq 'blowfish' ) {
2662         croak "unknown encryption method $encryption";
2663       } else {
2664         croak "unknown encryption method $encryption";
2665       }
2666
2667     }
2668
2669   }
2670
2671 }
2672
2673 =item ldap_password [ DEFAULT_ENCRYPTION_TYPE ]
2674
2675 Returns an encrypted password in "LDAP" format, with a curly-bracked prefix
2676 describing the format, for example, "{PLAIN}himom", "{CRYPT}94pAVyK/4oIBk" or
2677 "{MD5}5426824942db4253f87a1009fd5d2d4".
2678
2679 The optional DEFAULT_ENCRYPTION_TYPE is not yet used, but the idea is for it
2680 to work the same as the B</crypt_password> method.
2681
2682 =cut
2683
2684 sub ldap_password {
2685   my $self = shift;
2686   #eventually should check a "password-encoding" field
2687
2688   if ( $self->_password_encoding eq 'ldap' ) {
2689
2690     return $self->_password;
2691
2692   } elsif ( $self->_password_encoding eq 'crypt' ) {
2693
2694     if ( length($self->_password) == 13 ) { #crypt
2695       return '{CRYPT}'. $self->_password;
2696     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2697       return '{MD5}'. $1;
2698     #} elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2699     #  die "Blowfish encryption not supported in this context, svcnum ".
2700     #      $self->svcnum. "\n";
2701     } else {
2702       warn "encryption method not (yet?) supported in LDAP context";
2703       return '{CRYPT}*'; #unsupported, should not auth
2704     }
2705
2706   } elsif ( $self->_password_encoding eq 'plain' ) {
2707
2708     return '{PLAIN}'. $self->_password;
2709
2710     #return '{CLEARTEXT}'. $self->_password; #?
2711
2712   } else {
2713
2714     if ( length($self->_password) == 13 ) { #crypt
2715       return '{CRYPT}'. $self->_password;
2716     } elsif ( $self->_password =~ /^\$1\$(.*)$/ && length($1) == 31 ) { #passwdMD5
2717       return '{MD5}'. $1;
2718     } elsif ( $self->_password =~ /^\$2a?\$(.*)$/ ) { #Blowfish
2719       warn "Blowfish encryption not supported in this context, svcnum ".
2720           $self->svcnum. "\n";
2721       return '{CRYPT}*';
2722
2723     #are these two necessary anymore?
2724     } elsif ( $self->_password =~ /^(\w{48})$/ ) { #LDAP SSHA
2725       return '{SSHA}'. $1;
2726     } elsif ( $self->_password =~ /^(\w{64})$/ ) { #LDAP NS-MTA-MD5
2727       return '{NS-MTA-MD5}'. $1;
2728
2729     } else { #plaintext
2730       return '{PLAIN}'. $self->_password;
2731
2732       #return '{CLEARTEXT}'. $self->_password; #?
2733
2734       #XXX this could be replaced with Authen::Passphrase stuff if it gets used
2735       #my $encryption = ( scalar(@_) && $_[0] ) ? shift : 'crypt';
2736       #if ( $encryption eq 'crypt' ) {
2737       #  return '{CRYPT}'. crypt(
2738       #    $self->_password,
2739       #    $saltset[int(rand(64))].$saltset[int(rand(64))]
2740       #  );
2741       #} elsif ( $encryption eq 'md5' ) {
2742       #  unix_md5_crypt( $self->_password );
2743       #} elsif ( $encryption eq 'blowfish' ) {
2744       #  croak "unknown encryption method $encryption";
2745       #} else {
2746       #  croak "unknown encryption method $encryption";
2747       #}
2748     }
2749
2750   }
2751
2752 }
2753
2754 =item domain_slash_username
2755
2756 Returns $domain/$username/
2757
2758 =cut
2759
2760 sub domain_slash_username {
2761   my $self = shift;
2762   $self->domain. '/'. $self->username. '/';
2763 }
2764
2765 =item virtual_maildir
2766
2767 Returns $domain/maildirs/$username/
2768
2769 =cut
2770
2771 sub virtual_maildir {
2772   my $self = shift;
2773   $self->domain. '/maildirs/'. $self->username. '/';
2774 }
2775
2776 =back
2777
2778 =head1 CLASS METHODS
2779
2780 =over 4
2781
2782 =item search HASHREF
2783
2784 Class method which returns a qsearch hash expression to search for parameters
2785 specified in HASHREF.  Valid parameters are
2786
2787 =over 4
2788
2789 =item domain
2790
2791 =item domsvc
2792
2793 =item unlinked
2794
2795 =item agentnum
2796
2797 =item pkgpart
2798
2799 Arrayref of pkgparts
2800
2801 =item pkgpart
2802
2803 =item where
2804
2805 Arrayref of additional WHERE clauses, will be ANDed together.
2806
2807 =item order_by
2808
2809 =item cust_fields
2810
2811 =back
2812
2813 =cut
2814
2815 sub search {
2816   my ($class, $params) = @_;
2817
2818   my @from = (
2819     ' LEFT JOIN cust_svc  USING ( svcnum  ) ',
2820     ' LEFT JOIN part_svc  USING ( svcpart ) ',
2821     ' LEFT JOIN cust_pkg  USING ( pkgnum  ) ',
2822     ' LEFT JOIN cust_main USING ( custnum ) ',
2823   );
2824
2825   my @where = ();
2826
2827   # domain
2828   if ( $params->{'domain'} ) {
2829     my $svc_domain = qsearchs('svc_domain', { 'domain'=>$params->{'domain'} } );
2830     #preserve previous behavior & bubble up an error if $svc_domain not found?
2831     push @where, 'domsvc = '. $svc_domain->svcnum if $svc_domain;
2832   }
2833
2834   # domsvc
2835   if ( $params->{'domsvc'} =~ /^(\d+)$/ ) {
2836     push @where, "domsvc = $1";
2837   }
2838
2839   #unlinked
2840   push @where, 'pkgnum IS NULL' if $params->{'unlinked'};
2841
2842   #agentnum
2843   if ( $params->{'agentnum'} =~ /^(\d+)$/ and $1 ) {
2844     push @where, "cust_main.agentnum = $1";
2845   }
2846
2847   #custnum
2848   if ( $params->{'custnum'} =~ /^(\d+)$/ and $1 ) {
2849     push @where, "custnum = $1";
2850   }
2851
2852   #customer status
2853   if ( $params->{'cust_status'} =~ /^([a-z]+)$/ ) {
2854     push @where, FS::cust_main->cust_status_sql . " = '$1'";
2855   }
2856
2857   #customer balance
2858   if ( $params->{'balance'} =~ /^\s*(\-?\d*(\.\d{1,2})?)\s*$/ && length($1) ) {
2859     my $balance = $1;
2860
2861     my $age = '';
2862     if ( $params->{'balance_days'} =~ /^\s*(\d*(\.\d{1,3})?)\s*$/ && length($1) ) {
2863       $age = time - 86400 * $1;
2864     }
2865     push @where, FS::cust_main->balance_date_sql($age) . " > $balance";
2866   }
2867
2868   #payby
2869   if ( $params->{'payby'} && scalar(@{ $params->{'payby'} }) ) {
2870     my @payby = map "'$_'", grep /^(\w+)$/, @{ $params->{'payby'} };
2871     push @where, 'payby IN ('. join(',', @payby ). ')';
2872   }
2873
2874   #pkgpart
2875   if ( $params->{'pkgpart'} && scalar(@{ $params->{'pkgpart'} }) ) {
2876     #XXX untaint or sql quote
2877     push @where,
2878       'cust_pkg.pkgpart IN ('. join(',', @{ $params->{'pkgpart'} } ). ')';
2879   }
2880
2881   # popnum
2882   if ( $params->{'popnum'} =~ /^(\d+)$/ ) {
2883     push @where, "popnum = $1";
2884   }
2885
2886   # svcpart
2887   if ( $params->{'svcpart'} ) {
2888     my @svcpart = ref( $params->{'svcpart'} )
2889                     ? @{ $params->{'svcpart'} }
2890                     : $params->{'svcpart'}
2891                       ? ( $params->{'svcpart'} )
2892                       : ();
2893     @svcpart = grep /^(\d+)$/, @svcpart;
2894     push @where, 'svcpart IN ('. join(',', @svcpart ). ')' if @svcpart;
2895   }
2896
2897   if ( $params->{'exportnum'} =~ /^(\d+)$/ ) {
2898     push @from, ' LEFT JOIN export_svc USING ( svcpart )';
2899     push @where, "exportnum = $1";
2900   }
2901
2902   # sector and tower
2903   my @where_sector = $class->tower_sector_sql($params);
2904   if ( @where_sector ) {
2905     push @where, @where_sector;
2906     push @from, ' LEFT JOIN tower_sector USING ( sectornum )';
2907   }
2908
2909   # here is the agent virtualization
2910   #if ($params->{CurrentUser}) {
2911   #  my $access_user =
2912   #    qsearchs('access_user', { username => $params->{CurrentUser} });
2913   #
2914   #  if ($access_user) {
2915   #    push @where, $access_user->agentnums_sql('table'=>'cust_main');
2916   #  }else{
2917   #    push @where, "1=0";
2918   #  }
2919   #} else {
2920     push @where, $FS::CurrentUser::CurrentUser->agentnums_sql(
2921                    'table'      => 'cust_main',
2922                    'null_right' => 'View/link unlinked services',
2923                  );
2924   #}
2925
2926   push @where, @{ $params->{'where'} } if $params->{'where'};
2927
2928   my $addl_from = join(' ', @from);
2929   my $extra_sql = scalar(@where) ? ' WHERE '. join(' AND ', @where) : '';
2930
2931   my $count_query = "SELECT COUNT(*) FROM svc_acct $addl_from $extra_sql";
2932   #if ( keys %svc_acct ) {
2933   #  $count_query .= ' WHERE '.
2934   #                    join(' AND ', map "$_ = ". dbh->quote($svc_acct{$_}),
2935   #                                      keys %svc_acct
2936   #                        );
2937   #}
2938
2939   my $sql_query = {
2940     'table'       => 'svc_acct',
2941     'hashref'     => {}, # \%svc_acct,
2942     'select'      => join(', ',
2943                        'svc_acct.*',
2944                        'part_svc.svc',
2945                        'cust_main.custnum',
2946                        FS::UI::Web::cust_sql_fields($params->{'cust_fields'}),
2947                      ),
2948     'addl_from'   => $addl_from,
2949     'extra_sql'   => $extra_sql,
2950     'order_by'    => $params->{'order_by'},
2951     'count_query' => $count_query,
2952   };
2953
2954 }
2955
2956 =back
2957
2958 =head1 SUBROUTINES
2959
2960 =over 4
2961
2962 =item send_email
2963
2964 This is the FS::svc_acct job-queue-able version.  It still uses
2965 FS::Misc::send_email under-the-hood.
2966
2967 =cut
2968
2969 sub send_email {
2970   my %opt = @_;
2971
2972   eval "use FS::Misc qw(send_email)";
2973   die $@ if $@;
2974
2975   $opt{mimetype} ||= 'text/plain';
2976   $opt{mimetype} .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
2977
2978   my $error = send_email(
2979     'from'         => $opt{from},
2980     'to'           => $opt{to},
2981     'subject'      => $opt{subject},
2982     'content-type' => $opt{mimetype},
2983     'body'         => [ map "$_\n", split("\n", $opt{body}) ],
2984   );
2985   die $error if $error;
2986 }
2987
2988 =item check_and_rebuild_fuzzyfiles
2989
2990 =cut
2991
2992 sub check_and_rebuild_fuzzyfiles {
2993   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
2994   -e "$dir/svc_acct.username"
2995     or &rebuild_fuzzyfiles;
2996 }
2997
2998 =item rebuild_fuzzyfiles
2999
3000 =cut
3001
3002 sub rebuild_fuzzyfiles {
3003
3004   use Fcntl qw(:flock);
3005
3006   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3007
3008   #username
3009
3010   open(USERNAMELOCK,">>$dir/svc_acct.username")
3011     or die "can't open $dir/svc_acct.username: $!";
3012   flock(USERNAMELOCK,LOCK_EX)
3013     or die "can't lock $dir/svc_acct.username: $!";
3014
3015   my @all_username = map $_->getfield('username'), qsearch('svc_acct', {});
3016
3017   open (USERNAMECACHE,">$dir/svc_acct.username.tmp")
3018     or die "can't open $dir/svc_acct.username.tmp: $!";
3019   print USERNAMECACHE join("\n", @all_username), "\n";
3020   close USERNAMECACHE or die "can't close $dir/svc_acct.username.tmp: $!";
3021
3022   rename "$dir/svc_acct.username.tmp", "$dir/svc_acct.username";
3023   close USERNAMELOCK;
3024
3025 }
3026
3027 =item all_username
3028
3029 =cut
3030
3031 sub all_username {
3032   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3033   open(USERNAMECACHE,"<$dir/svc_acct.username")
3034     or die "can't open $dir/svc_acct.username: $!";
3035   my @array = map { chomp; $_; } <USERNAMECACHE>;
3036   close USERNAMECACHE;
3037   \@array;
3038 }
3039
3040 =item append_fuzzyfiles USERNAME
3041
3042 =cut
3043
3044 sub append_fuzzyfiles {
3045   my $username = shift;
3046
3047   &check_and_rebuild_fuzzyfiles;
3048
3049   use Fcntl qw(:flock);
3050
3051   my $dir = $FS::UID::conf_dir. "/cache.". $FS::UID::datasrc;
3052
3053   open(USERNAME,">>$dir/svc_acct.username")
3054     or die "can't open $dir/svc_acct.username: $!";
3055   flock(USERNAME,LOCK_EX)
3056     or die "can't lock $dir/svc_acct.username: $!";
3057
3058   print USERNAME "$username\n";
3059
3060   flock(USERNAME,LOCK_UN)
3061     or die "can't unlock $dir/svc_acct.username: $!";
3062   close USERNAME;
3063
3064   1;
3065 }
3066
3067
3068 =item reached_threshold
3069
3070 Performs some activities when svc_acct thresholds (such as number of seconds
3071 remaining) are reached.
3072
3073 =cut
3074
3075 sub reached_threshold {
3076   my %opt = @_;
3077
3078   my $svc_acct = qsearchs('svc_acct', { 'svcnum' => $opt{'svcnum'} } );
3079   die "Cannot find svc_acct with svcnum " . $opt{'svcnum'} unless $svc_acct;
3080
3081   if ( $opt{'op'} eq '+' ){
3082     $svc_acct->setfield( $opt{'column'}.'_threshold',
3083                          int($svc_acct->getfield($opt{'column'})
3084                              * ( $conf->exists('svc_acct-usage_threshold')
3085                                  ? $conf->config('svc_acct-usage_threshold')/100
3086                                  : 0.80
3087                                )
3088                          )
3089                        );
3090     my $error = $svc_acct->replace;
3091     die $error if $error;
3092   }elsif ( $opt{'op'} eq '-' ){
3093
3094     my $threshold = $svc_acct->getfield( $opt{'column'}.'_threshold' );
3095     return '' if ($threshold eq '' );
3096
3097     $svc_acct->setfield( $opt{'column'}.'_threshold', 0 );
3098     my $error = $svc_acct->replace;
3099     die $error if $error; # email next time, i guess
3100
3101     if ( $warning_template ) {
3102       eval "use FS::Misc qw(send_email)";
3103       die $@ if $@;
3104
3105       my $cust_pkg  = $svc_acct->cust_svc->cust_pkg;
3106       my $cust_main = $cust_pkg->cust_main;
3107
3108       my $to = join(', ', grep { $_ !~ /^(POST|FAX)$/ }
3109                                $cust_main->invoicing_list,
3110                                ($opt{'to'} ? $opt{'to'} : ())
3111                    );
3112
3113       my $mimetype = $warning_mimetype;
3114       $mimetype .= '; charset="iso-8859-1"' unless $opt{mimetype} =~ /charset/;
3115
3116       my $body       =  $warning_template->fill_in( HASH => {
3117                         'custnum'   => $cust_main->custnum,
3118                         'username'  => $svc_acct->username,
3119                         'password'  => $svc_acct->_password,
3120                         'first'     => $cust_main->first,
3121                         'last'      => $cust_main->getfield('last'),
3122                         'pkg'       => $cust_pkg->part_pkg->pkg,
3123                         'column'    => $opt{'column'},
3124                         'amount'    => $opt{'column'} =~/bytes/
3125                                        ? FS::UI::bytecount::display_bytecount($svc_acct->getfield($opt{'column'}))
3126                                        : $svc_acct->getfield($opt{'column'}),
3127                         'threshold' => $opt{'column'} =~/bytes/
3128                                        ? FS::UI::bytecount::display_bytecount($threshold)
3129                                        : $threshold,
3130                       } );
3131
3132
3133       my $error = send_email(
3134         'from'         => $warning_from,
3135         'to'           => $to,
3136         'subject'      => $warning_subject,
3137         'content-type' => $mimetype,
3138         'body'         => [ map "$_\n", split("\n", $body) ],
3139       );
3140       die $error if $error;
3141     }
3142   }else{
3143     die "unknown op: " . $opt{'op'};
3144   }
3145 }
3146
3147 =back
3148
3149 =head1 BUGS
3150
3151 The $recref stuff in sub check should be cleaned up.
3152
3153 The suspend, unsuspend and cancel methods update the database, but not the
3154 current object.  This is probably a bug as it's unexpected and
3155 counterintuitive.
3156
3157 insertion of RADIUS group stuff in insert could be done with child_objects now
3158 (would probably clean up export of them too)
3159
3160 _op_usage and set_usage bypass the history... maybe they shouldn't
3161
3162 =head1 SEE ALSO
3163
3164 L<FS::svc_Common>, edit/part_svc.cgi from an installed web interface,
3165 export.html from the base documentation, L<FS::Record>, L<FS::Conf>,
3166 L<FS::cust_svc>, L<FS::part_svc>, L<FS::cust_pkg>, L<FS::queue>,
3167 L<freeside-queued>), L<FS::svc_acct_pop>,
3168 schema.html from the base documentation.
3169
3170 =cut
3171
3172 1;