FS/FS/svc_acct.pm

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