lib/Vend/UserDB.pm

   1 # Vend::UserDB - Interchange user database functions
   2 #
   3 # $Id: UserDB.pm,v 2.66 2009-05-01 13:50:01 pajamian Exp $
   4 #
   5 # Copyright (C) 2002-2008 Interchange Development Group
   6 # Copyright (C) 1996-2002 Red Hat, Inc.
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16 # GNU General Public License for more details.
  17
  18 package Vend::UserDB;
  19
  20 $VERSION = substr(q$Revision: 2.66 $, 10);
  21
  22 use vars qw!
  23         $VERSION
  24         @S_FIELDS @B_FIELDS @P_FIELDS @I_FIELDS
  25         %S_to_B %B_to_S
  26         $USERNAME_GOOD_CHARS
  27 !;
  28
  29 use Vend::Data;
  30 use Vend::Util;
  31 use Vend::Safe;
  32 use strict;
  33 no warnings qw(uninitialized numeric);
  34
  35 my $ready = new Vend::Safe;
  36
  37 my $HAVE_SHA;
  38
  39 eval {
  40     require Digest::SHA;
  41     import Digest::SHA;
  42     $HAVE_SHA = 1;
  43 };
  44
  45 if ($@) {
  46     ::logGlobal("SHA passwords disabled: $@");
  47 }
  48
  49 # The object encryption methods take three arguments: object, password, and
  50 # mystery meat. If called in the context of new_account(), the mystery meat
  51 # is the salt (which is not always used). If called in the context of
  52 # login(), then the mystery meat is the entire password field from the
  53 # database (with salt, if applicable).
  54 my %enc_subs = (
  55     default => \&enc_default,
  56     md5 => \&enc_md5,
  57     md5_salted => \&enc_md5_salted,
  58     sha1 => \&enc_sha1,
  59 );
  60
  61 sub enc_default {
  62     my $obj = shift;
  63     my ($pwd, $salt) = @_;
  64     return crypt($pwd, $salt);
  65 }
  66
  67 sub enc_md5 {
  68     my $obj = shift;
  69     return Digest::MD5::md5_hex(shift);
  70 }
  71
  72 # This particular md5_salted encryption stores the salt with the password
  73 # in colon-separated format: /.+:(..)/. It is compatible with Zen Cart.
  74 # Detecting context based on the length of the mystery meat is a little
  75 # hokey; it would be more ideal to specify or detect the context
  76 # explicitly in/from the object itself (or as a named/separate parameter).
  77 sub enc_md5_salted {
  78     my ($obj, $password, $mystery_meat) = @_;
  79
  80     my $encrypted;
  81     my $return_salt;
  82     my $mystery_meat_length = length $mystery_meat;
  83     if ($mystery_meat_length == 35) {
  84         # Extract only the salt; we don't need the database password here.
  85         my (undef, $db_salt) = split(':', $mystery_meat);
  86         $encrypted = Digest::MD5::md5_hex($db_salt . $password);
  87         $return_salt = $db_salt;
  88     }
  89     else {
  90         if ($mystery_meat_length != 2) {
  91             # Assume the mystery meat is a salt and soldier on anyway.
  92             ::logError("Unrecognized salt for md5_salted encryption.");
  93         }
  94         $return_salt = $mystery_meat;
  95         $encrypted = Digest::MD5::md5_hex($return_salt . $password);
  96     }
  97
  98     return "$encrypted:$return_salt";
  99 }
 100
 101 sub enc_sha1 {
 102     my $obj = shift;
 103     unless ($HAVE_SHA) {
 104         $obj->log_either('SHA passwords unavailable. Is Digest::SHA installed?');
 105         return;
 106     }
 107     return Digest::SHA::sha1_hex(shift);
 108 }
 109
 110 # Maps the length of the encrypted data to the algorithm that
 111 # produces it. This method will have to be re-evaluated if competing
 112 # algorithms are introduced which produce the same-length value.
 113 my %enc_id = qw/
 114     13  default
 115     32  md5
 116     35  md5_salted
 117     40  sha1
 118 /;
 119
 120 =head1 NAME
 121
 122 UserDB.pm -- Interchange User Database Functions
 123
 124 =head1 SYNOPSIS
 125
 126 userdb $function, %options
 127
 128 =head1 DESCRIPTION
 129
 130 The Interchange user database saves information for users, including shipping,
 131 billing, and preference information.  It allows the user to return to a
 132 previous session without the requirement for a "cookie" or other persistent
 133 session information.
 134
 135 It is object-oriented and called via the [userdb] usertag, which calls the
 136 userdb subroutine.
 137
 138 It restores and manipulates the form values normally stored in the user session
 139 values -- the ones set in forms and read through the C<[value variable]> tags.
 140 A special function allows saving of shopping cart contents.
 141
 142 The preference, billing, and shipping information is keyed so that different
 143 sets of information may be saved, providing and "address_book" function that
 144 can save more than one shipping and/or billing address. The set to restore
 145 is selected by the form values C<s_nickname>, C<b_nickname>, and C<p_nickname>.
 146
 147 =cut
 148
 149 =head1 METHODS
 150
 151 User login:
 152
 153     $obj->login();        # Form values are
 154                           # mv_username, mv_password
 155
 156 Create account:
 157
 158     $obj->new_account();  # Form values are
 159                           # mv_username, mv_password, mv_verify
 160
 161 Change password:
 162
 163     $obj->change_pass();  # Form values are
 164                           # mv_username, mv_password_old, mv_password, mv_verify(new)
 165
 166 Get, set user information:
 167
 168     $obj->get_values();
 169     $obj->set_values();
 170     $obj->clear_values();
 171
 172 Save, restore filed user information:
 173
 174     $obj->get_shipping();
 175     $obj->set_shipping();
 176
 177     $obj->get_billing();
 178     $obj->set_billing();
 179
 180     $obj->get_preferences();
 181     $obj->set_preferences();
 182
 183     $obj->get_cart();
 184     $obj->set_cart();
 185
 186 =head2 Shipping Address Book
 187
 188 The shipping address book saves information relevant to shipping the
 189 order. In its simplest form, this can be the only address book needed.
 190 By default these form values are included:
 191
 192         s_nickname
 193         name
 194         address
 195         city
 196         state
 197         zip
 198         country
 199         phone_day
 200         mv_shipmode
 201
 202 The values are saved with the $obj->set_shipping() method and restored
 203 with $obj->get_shipping. A list of the keys available is kept in the
 204 form value C<address_book>, suitable for iteration in an HTML select
 205 box or in a set of links.
 206
 207 =cut
 208
 209 @S_FIELDS = (
 210 qw!
 211         s_nickname
 212         company
 213         name
 214         fname
 215         lname
 216         address
 217         address1
 218         address2
 219         address3
 220         city
 221         state
 222         zip
 223         country
 224         phone_day
 225         mv_shipmode
 226   !
 227 );
 228
 229 =head2 Accounts Book
 230
 231 The accounts book saves information relevant to billing the
 232 order. By default these form values are included:
 233
 234         b_nickname
 235         b_name
 236         b_address
 237         b_city
 238         b_state
 239         b_zip
 240         b_country
 241         b_phone
 242         mv_credit_card_type
 243         mv_credit_card_exp_month
 244         mv_credit_card_exp_year
 245         mv_credit_card_reference
 246
 247 The values are saved with the $obj->set_billing() method and restored
 248 with $obj->get_billing. A list of the keys available is kept in the
 249 form value C<accounts>, suitable for iteration in an HTML select
 250 box or in a set of links.
 251
 252 =cut
 253
 254 @B_FIELDS = (
 255 qw!
 256         b_nickname
 257         b_name
 258         b_fname
 259         b_lname
 260         b_address
 261         b_address1
 262         b_address2
 263         b_address3
 264         b_city
 265         b_state
 266         b_zip
 267         b_country
 268         b_phone
 269         purchase_order
 270         mv_credit_card_type
 271         mv_credit_card_exp_month
 272         mv_credit_card_exp_year
 273         mv_credit_card_reference
 274         !
 275 );
 276
 277 =head2 Preferences
 278
 279 Preferences are miscellaneous session information. They include
 280 by default the fields C<email>, C<fax>, C<phone_night>,
 281 and C<fax_order>. The field C<p_nickname> acts as a key to select
 282 the preference set.
 283
 284 =head2 Locations
 285
 286 There are several database locations that have special purposes. These
 287 fields are not saved as user values.
 288
 289 =over
 290
 291 =item USERNAME                          default: username
 292
 293 The username or key field of the database table.
 294
 295 =item BILLING                           default: accounts
 296
 297 Billing address hash field.
 298
 299 =item SHIPPING                          default: address_book
 300
 301 Shipping address hash field.
 302
 303 =item PREFERENCES                       default: preferences
 304
 305 Miscellaneous information hash field.
 306
 307 =item FEEDBACK                          default: feedback
 308
 309 Customer feedback hash field.
 310
 311 =item PRICING                           default: price_level
 312
 313 Customer pricing level marker.
 314
 315 =item CARTS                                     default: carts
 316
 317 Saved carts hash field.
 318
 319 =item PASSWORD                          default: password
 320
 321 Customer password info. If C<crypt> is set, may be encrypted.
 322
 323 =item LAST                                      default: mod_time
 324
 325 Last login time
 326
 327 =item EXPIRATION                        default: expiration
 328
 329 Expiration of account.
 330
 331 =item OUTBOARD_KEY              default: (none)
 332
 333 Key information for linking to another table of address or other info.
 334
 335 =item GROUPS                            default: groups
 336
 337 Groups they should be logged into.
 338
 339 =item SUPER                                     default: super
 340
 341 Whether they are a superuser (admin).
 342
 343 =item ACL                                       default: acl
 344
 345 =item FILE_ACL                          default: file_acl
 346
 347 =item DB_ACL                            default: db_acl
 348
 349 Location of access control information.
 350
 351 =item CREATED_DATE_ISO          default: (none)
 352
 353 =item CREATED_DATE_UNIX         default: (none)
 354
 355 =item UPDATED_DATE_ISO          default: (none)
 356
 357 =item UPDATED_DATE_UNIX         default: (none)
 358
 359 Date fields.
 360
 361 =item MERGED_USER                       default: (none)
 362
 363 The user id of another account this was merged into. If present, and data (should
 364 be a valid user id) is present in the field, the user will be logged as that username.
 365
 366 =back
 367
 368 =cut
 369
 370 # user name and password restrictions
 371 $USERNAME_GOOD_CHARS = '[-A-Za-z0-9_@.]';
 372
 373 @P_FIELDS = qw ( p_nickname email fax email_copy phone_night mail_list fax_order );
 374
 375 %S_to_B = (
 376 qw!
 377 s_nickname      b_nickname
 378 name            b_name
 379 address         b_address
 380 city            b_city
 381 state           b_state
 382 zip                     b_zip
 383 country         b_country
 384 phone_day       b_phone
 385 !
 386 );
 387
 388 @B_to_S{values %S_to_B} = keys %S_to_B;
 389
 390 sub new {
 391
 392         my ($class, %options) = @_;
 393
 394         my $loc;
 395         if(     $Vend::Cfg->{UserDB} ) {
 396                 if( $options{profile} ) {
 397                         $loc =  $Vend::Cfg->{UserDB_repository}{$options{profile}};
 398                 }
 399                 else {
 400                         $options{profile} = 'default';
 401                         $loc =  $Vend::Cfg->{UserDB};
 402                 }
 403                 $loc = {} unless $loc;
 404                 my ($k, $v);
 405                 while ( ($k,$v) = each %$loc) {
 406                         $options{$k} = $v unless defined $options{$k};
 407                 }
 408         }
 409
 410         if($options{billing}) {
 411                 $options{billing} =~ s/[,\s]+$//;
 412                 $options{billing} =~ s/^[,\s]+//;
 413                 @B_FIELDS = split /[\s,]+/, $options{billing};
 414         }
 415         if($options{shipping}) {
 416                 $options{shipping} =~ s/[,\s]+$//;
 417                 $options{shipping} =~ s/^[,\s]+//;
 418                 @S_FIELDS = split /[\s,]+/, $options{shipping};
 419         }
 420         if($options{preferences}) {
 421                 $options{preferences} =~ s/[,\s]+$//;
 422                 $options{preferences} =~ s/^[,\s]+//;
 423                 @P_FIELDS = split /[\s,]+/, $options{preferences};
 424         }
 425         if($options{ignore}) {
 426                 $options{ignore} =~ s/[,\s]+$//;
 427                 $options{ignore} =~ s/^[,\s]+//;
 428                 @I_FIELDS = split /[\s,]+/, $options{ignore};
 429         }
 430         my $self = {
 431                         USERNAME        => $options{username}   ||
 432                                                    $Vend::username              ||
 433                                                    $CGI::values{mv_username} ||
 434                                                    '',
 435                         OLDPASS         => $options{oldpass}    || $CGI::values{mv_password_old} || '',
 436                         PASSWORD        => $options{password}   || $CGI::values{mv_password} || '',
 437                         VERIFY          => $options{verify}             || $CGI::values{mv_verify}       || '',
 438                         NICKNAME        => $options{nickname}   || '',
 439                         PROFILE         => $options{profile}    || '',
 440                         LAST            => '',
 441                         USERMINLEN      => $options{userminlen} || 2,
 442                         PASSMINLEN      => $options{passminlen} || 4,
 443                         VALIDCHARS      => $options{validchars} ? ('[' . $options{validchars} . ']') : $USERNAME_GOOD_CHARS,
 444                         CRYPT           => defined $options{'crypt'}
 445                                                         ? $options{'crypt'}
 446                                                         : ! $::Variable->{MV_NO_CRYPT},
 447                         CGI                     =>      ( defined $options{cgi} ? is_yes($options{cgi}) : 1),
 448                         PRESENT         =>      { },
 449                         DB_ID           =>      $options{database} || 'userdb',
 450                         OPTIONS         =>      \%options,
 451                         OUTBOARD        =>  $options{outboard}  || '',
 452                         LOCATION        =>      {
 453                                                 USERNAME        => $options{user_field} || 'username',
 454                                                 BILLING         => $options{bill_field} || 'accounts',
 455                                                 SHIPPING        => $options{addr_field} || 'address_book',
 456                                                 PREFERENCES     => $options{pref_field} || 'preferences',
 457                                                 FEEDBACK        => $options{feedback_field}   || 'feedback',
 458                                                 PRICING         => $options{pricing_field} || 'price_level',
 459                                                 ORDERS          => $options{ord_field}  || 'orders',
 460                                                 CARTS           => $options{cart_field} || 'carts',
 461                                                 PASSWORD        => $options{pass_field} || 'password',
 462                                                 LAST            => $options{time_field} || 'mod_time',
 463                                                 EXPIRATION      => $options{expire_field} || 'expiration',
 464                                                 OUTBOARD_KEY=> $options{outboard_key_col},
 465                                                 GROUPS          => $options{groups_field}|| 'groups',
 466                                                 MERGED_USER => $options{merged_user},
 467                                                 SUPER           => $options{super_field}|| 'super',
 468                                                 ACL                     => $options{acl}                || 'acl',
 469                                                 FILE_ACL        => $options{file_acl}   || 'file_acl',
 470                                                 DB_ACL          => $options{db_acl}             || 'db_acl',
 471                                                 CREATED_DATE_ISO                => $options{created_date_iso},
 472                                                 CREATED_DATE_UNIX               => $options{created_date_epoch},
 473                                                 UPDATED_DATE_ISO                => $options{updated_date_iso},
 474                                                 UPDATED_DATE_UNIX               => $options{updated_date_epoch},
 475                                                         },
 476                         STATUS          =>              0,
 477                         ERROR           =>              '',
 478                         MESSAGE         =>              '',
 479                 };
 480         bless $self;
 481
 482         return $self if $options{no_open};
 483
 484         set_db($self) or die errmsg("user database %s does not exist.", $self->{DB_ID}) . "\n";
 485
 486         return $Vend::user_object = $self;
 487 }
 488
 489 sub create_db {
 490         my(%options) = @_;
 491         my $user = new Vend::UserDB no_open => 1, %options;
 492
 493         my(@out);
 494         push @out, $user->{LOCATION}{USERNAME};
 495         push @out, $user->{LOCATION}{PASSWORD};
 496         push @out, $user->{LOCATION}{LAST};
 497         push @out, @S_FIELDS, @B_FIELDS, @P_FIELDS;
 498         push @out, $user->{LOCATION}{ORDERS};
 499         push @out, $user->{LOCATION}{SHIPPING};
 500         push @out, $user->{LOCATION}{BILLING};
 501         push @out, $user->{LOCATION}{PREFERENCES};
 502
 503         my $csv = 0;
 504         my $delimiter = $options{delimiter} || "\t";
 505         if($delimiter =~ /csv|comma/i) {
 506                 $csv = 1;
 507                 $delimiter = '","';
 508         }
 509         my $separator = $options{separator} || "\n";
 510
 511         print '"' if $csv;
 512         print join $delimiter, @out;
 513         print '"' if $csv;
 514         print $separator;
 515         if ($options{verbose}) {
 516                 my $msg;
 517                 $msg = "Delimiter=";
 518                 if(length $delimiter == 1) {
 519                         $msg .= sprintf '\0%o', ord($delimiter);
 520                 }
 521                 else {
 522                         $msg .= $delimiter;
 523                 }
 524                 $msg .= " ";
 525                 $msg .= "Separator=";
 526                 if(length $separator == 1) {
 527                         $msg .= sprintf '\0%o', ord($separator);
 528                 }
 529                 else {
 530                         $msg .= $separator;
 531                 }
 532                 $msg .= "\nNicknames: ";
 533                 $msg .= "SHIPPING=$S_FIELDS[0] ";
 534                 $msg .= "BILLING=$B_FIELDS[0] ";
 535                 $msg .= "PREFERENCES=$P_FIELDS[0] ";
 536                 $msg .= "\nFields:\n";
 537                 $msg .= join "\n", @out;
 538                 $msg .= "\n\n";
 539                 my $type;
 540                 my $ext = '.txt';
 541                 SWITCH: {
 542                         $type = 4, $ext = '.csv', last SWITCH if $csv;
 543                         $type = 6, last SWITCH if $delimiter eq "\t";
 544                         $type = 5, last SWITCH if $delimiter eq "|";
 545                         $type = 3, last SWITCH
 546                                 if $delimiter eq "\n%%\n" && $separator eq "\n%%%\n";
 547                         $type = 2, last SWITCH
 548                                 if $delimiter eq "\n" && $separator eq "\n\n";
 549                         $type = '?';
 550                 }
 551
 552                 my $id = $user->{DB_ID};
 553                 $msg .= "Database line in catalog.cfg should be:\n\n";
 554                 $msg .= "Database $id $id.txt $type";
 555                 warn "$msg\n";
 556         }
 557         1;
 558 }
 559
 560 sub log_either {
 561         my $self = shift;
 562         my $msg = shift;
 563
 564         if(! $self->{OPTIONS}{logfile}) {
 565                 return logError($msg);
 566         }
 567         $self->log($msg,@_);
 568         return;
 569 }
 570
 571 sub log {
 572         my $self = shift;
 573         my $time = $self->{OPTIONS}{unix_time} ?  time() :
 574                                 POSIX::strftime("%Y%m%d%H%M", localtime());
 575         my $msg = shift;
 576         logData( ($self->{OPTIONS}{logfile} || $Vend::Cfg->{LogFile}),
 577                                                 $time,
 578                                                 $self->{USERNAME},
 579                                                 $CGI::remote_host || $CGI::remote_addr,
 580                                                 $msg,
 581                                                 );
 582         return;
 583 }
 584
 585 sub check_acl {
 586         my ($self,%options) = @_;
 587
 588         if(! defined $self->{PRESENT}{$self->{LOCATION}{ACL}}) {
 589                 $self->{ERROR} = errmsg('No ACL field present.');
 590                 return undef;
 591         }
 592
 593         if(not $options{location}) {
 594                 $self->{ERROR} = errmsg('No location to check.');
 595                 return undef;
 596         }
 597
 598         my $acl = $self->{DB}->field($self->{USERNAME}, $self->{LOCATION}{ACL});
 599         $acl =~ /(\s|^)$options{location}(\s|$)/;
 600 }
 601
 602
 603 sub set_acl {
 604         my ($self,%options) = @_;
 605
 606         if(!$self->{PRESENT}{$self->{LOCATION}{ACL}}) {
 607                 $self->{ERROR} = errmsg('No ACL field present.');
 608                 return undef;
 609         }
 610
 611         if(!$options{location}) {
 612                 $self->{ERROR} = errmsg('No location to set.');
 613                 return undef;
 614         }
 615
 616         my $acl = $self->{DB}->field($self->{USERNAME}, $self->{LOCATION}{ACL});
 617         if($options{'delete'}) {
 618                 $acl =~ s/(\s|^)$options{location}(\s|$)/$1$2/;
 619         }
 620         else {
 621                 $acl =~ s/(\s|^)$options{location}(\s|$)/$1$2/;
 622                 $acl .= " $options{location}";
 623         }
 624         $acl =~ s/\s+/ /g;
 625         $self->{DB}->set_field( $self->{USERNAME}, $self->{LOCATION}{ACL}, $acl);
 626         return $acl if $options{show};
 627         return;
 628 }
 629
 630 sub _check_acl {
 631         my ($self, $loc, %options) = @_;
 632         return undef unless $options{location};
 633         $options{mode} = 'r' if ! defined $options{mode};
 634         my $acl = $self->{DB}->field( $self->{USERNAME}, $loc);
 635         my $f = $ready->reval($acl);
 636         return undef unless exists $f->{$options{location}};
 637         return 1 if ! $options{mode};
 638         if($options{mode} =~ /^\s*expire\b/i) {
 639                 my $cmp = $f->{$options{location}};
 640                 return $cmp < time() ? '' : 1;
 641         }
 642         return 1 if $f->{$options{location}} =~ /$options{mode}/i;
 643         return '';
 644 }
 645
 646 sub _set_acl {
 647         my ($self, $loc, %options) = @_;
 648         return undef unless $self->{OPTIONS}{location};
 649         if($options{mode} =~ /^\s*expires?\s+(.*)/i) {
 650                 $options{mode} = adjust_time($1);
 651         }
 652         my $acl = $self->{DB}->field( $self->{USERNAME}, $loc );
 653         my $f = $ready->reval($acl) || {};
 654         if($options{'delete'}) {
 655                 delete $f->{$options{location}};
 656         }
 657         else {
 658                 $f->{$options{location}} = $options{mode} || 'rw';
 659         }
 660         my $return = $self->{DB}->set_field( $self->{USERNAME}, $loc, uneval_it($f) );
 661         return $return if $options{show};
 662         return;
 663 }
 664
 665 sub set_file_acl {
 666         my $self = shift;
 667         return $self->_set_acl($self->{LOCATION}{FILE_ACL}, @_);
 668 }
 669
 670 sub set_db_acl {
 671         my $self = shift;
 672         return $self->_set_acl($self->{LOCATION}{DB_ACL}, @_);
 673 }
 674
 675 sub check_file_acl {
 676         my $self = shift;
 677         return $self->_check_acl($self->{LOCATION}{FILE_ACL}, @_);
 678 }
 679
 680 sub check_db_acl {
 681         my $self = shift;
 682         return $self->_check_acl($self->{LOCATION}{DB_ACL}, @_);
 683 }
 684
 685 sub set_db {
 686         my($self, $database) = @_;
 687
 688         $database = $self->{DB_ID}              unless $database;
 689
 690         $Vend::WriteDatabase{$database} = 1;
 691
 692         my $db = database_exists_ref($database);
 693         return undef unless defined $db;
 694
 695         $db = $db->ref();
 696         my @fields = $db->columns();
 697         my %ignore;
 698
 699         my @final;
 700
 701         for(@I_FIELDS) {
 702                 $ignore{$_} = 1;
 703         }
 704
 705         if($self->{OPTIONS}{username_email}) {
 706                 $ignore{$self->{OPTIONS}{username_email_field} || 'email'} = 1;
 707         }
 708
 709         for(values %{$self->{LOCATION}}) {
 710                 $ignore{$_} = 1;
 711         }
 712
 713         if($self->{OPTIONS}{force_lower}) {
 714                 @fields = map { lc $_ } @fields;
 715         }
 716
 717         for(@fields) {
 718                 if($ignore{$_}) {
 719                         $self->{PRESENT}->{$_} = 1;
 720                         next;
 721                 }
 722                 push @final, $_;
 723         }
 724
 725         $self->{DB_FIELDS} = \@final;
 726         $self->{DB} = $db;
 727 }
 728
 729 # Sets location map, returns old value
 730 sub map_field {
 731         my ($self, $location, $field) = @_;
 732         if(! defined $field) {
 733                 return $self->{LOCATION}->{$location};
 734         }
 735         else {
 736                 my $old = $self->{LOCATION}->{$field};
 737                 $self->{LOCATION}->{$location} = $field;
 738                 return $old;
 739         }
 740 }
 741
 742 sub clear_values {
 743         my($self, @fields) = @_;
 744
 745         @fields = @{ $self->{DB_FIELDS} } unless @fields;
 746
 747         my %constant;
 748         my %scratch;
 749         my %session_hash;
 750
 751         if($self->{OPTIONS}->{constant}) {
 752                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{constant} ;
 753                 for(@s) {
 754                         my ($k, $v) = split /=/, $_;
 755                         $v ||= $k;
 756                         $constant{$k} = $v;
 757                 }
 758         }
 759
 760         if($self->{OPTIONS}->{scratch}) {
 761                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{scratch} ;
 762                 for(@s) {
 763                         my ($k, $v) = split /=/, $_;
 764                         $v ||= $k;
 765                         $scratch{$k} = $v;
 766                 }
 767         }
 768
 769         if($self->{OPTIONS}->{session_hash}) {
 770                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{session_hash} ;
 771                 for(@s) {
 772                         my ($k, $v) = split /=/, $_;
 773                         $v ||= $k;
 774                         $session_hash{$k} = $v;
 775                 }
 776         }
 777
 778         for(@fields) {
 779                 if(my $s = $scratch{$_}) {
 780                         if (exists $Vend::Cfg->{ScratchDefault}->{$s}) {
 781                                 $::Scratch->{$s} = $Vend::Cfg->{ScratchDefault}->{$s};
 782                         }
 783                         else {
 784                                 delete $::Scratch->{$s};
 785                         }
 786                 }
 787                 elsif($constant{$_}) {
 788                         delete $Vend::Session->{constant}{$constant{$_}};
 789                 }
 790                 elsif($session_hash{$_}) {
 791                         delete $Vend::Session->{$session_hash{$_}};
 792                 }
 793                 else {
 794                         if (exists $Vend::Cfg->{ValuesDefault}->{$_}) {
 795                                 $::Values->{$_} = $Vend::Cfg->{ValuesDefault}->{$_};
 796                         }
 797                         else{
 798                                 delete $::Values->{$_};
 799                         }
 800                         delete $CGI::values{$_};
 801                 }
 802         }
 803
 804         1;
 805 }
 806
 807 sub get_values {
 808         my($self, $valref, $scratchref) = @_;
 809
 810         $valref = $::Values unless ref($valref);
 811         $scratchref = $::Scratch unless ref($scratchref);
 812         my $constref = $Vend::Session->{constant} ||= {};
 813
 814         my @fields = @{ $self->{DB_FIELDS} };
 815
 816         if($self->{OPTIONS}{username_email}) {
 817                 push @fields, $self->{OPTIONS}{username_email_field} || 'email';
 818         }
 819
 820         my $db = $self->{DB}
 821                 or die errmsg("No user database found.");
 822
 823         unless ( $db->record_exists($self->{USERNAME}) ) {
 824                 $self->{ERROR} = errmsg("username %s does not exist.", $self->{USERNAME});
 825                 return undef;
 826         }
 827
 828         my %ignore;
 829         my %scratch;
 830         my %constant;
 831         my %session_hash;
 832
 833         for(values %{$self->{LOCATION}}) {
 834                 $ignore{$_} = 1;
 835         }
 836
 837         my %outboard;
 838         if($self->{OUTBOARD}) {
 839                 %outboard = split /[\s=,]+/, $self->{OUTBOARD};
 840                 push @fields, keys %outboard;
 841         }
 842
 843         if($self->{OPTIONS}->{constant}) {
 844                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{constant} ;
 845                 for(@s) {
 846                         my ($k, $v) = split /=/, $_;
 847                         $v ||= $k;
 848                         $constant{$k} = $v;
 849                 }
 850 #::logDebug("constant ones: " . join " ", @s);
 851         }
 852
 853         if($self->{OPTIONS}->{session_hash}) {
 854                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{session_hash} ;
 855                 for(@s) {
 856                         my ($k, $v) = split /=/, $_;
 857                         $v ||= $k;
 858                         $session_hash{$k} = $v;
 859                 }
 860 #::logDebug("session_hash ones: " . join " ", @s);
 861         }
 862
 863         if($self->{OPTIONS}->{scratch}) {
 864                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{scratch} ;
 865                 for(@s) {
 866                         my ($k, $v) = split /=/, $_;
 867                         $v ||= $k;
 868                         $scratch{$k} = $v;
 869                 }
 870 #::logDebug("scratch ones: " . join " ", @s);
 871         }
 872
 873         my @needed;
 874         my $row = $db->row_hash($self->{USERNAME});
 875         my $outkey = $self->{LOCATION}->{OUTBOARD_KEY}
 876                                  ? $row->{$self->{LOCATION}->{OUTBOARD_KEY}}
 877                                  : $self->{USERNAME};
 878
 879         if(my $ef = $self->{OPTIONS}->{extra_fields}) {
 880                 my @s = grep /\w/, split /[\s,]+/, $ef;
 881                 my $field = $self->{LOCATION}{PREFERENCES};
 882                 my $loc   = $self->{OPTIONS}{extra_selector} || 'default';
 883                 my $hash = get_option_hash($row->{$field});
 884                 if($hash and $hash = $hash->{$loc} and ref($hash) eq 'HASH') {
 885                         for(@s) {
 886                                 if($scratch{$_} ) {
 887                                         $::Scratch->{$_} = $hash->{$_};
 888                                 }
 889                                 else {
 890                                         $::Values->{$_} = $hash->{$_};
 891                                 }
 892                         }
 893                 }
 894         }
 895
 896         for(@fields) {
 897                 if($ignore{$_}) {
 898                         $self->{PRESENT}->{$_} = 1;
 899                         next;
 900                 }
 901                 my $val;
 902                 if ($outboard{$_}) {
 903                         my ($t, $c, $k) = split /:+/, $outboard{$_};
 904                         $val = ::tag_data($t, ($c || $_), $outkey, { foreign => $k });
 905                 }
 906                 else {
 907                         $val = $row->{$_};
 908                 }
 909
 910                 my $k;
 911                 if($k = $scratch{$_}) {
 912                         $scratchref->{$k} = $val;
 913                         next;
 914                 }
 915                 elsif($k = $constant{$_}) {
 916                         $constref->{$k} = $val;
 917                         next;
 918                 }
 919                 elsif($k = $session_hash{$_}) {
 920                         $Vend::Session->{$k} = string_to_ref($val) || {};
 921                         next;
 922                 }
 923                 $valref->{$_} = $val;
 924
 925         }
 926
 927         my $area;
 928         foreach $area (qw!SHIPPING BILLING PREFERENCES CARTS!) {
 929                 my $f = $self->{LOCATION}->{$area};
 930                 if ($self->{PRESENT}->{$f}) {
 931                         my $s = $self->get_hash($area);
 932                         die errmsg("Bad structure in %s: %s", $f, $@) if $@;
 933                         $::Values->{$f} = join "\n", sort keys %$s;
 934                 }
 935         }
 936
 937         1;
 938 }
 939
 940 sub set_values {
 941         my($self, $valref, $scratchref) = @_;
 942
 943         $valref = $::Values unless ref($valref);
 944         $scratchref = $::Scratch unless ref($scratchref);
 945
 946         my $user = $self->{USERNAME};
 947
 948         my @fields = @{$self->{DB_FIELDS}};
 949
 950         my $db = $self->{DB};
 951
 952         unless ( $db->record_exists($self->{USERNAME}) ) {
 953                 $self->{ERROR} = errmsg("username %s does not exist.", $self->{USERNAME});
 954                 return undef;
 955         }
 956         my %scratch;
 957         my %constant;
 958         my %session_hash;
 959     my %read_only;
 960
 961         if ($self->{OPTIONS}{read_only}) {
 962                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{read_only} ;
 963                 $read_only{$_} = 1 for @s;
 964         }
 965
 966         if($self->{OPTIONS}->{scratch}) {
 967                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{scratch} ;
 968                 for(@s) {
 969                         my ($k, $v) = split /=/, $_;
 970                         $v ||= $k;
 971                         $scratch{$k} = $v;
 972                 }
 973         }
 974
 975         if($self->{OPTIONS}->{constant}) {
 976                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{constant} ;
 977                 for(@s) {
 978                         my ($k, $v) = split /=/, $_;
 979                         $v ||= $k;
 980                         $constant{$k} = $v;
 981                 }
 982         }
 983
 984         if($self->{OPTIONS}->{session_hash}) {
 985                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{session_hash} ;
 986                 for(@s) {
 987                         my ($k, $v) = split /=/, $_;
 988                         $v ||= $k;
 989                         $session_hash{$k} = $v;
 990                 }
 991         }
 992
 993         my $val;
 994         my %outboard;
 995         if($self->{OUTBOARD}) {
 996                 %outboard = split /[\s=,]+/, $self->{OUTBOARD};
 997                 push @fields, keys %outboard;
 998         }
 999
1000         my @bfields;
1001         my @bvals;
1002
1003   eval {
1004
1005         my @extra;
1006
1007         if(my $ef = $self->{OPTIONS}->{extra_fields}) {
1008                 my $row = $db->row_hash($user);
1009                 my @s = grep /\w/, split /[\s,]+/, $ef;
1010                 my $field = $self->{LOCATION}{PREFERENCES};
1011                 my $loc   = $self->{OPTIONS}{extra_selector} || 'default';
1012                 my $hash = get_option_hash( $row->{$field} ) || {};
1013
1014                 my $subhash = $hash->{$loc} ||= {};
1015                 for(@s) {
1016                         $subhash->{$_} = $scratch{$_} ? $scratchref->{$_} : $valref->{$_};
1017                 }
1018
1019                 push @extra, $field;
1020                 push @extra, uneval_it($hash);
1021         }
1022
1023         for( @fields ) {
1024 #::logDebug("set_values saving $_ as $valref->{$_}\n");
1025                 my $val;
1026                 my $k;
1027         if ($read_only{$_}) {
1028             # Pull from get_values only; never write through set_values
1029             next;
1030         }
1031                 if ($k = $scratch{$_}) {
1032                         $val = $scratchref->{$k}
1033                                 if defined $scratchref->{$k};
1034                 }
1035                 elsif ($constant{$_}) {
1036                         # we never store constants
1037                         next;
1038                 }
1039                 elsif ($k = $session_hash{$_}) {
1040                         $val = uneval_it($Vend::Session->{$k});
1041                 }
1042                 else {
1043                         $val = $valref->{$_}
1044                                 if defined $valref->{$_};
1045                 }
1046
1047                 next if ! defined $val;
1048
1049                 if($outboard{$_}) {
1050                         my ($t, $c, $k) = split /:+/, $outboard{$_};
1051                         ::tag_data($t, ($c || $_), $self->{USERNAME}, { value => $val, foreign => $k });
1052                 }
1053                 elsif ($db->test_column($_)) {
1054                         push @bfields, $_;
1055                         push @bvals, $val;
1056                 }
1057                 else {
1058                         ::logDebug( errmsg(
1059                                                         "cannot set unknown userdb field %s to: %s",
1060                                                         $_,
1061                                                         $val,
1062                                                 )
1063                                         );
1064                 }
1065         }
1066
1067         my $dfield;
1068         my $dstring;
1069         if($dfield = $self->{OPTIONS}{updated_date_iso}) {
1070                 if($self->{OPTIONS}{updated_date_gmtime}) {
1071                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%SZ', gmtime());
1072                 }
1073                 elsif($self->{OPTIONS}{updated_date_showzone}) {
1074                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S %z', localtime());
1075                 }
1076                 else {
1077                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
1078                 }
1079         }
1080         elsif($dfield = $self->{OPTIONS}{updated_date_epoch}) {
1081                 $dstring = time;
1082         }
1083
1084         if($dfield and $dstring) {
1085                 if($db->test_column($dfield)) {
1086                         push @bfields, $dfield;
1087                         push @bvals, $dstring;
1088                 }
1089                 else {
1090                         my $msg = errmsg("updated field %s doesn't exist", $dfield);
1091                         Vend::Tags->warnings($msg);
1092                 }
1093         }
1094
1095         while(@extra) {
1096                 push @bfields, shift @extra;
1097                 push @bvals, shift @extra;
1098         }
1099
1100 #::logDebug("bfields=" . ::uneval(\@bfields));
1101 #::logDebug("bvals=" . ::uneval(\@bvals));
1102         if(@bfields) {
1103                 $db->set_slice($user, \@bfields, \@bvals);
1104         }
1105   };
1106
1107         if($@) {
1108           my $msg = errmsg("error saving values in userdb: %s", $@);
1109           $self->{ERROR} = $msg;
1110           logError($msg);
1111           return undef;
1112         }
1113
1114 # Changes made to support Accounting Interface.
1115
1116         if(my $l = $Vend::Cfg->{Accounting}) {
1117                 my %hashvar;
1118                 my $indexvar = 0;
1119                 while ($indexvar <= (scalar @bfields)) {
1120                         $hashvar{ $bfields[$indexvar] } = $bvals[$indexvar];
1121                         $indexvar++;
1122                 };
1123                 my $obj;
1124                 my $class = $l->{Class};
1125                 eval {
1126                         $obj = $class->new;
1127                 };
1128
1129                 if($@) {
1130                         die errmsg(
1131                                 "Failed to save customer data with accounting system %s: %s",
1132                                 $class,
1133                                 $@,
1134                                 );
1135                 }
1136                 my $returnval = $obj->save_customer_data($user, \%hashvar);
1137         }
1138
1139         return 1;
1140 }
1141
1142 sub set_billing {
1143         my $self = shift;
1144         my $ref = $self->set_hash('BILLING', @B_FIELDS );
1145         return $ref;
1146 }
1147
1148 sub set_shipping {
1149         my $self = shift;
1150         my $ref = $self->set_hash('SHIPPING', @S_FIELDS );
1151         return $ref;
1152 }
1153
1154 sub set_preferences {
1155         my $self = shift;
1156         my $ref = $self->set_hash('PREFERENCES', @P_FIELDS );
1157         return $ref;
1158 }
1159
1160 sub get_shipping {
1161         my $self = shift;
1162         my $ref = $self->get_hash('SHIPPING', @S_FIELDS );
1163         return $ref;
1164 }
1165
1166 sub get_billing {
1167         my $self = shift;
1168         my $ref = $self->get_hash('BILLING', @B_FIELDS );
1169         return $ref;
1170 }
1171
1172 sub get_preferences {
1173         my $self = shift;
1174         my $ref = $self->get_hash('PREFERENCES', @P_FIELDS );
1175         return $ref;
1176 }
1177
1178 sub get_shipping_names {
1179         my $self = shift;
1180         my $ref = $self->get_hash('SHIPPING');
1181         return undef unless ref $ref;
1182         $::Values->{$self->{LOCATION}{SHIPPING}} = join "\n", sort keys %$ref;
1183         return $::Values->{$self->{LOCATION}{SHIPPING}} if $self->{OPTIONS}{show};
1184         return '';
1185 }
1186
1187 sub get_shipping_hashref {
1188         my $self = shift;
1189         my $ref = $self->get_hash('SHIPPING');
1190         return $ref if ref($ref) eq 'HASH';
1191         return undef;
1192 }
1193
1194 sub get_billing_names {
1195         my $self = shift;
1196         my $ref = $self->get_hash('BILLING');
1197         return undef unless ref $ref;
1198         $::Values->{$self->{LOCATION}{BILLING}} = join "\n", sort keys %$ref;
1199         return $::Values->{$self->{LOCATION}{BILLING}} if $self->{OPTIONS}{show};
1200         return '';
1201 }
1202
1203 sub get_billing_hashref {
1204         my $self = shift;
1205         my $ref = $self->get_hash('BILLING');
1206         return $ref if ref($ref) eq 'HASH';
1207         return undef;
1208 }
1209
1210 sub get_preferences_names {
1211         my $self = shift;
1212         my $ref = $self->get_hash('PREFERENCES');
1213         return undef unless ref $ref;
1214         $::Values->{$self->{LOCATION}{PREFERENCES}} = join "\n", sort keys %$ref;
1215         return $::Values->{$self->{LOCATION}{PREFERENCES}} if $self->{OPTIONS}{show};
1216         return '';
1217 }
1218
1219 sub get_cart_names {
1220         my $self = shift;
1221         my $ref = $self->get_hash('CARTS');
1222         return undef unless ref $ref;
1223         $::Values->{$self->{LOCATION}{CARTS}} = join "\n", sort keys %$ref;
1224         return $::Values->{$self->{LOCATION}{CARTS}} if $self->{OPTIONS}{show};
1225         return '';
1226 }
1227
1228 sub delete_billing {
1229         my $self = shift;
1230         $self->delete_nickname('BILLING', @B_FIELDS );
1231         return '';
1232 }
1233
1234 sub delete_cart {
1235         my $self = shift;
1236         $self->delete_nickname('CARTS', $self->{NICKNAME});
1237         return '';
1238 }
1239
1240 sub delete_shipping {
1241         my $self = shift;
1242         $self->delete_nickname('SHIPPING', @S_FIELDS );
1243         return '';
1244 }
1245
1246 sub delete_preferences {
1247         my $self = shift;
1248         $self->delete_nickname('PREFERENCES', @P_FIELDS );
1249         return '';
1250 }
1251
1252 sub delete_nickname {
1253         my($self, $name, @fields) = @_;
1254
1255         die errmsg("no fields?") unless @fields;
1256         die errmsg("no name?") unless $name;
1257
1258         $self->get_hash($name) unless ref $self->{$name};
1259
1260         my $nick_field = shift @fields;
1261         my $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1262
1263         delete $self->{$name}{$nick};
1264
1265         my $field_name = $self->{LOCATION}->{$name};
1266         unless($self->{PRESENT}->{$field_name}) {
1267                 $self->{ERROR} = errmsg('%s field not present to set %s', $field_name, $name);
1268                 return undef;
1269         }
1270
1271         my $s = uneval_it($self->{$name});
1272
1273         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
1274
1275         return ($s, $self->{$name});
1276 }
1277
1278 sub set_hash {
1279         my($self, $name, @fields) = @_;
1280
1281         die errmsg("no fields?") unless @fields;
1282         die errmsg("no name?") unless $name;
1283
1284         $self->get_hash($name) unless ref $self->{$name};
1285
1286         my $nick_field = shift @fields;
1287         my $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1288         $nick =~ s/^[\0\s]+//;
1289         $nick =~ s/[\0\s]+.*//;
1290         $::Values->{$nick_field} = $nick;
1291         $CGI::values{$nick_field} = $nick if $self->{CGI};
1292
1293         die errmsg("no nickname?") unless $nick;
1294
1295         $self->{$name}{$nick} = {} unless $self->{OPTIONS}{keep}
1296                                                            and    defined $self->{$name}{$nick};
1297
1298         for(@fields) {
1299                 $self->{$name}{$nick}{$_} = $::Values->{$_}
1300                         if defined $::Values->{$_};
1301         }
1302
1303         my $field_name = $self->{LOCATION}->{$name};
1304         unless($self->{PRESENT}->{$field_name}) {
1305                 $self->{ERROR} = errmsg('%s field not present to set %s', $field_name, $name);
1306                 return undef;
1307         }
1308
1309         my $s = uneval_it($self->{$name});
1310
1311         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
1312
1313         return ($s, $self->{$name});
1314 }
1315
1316 sub get_hash {
1317         my($self, $name, @fields) = @_;
1318
1319         my $field_name = $self->{LOCATION}->{$name};
1320         my ($nick, $s);
1321
1322         eval {
1323                 die errmsg("no name?")                                  unless $name;
1324                 die errmsg("%s field not present to get %s", $field_name, $name) . "\n"
1325                                                                                 unless $self->{PRESENT}->{$field_name};
1326
1327                 $s = $self->{DB}->field( $self->{USERNAME}, $field_name);
1328
1329                 if($s) {
1330                         $self->{$name} = string_to_ref($s);
1331                         die errmsg("Bad structure in %s: %s", $field_name, $@) if $@;
1332                 }
1333                 else {
1334                         $self->{$name} = {};
1335                 }
1336
1337                 die errmsg("eval failed?") . "\n"               unless ref $self->{$name};
1338         };
1339
1340         if($@) {
1341                 $self->{ERROR} = $@;
1342                 return undef;
1343         }
1344
1345         return $self->{$name} unless @fields;
1346
1347         eval {
1348                 my $nick_field = shift @fields;
1349                 $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1350                 $nick =~ s/^[\0\s]+//;
1351                 $nick =~ s/[\0\s]+.*//;
1352                 $::Values->{$nick_field} = $nick;
1353                 $CGI::values{$nick_field} = $nick if $self->{CGI};
1354                 die errmsg("no nickname?") unless $nick;
1355         };
1356
1357         if($@) {
1358                 $self->{ERROR} = $@;
1359                 return undef;
1360         }
1361
1362         $self->{$name}->{$nick} = {} unless defined $self->{$name}{$nick};
1363
1364         for(@fields) {
1365                 delete $::Values->{$_};
1366                 $::Values->{$_} = $self->{$name}{$nick}{$_}
1367                         if defined  $self->{$name}{$nick}{$_};
1368                 next unless $self->{CGI};
1369                 $CGI::values{$_} = $::Values->{$_};
1370         }
1371         ::update_user() if $self->{CGI};
1372         return $self->{$name}{$nick};
1373 }
1374
1375 =over 4
1376
1377 =item enclair_db
1378
1379 Using set_enclair() allows logging of enclair password to separate
1380 database table. Designed to allow administration personnel to look
1381 at passwords, without allowing access to web-connected systems. Or
1382 perhaps more properly, to check prior MD5-encrypted password values
1383 for repeat passwords.
1384
1385 Designed to log to an insert-only handle on a table, with a database
1386 structure such as:
1387
1388   create table enclair (
1389     username varchar(32),
1390      password varchar(32),
1391      update_date timestamp
1392     )
1393
1394 Then a program on a secure behind-firewall no-select write-only
1395 database can access the table, logged via request and username.
1396
1397 Configured:
1398
1399         UserDB   default  enclair_db   some_table
1400
1401 You can set the following, which have the defaults shown in the
1402 setting. You can also insert %M, which is the MD5 of the password, or
1403 %D which is a datetime localtime value in the form YYYYmmddHHMMSS.
1404
1405         #UserDB   default  enclair_key_field   username
1406         #UserDB   default  enclair_field       password
1407         #UserDB   default  enclair_query_template "INSERT INTO %t (%U,%P) values (%u,%p)"
1408
1409 String substitutions:
1410
1411         %u  value of username
1412         %p  value of password
1413         %U  field of username
1414         %P  field of password
1415         %t  enclair table name
1416         %D  datetime value of form YYYYmmddHHMMSS
1417         %M  MD5 hashed value of password
1418
1419 =back
1420
1421 =cut
1422
1423 sub set_enclair {
1424         my $self = shift;
1425         if( my $tab = $self->{OPTIONS}{enclair_db} ) {
1426                 eval {
1427                         my $dbh = dbref($tab)->dbh();
1428                         my $field = $self->{OPTIONS}{enclair_field} || 'password';
1429                         my $key   = $self->{OPTIONS}{enclair_key_field} || 'username';
1430                         my $datetime = POSIX::strftime('%Y%m%d%H%M%S', localtime());
1431                         my $md5 = generate_key($self->{PASSWORD});
1432                         my $q = $self->{OPTIONS}{enclair_query_template} || "INSERT INTO %t (%U,%P) values (%u,%p)";
1433                         $q =~ s/\%M/$dbh->quote($md5)/eg;
1434                         $q =~ s/\%D/$dbh->quote($datetime)/eg;
1435                         $q =~ s/\%t/$tab/g;
1436                         $q =~ s/\%U/$key/g;
1437                         $q =~ s/\%P/$field/g;
1438                         $q =~ s/\%u/$dbh->quote($self->{USERNAME})/eg;
1439                         $q =~ s/\%p/$dbh->quote($self->{PASSWORD})/eg;
1440                         $dbh->do($q);
1441                 };
1442                 if($@) {
1443                         $self->log_either("Failed to set enclair password for $self->{USERNAME}: $@");
1444                 }
1445         }
1446 }
1447
1448
1449 sub login {
1450         my $self;
1451
1452         $self = shift
1453                 if ref $_[0];
1454
1455         my(%options) = @_;
1456         my ($user_data, $pw);
1457
1458         # Show this generic error message on login page to avoid
1459         # helping would-be intruders
1460         my $stock_error = errmsg("Invalid user name or password.");
1461
1462         eval {
1463                 unless($self) {
1464                         $self = new Vend::UserDB %options;
1465                 }
1466
1467                 if($Vend::Cfg->{CookieLogin}) {
1468                         $self->{USERNAME} = Vend::Util::read_cookie('MV_USERNAME')
1469                                 if ! $self->{USERNAME};
1470                         $self->{PASSWORD} = Vend::Util::read_cookie('MV_PASSWORD')
1471                                 if ! $self->{PASSWORD};
1472                 }
1473
1474                 if ($self->{VALIDCHARS} !~ / /) {
1475                         # If space isn't a valid character in usernames,
1476                         # be nice and strip leading and trailing whitespace.
1477                         $self->{USERNAME} =~ s/^\s+//;
1478                         $self->{USERNAME} =~ s/\s+$//;
1479                 }
1480
1481                 if ($self->{OPTIONS}{ignore_case}) {
1482                         $self->{PASSWORD} = lc $self->{PASSWORD};
1483                         $self->{USERNAME} = lc $self->{USERNAME};
1484                 }
1485
1486                 # We specifically check for login attempts with group names to see if
1487                 # anyone is trying to exploit a former vulnerability in the demo catalog.
1488                 if ($self->{USERNAME} =~ /^:/) {
1489                         $self->log_either(errmsg("Denied attempted login with group name '%s'",
1490                                 $self->{USERNAME}));
1491                         die $stock_error, "\n";
1492                 }
1493
1494                 # Username must be long enough
1495                 if (length($self->{USERNAME}) < $self->{USERMINLEN}) {
1496                         $self->log_either(errmsg("Denied attempted login for user name '%s'; must have at least %s characters",
1497                                 $self->{USERNAME}, $self->{USERMINLEN}));
1498                         die $stock_error, "\n";
1499                 }
1500
1501                 # Username must contain only valid characters
1502                 if ($self->{USERNAME} !~ m{^$self->{VALIDCHARS}+$}) {
1503                         $self->log_either(errmsg("Denied attempted login for user name '%s' with illegal characters",
1504                                 $self->{USERNAME}));
1505                         die $stock_error, "\n";
1506                 }
1507
1508                 # Fail if password is too short
1509                 if (length($self->{PASSWORD}) < $self->{PASSMINLEN}) {
1510                         $self->log_either(errmsg("Denied attempted login with user name '%s' and password less than %s characters",
1511                                 $self->{USERNAME}, $self->{PASSMINLEN}));
1512                         die $stock_error, "\n";
1513                 }
1514
1515                 my $udb = $self->{DB};
1516                 my $foreign = $self->{OPTIONS}{indirect_login};
1517
1518                 if($foreign) {
1519                         my $uname = ($self->{PASSED_USERNAME} ||= $self->{USERNAME});
1520                         my $ufield = $self->{LOCATION}{USERNAME};
1521                         $uname = $udb->quote($uname);
1522                         my $q = "select $ufield from $self->{DB_ID} where $foreign = $uname";
1523 #::logDebug("indirect login query: $q");
1524                         my $ary = $udb->query($q)
1525                                 or do {
1526                                         my $msg = errmsg( "Database access error for query: %s", $q);
1527                                         die "$msg\n";
1528                                 };
1529                         @$ary == 1
1530                                 or do {
1531                                         $self->log_either(errmsg(
1532                                                 @$ary ? "Denied attempted login with ambiguous (indirect from %s) user name %s" : "Denied attempted login with nonexistent (indirect from %s) user name %s",
1533                                                 $foreign,
1534                                                 $uname,
1535                                                 $self->{USERNAME},
1536                                         ));
1537                                         die $stock_error, "\n";
1538                                 };
1539                         $self->{USERNAME} = $ary->[0][0];
1540                 }
1541
1542                 # If not superuser, an entry must exist in access database
1543                 unless ($Vend::superuser) {
1544                         unless ($udb->record_exists($self->{USERNAME})) {
1545                                 $self->log_either(errmsg("Denied attempted login with nonexistent user name '%s'",
1546                                         $self->{USERNAME}));
1547                                 die $stock_error, "\n";
1548                         }
1549                         unless ($user_data = $udb->row_hash($self->{USERNAME})) {
1550                                 $self->log_either(errmsg("Login denied after failed fetch of user data for user '%s'",
1551                                         $self->{USERNAME}));
1552                                 die $stock_error, "\n";
1553                         }
1554                         my $db_pass = $user_data->{ $self->{LOCATION}{PASSWORD} };
1555                         unless ($db_pass) {
1556                                 $self->log_either(errmsg("Refusing to use blank password from '%s' database for user '%s'", $self->{DB_ID}, $self->{USERNAME}));
1557                                 die $stock_error, "\n";
1558                         }
1559                         $pw = $self->{PASSWORD};
1560
1561                         if ( $self->{CRYPT} && $self->{OPTIONS}{promote} ) {
1562                                 my ($cur_method) = grep { $self->{OPTIONS}{ $_ } } keys %enc_subs;
1563                                 $cur_method ||= 'default';
1564
1565                                 my $stored_by = $enc_id{ length($db_pass) };
1566
1567                                 if (
1568                                         $cur_method ne $stored_by
1569                                         &&
1570                                         $db_pass eq $enc_subs{$stored_by}->($self, $pw, $db_pass)
1571                                 ) {
1572
1573                                         my $newpass = $enc_subs{$cur_method}->($self, $pw, $db_pass);
1574                                         my $db_newpass = eval {
1575                                                 $self->{DB}->set_field(
1576                                                         $self->{USERNAME},
1577                                                         $self->{LOCATION}{PASSWORD},
1578                                                         $newpass,
1579                                                 );
1580                                         };
1581
1582                                         if ($db_newpass ne $newpass) {
1583                                                 # Usually, an error in the update will cause $db_newpass to be set to a
1584                                                 # useful error string. The usefulness is dependent on DB store itself, though.
1585                                                 my $err_msg = qq{Could not update database "%s" field "%s" with promoted password due to error:\n}
1586                                                         . "%s\n"
1587                                                         . qq{Check that field "%s" is at least %s characters wide.\n};
1588                                                 $err_msg = ::errmsg(
1589                                                         $err_msg,
1590                                                         $self->{DB_ID},
1591                                                         $self->{LOCATION}{PASSWORD},
1592                                                         $DBI::errstr,
1593                                                         $self->{LOCATION}{PASSWORD},
1594                                                         length($newpass),
1595                                                 );
1596                                                 ::logError($err_msg);
1597                                                 die $err_msg;
1598                                         }
1599                                         $db_pass = $newpass;
1600                                 }
1601                         }
1602
1603                         if ($self->{CRYPT}) {
1604                                 $self->{PASSWORD} = $self->do_crypt($pw, $db_pass);
1605                         }
1606                         else {
1607                                 $db_pass = lc $db_pass if $self->{OPTIONS}{ignore_case};
1608                         }
1609 #::logDebug(errmsg("crypt: %s", $self->{CRYPT}));
1610 #::logDebug(errmsg("ignore_case: %s", $self->{OPTIONS}{ignore_case}));
1611 #::logDebug(errmsg("given password: %s", $self->{PASSWORD}));
1612 #::logDebug(errmsg("stored password: %s", $db_pass));
1613                         unless ($self->{PASSWORD} eq $db_pass) {
1614                                 $self->log_either(errmsg("Denied attempted login by user '%s' with incorrect password",
1615                                         $self->{USERNAME}));
1616                                 die $stock_error, "\n";
1617                         }
1618                         $self->log_either(errmsg("Successful login by user '%s'", $self->{USERNAME}));
1619                 }
1620
1621                 if($self->{PRESENT}->{ $self->{LOCATION}{EXPIRATION} } ) {
1622                         my $now = time();
1623                         my $cmp = $now;
1624                         $cmp = POSIX::strftime("%Y%m%d%H%M", localtime($now))
1625                                 unless $self->{OPTIONS}->{unix_time};
1626                         my $exp = $udb->field(
1627                                                 $self->{USERNAME},
1628                                                 $self->{LOCATION}{EXPIRATION},
1629                                                 );
1630                         die errmsg("Expiration date not set.") . "\n"
1631                                 if ! $exp and $self->{EMPTY_EXPIRE_FATAL};
1632                         if($exp and $exp < $cmp) {
1633                                 die errmsg("Expired %s.", $exp) . "\n";
1634                         }
1635                 }
1636
1637                 if($self->{PRESENT}->{ $self->{LOCATION}{MERGED_USER} } ) {
1638                         my $old = $self->{USERNAME};
1639                         my $new = $udb->field(
1640                                                 $self->{USERNAME},
1641                                                 $self->{LOCATION}{MERGED_USER},
1642                                                 );
1643                         if($new) {
1644                                 $self->{USERNAME} = $new;
1645                                 my $msg = errmsg('%s logged in as user %s, merged.', $old, $new);
1646                                 Vend::Tags->warnings($msg);
1647                                 $self->log_either($msg);
1648                         }
1649                 }
1650
1651                 if($self->{PRESENT}->{ $self->{LOCATION}{GROUPS} } ) {
1652                         $Vend::groups
1653                         = $Vend::Session->{groups}
1654                         = $udb->field(
1655                                                 $self->{USERNAME},
1656                                                 $self->{LOCATION}{GROUPS},
1657                                                 );
1658                 }
1659
1660                 username_cookies($self->{PASSED_USERNAME} || $self->{USERNAME}, $pw, $self->{OPTIONS}{secure_cookies})
1661                         if $Vend::Cfg->{CookieLogin};
1662
1663                 if ($self->{LOCATION}{LAST} ne 'none') {
1664                         my $now = time();
1665                         my $login_time;
1666                         unless($self->{OPTIONS}{null_time}) {
1667                                 $login_time = $self->{OPTIONS}{iso_time}
1668                                                 ? POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime($now))
1669                                                 : $now;
1670                         }
1671                         eval {
1672                                 $udb->set_field( $self->{USERNAME},
1673                                                                         $self->{LOCATION}{LAST},
1674                                                                         $login_time
1675                                                                         );
1676                         };
1677                         if ($@) {
1678                                 my $msg = errmsg("Failed to record timestamp in UserDB: %s", $@);
1679                                 logError($msg);
1680                                 die $msg, "\n";
1681                         }
1682                 }
1683                 $self->log('login') if $options{'log'};
1684
1685                 $self->get_values() unless $self->{OPTIONS}{no_get};
1686         };
1687
1688         scrub();
1689
1690         if($@) {
1691                 if(defined $self) {
1692                         $self->{ERROR} = $@;
1693                 }
1694                 else {
1695                         logError( "Vend::UserDB error: %s\n", $@ );
1696                 }
1697                 return undef;
1698         }
1699
1700         PRICING: {
1701                 my $pprof;
1702                 last PRICING
1703                         unless  $self->{LOCATION}{PRICING}
1704                         and             $pprof = $user_data->{ $self->{LOCATION}{PRICING} };
1705
1706                 Vend::Interpolate::tag_profile(
1707                                                                 $pprof,
1708                                                                 { tag => $self->{OPTIONS}{profile} },
1709                                                                 );
1710         }
1711
1712         $Vend::login_table = $Vend::Session->{login_table} = $self->{DB_ID};
1713         $Vend::username = $Vend::Session->{username} = $self->{USERNAME};
1714         $Vend::Session->{logged_in} = 1;
1715
1716         if (my $macros = $self->{OPTIONS}{postlogin_action}) {
1717                 eval {
1718                         Vend::Dispatch::run_macro $macros;
1719                 };
1720                 if ($@) {
1721                         logError("UserDB postlogin_action execution error: %s\n", $@);
1722                 }
1723         }
1724
1725         1;
1726 }
1727
1728 sub scrub {
1729         for(qw/ mv_password mv_verify mv_password_old /) {
1730                 delete $CGI::values{$_};
1731                 delete $::Values->{$_};
1732         }
1733 }
1734
1735 sub logout {
1736         my $self = shift or return undef;
1737         scrub();
1738
1739         my $opt = $self->{OPTIONS};
1740
1741         if( is_yes($opt->{clear}) ) {
1742                 $self->clear_values();
1743         }
1744
1745         Vend::Interpolate::tag_profile("", { restore => 1 });
1746         no strict 'refs';
1747
1748         my @dels = qw/
1749                                         groups
1750                                         admin
1751                                         superuser
1752                                         login_table
1753                                         username
1754                                         logged_in
1755                                 /;
1756
1757         for(@dels) {
1758                 delete $Vend::Session->{$_};
1759                 undef ${"Vend::$_"};
1760         }
1761
1762         delete $CGI::values{mv_username};
1763         delete $::Values->{mv_username};
1764         $self->log('logout') if $opt->{log};
1765         $self->{MESSAGE} = errmsg('Logged out.');
1766         if ($opt->{clear_cookie}) {
1767                 my @cookies = split /[\s,\0]+/, $opt->{clear_cookie};
1768                 my $exp = 10;
1769                 for(@cookies) {
1770                         Vend::Util::set_cookie($_, '', $exp);
1771                 }
1772         }
1773         if ($opt->{clear_session}) {
1774                 Vend::Session::init_session();
1775         }
1776         return 1;
1777 }
1778
1779 sub change_pass {
1780
1781         my ($self, $original_self);
1782
1783         $self = shift
1784                 if ref $_[0];
1785
1786         my(%options) = @_;
1787
1788         if ($self->{OPTIONS}{ignore_case}) {
1789            $self->{USERNAME} = lc $self->{USERNAME};
1790            $self->{OLDPASS} = lc $self->{OLDPASS};
1791            $self->{PASSWORD} = lc $self->{PASSWORD};
1792            $self->{VERIFY} = lc $self->{VERIFY};
1793         }
1794
1795         eval {
1796                 # Create copies so that ignore_case doesn't lc the originals.
1797                 my $vend_username = $Vend::username;
1798                 my $cgi_mv_username = $CGI::values{mv_username};
1799                 if ($self->{OPTIONS}{ignore_case}) {
1800                         $vend_username = lc $vend_username;
1801                         $cgi_mv_username = lc $cgi_mv_username
1802                                 if defined $cgi_mv_username;
1803                 }
1804
1805                 # Database operations still use the mixed-case original.
1806                 my $super = $Vend::superuser || (
1807                         $Vend::admin and
1808                         $self->{DB}->field($Vend::username, $self->{LOCATION}{SUPER})
1809                 );
1810
1811                 if ($self->{USERNAME} ne $vend_username or
1812                         defined $cgi_mv_username and
1813                         $self->{USERNAME} ne $cgi_mv_username
1814                 ) {
1815                         if ($super) {
1816                                 if ($cgi_mv_username and
1817                                         $cgi_mv_username ne $self->{USERNAME}) {
1818                                         $original_self = $self;
1819                                         $options{username} = $cgi_mv_username;
1820                                         undef $self;
1821                                 }
1822                         } else {
1823                                 errmsg("Unprivileged user '%s' attempted to change password of user '%s'",
1824                                         $vend_username, $self->{USERNAME}) if $options{log};
1825                                 die errmsg("You are not allowed to change another user's password.");
1826                         }
1827                 }
1828
1829                 unless($self) {
1830                         $self = new Vend::UserDB %options;
1831                 }
1832
1833                 die errmsg("Bad object.") unless defined $self;
1834
1835                 die errmsg("'%s' not a user.", $self->{USERNAME}) . "\n"
1836                         unless $self->{DB}->record_exists($self->{USERNAME});
1837
1838                 unless ($super and $self->{USERNAME} ne $Vend::username) {
1839                         my $db_pass = $self->{DB}->field($self->{USERNAME}, $self->{LOCATION}{PASSWORD});
1840                         if ($self->{CRYPT}) {
1841                                 $self->{OLDPASS} = $self->do_crypt($self->{OLDPASS}, $db_pass);
1842                         }
1843                         die errmsg("Must have old password.") . "\n"
1844                                 if $self->{OLDPASS} ne $db_pass;
1845                 }
1846
1847                 die errmsg("Must enter at least %s characters for password.",
1848                         $self->{PASSMINLEN}) . "\n"
1849                         if length($self->{PASSWORD}) < $self->{PASSMINLEN};
1850                 die errmsg("Password and check value don't match.") . "\n"
1851                         unless $self->{PASSWORD} eq $self->{VERIFY};
1852
1853                 $self->{OPTIONS}{enclair_db} and $self->set_enclair();
1854
1855                 if ( $self->{CRYPT} ) {
1856                         $self->{PASSWORD} = $self->do_crypt(
1857                                 $self->{PASSWORD},
1858                                 Vend::Util::random_string(2),
1859                         );
1860                 }
1861
1862                 my $pass = $self->{DB}->set_field(
1863                                                 $self->{USERNAME},
1864                                                 $self->{LOCATION}{PASSWORD},
1865                                                 $self->{PASSWORD}
1866                                                 );
1867                 die errmsg("Database access error.") . "\n" unless defined $pass;
1868                 $self->log(errmsg('change password')) if $options{'log'};
1869         };
1870
1871         scrub();
1872
1873         $self = $original_self if $original_self;
1874
1875         if($@) {
1876                 if(defined $self) {
1877                         $self->{ERROR} = $@;
1878                         $self->log(errmsg('change password failed')) if $options{'log'};
1879                 }
1880                 else {
1881                         logError( "Vend::UserDB error: %s", $@ );
1882                 }
1883                 return undef;
1884         }
1885
1886         1;
1887 }
1888
1889 sub assign_username {
1890         my $self = shift;
1891         my $file = shift || $self->{OPTIONS}{counter};
1892         my $start = $self->{OPTIONS}{username} || 'U00000';
1893         $file = './etc/username.counter' if ! $file;
1894
1895         my $o = { start => $start, sql => $self->{OPTIONS}{sql_counter} };
1896
1897         my $custno;
1898
1899         if(my $l = $Vend::Cfg->{Accounting}) {
1900
1901                 my $class = $l->{Class};
1902
1903                 my $assign = defined $l->{assign_username} ? $l->{assign_username} : 1;
1904
1905                 if($assign) {
1906 #::logDebug("Accounting class is $class");
1907                 my $obj;
1908                 eval {
1909                                 $obj = $class->new;
1910                 };
1911 #::logDebug("Accounting object is $obj");
1912
1913                 if($@) {
1914                         die errmsg(
1915                                 "Failed to assign new customer number with accounting system %s",
1916                                 $class,
1917                                 );
1918                 }
1919                 $custno = $obj->assign_customer_number();
1920                 }
1921 #::logDebug("assigned new customer number $custno");
1922         }
1923
1924         return $custno || Vend::Interpolate::tag_counter($file, $o);
1925 }
1926
1927 sub new_account {
1928
1929         my $self;
1930
1931         $self = shift
1932                 if ref $_[0];
1933
1934         my(%options) = @_;
1935
1936         eval {
1937                 unless($self) {
1938                         $self = new Vend::UserDB %options;
1939                 }
1940
1941                 delete $Vend::Session->{auto_created_user};
1942
1943                 die errmsg("Bad object.") . "\n" unless defined $self;
1944
1945                 die errmsg("Already logged in. Log out first.") . "\n"
1946                         if $Vend::Session->{logged_in} and ! $options{no_login};
1947                 die errmsg("Sorry, reserved user name.") . "\n"
1948                         if $self->{OPTIONS}{username_mask}
1949                                 and $self->{USERNAME} =~ m!$self->{OPTIONS}{username_mask}!;
1950                 die errmsg("Sorry, user name must be an email address.") . "\n"
1951                         if $self->{OPTIONS}{username_email}
1952                                 and $self->{USERNAME} !~ m!^[[:alnum:]]([.]?([[:alnum:]._-]+)*)?@([[:alnum:]\-_]+\.)+[a-zA-Z]{2,4}$!;
1953                 die errmsg("Must enter at least %s characters for password.",
1954                         $self->{PASSMINLEN}) . "\n"
1955                         if length($self->{PASSWORD}) < $self->{PASSMINLEN};
1956                 die errmsg("Password and check value don't match.") . "\n"
1957                         unless $self->{PASSWORD} eq $self->{VERIFY};
1958
1959                 if ($self->{OPTIONS}{ignore_case}) {
1960                         $self->{PASSWORD} = lc $self->{PASSWORD};
1961                         $self->{USERNAME} = lc $self->{USERNAME};
1962                 }
1963
1964                 my $pw = $self->{PASSWORD};
1965                 if($self->{CRYPT}) {
1966                         eval {
1967                                 $pw = $self->do_crypt($pw, Vend::Util::random_string(2));
1968                         };
1969                 }
1970
1971                 my $udb = $self->{DB};
1972
1973                 if($self->{OPTIONS}{assign_username}) {
1974                         $self->{PASSED_USERNAME} = $self->{USERNAME};
1975                         $self->{USERNAME} = $self->assign_username();
1976                         $self->{USERNAME} = lc $self->{USERNAME}
1977                                 if $self->{OPTIONS}{ignore_case};
1978                 }
1979                 # plain error message without user-supplied username
1980                 # to avoid XSS exploit (RT #306)
1981                 die errmsg("Username contains illegal characters.") . "\n"
1982                         if $self->{USERNAME} !~ m{^$self->{VALIDCHARS}+$};
1983                 die errmsg("Must have at least %s characters in username.",
1984                         $self->{USERMINLEN}) . "\n"
1985                         if length($self->{USERNAME}) < $self->{USERMINLEN};
1986
1987                 if($self->{OPTIONS}{captcha}) {
1988                         my $status = Vend::Tags->captcha( { function => 'check' });
1989                         die errmsg("Must input captcha code correctly.") . "\n"
1990                                 unless $status;
1991                 }
1992
1993                 # Here we put the username in a non-primary key field, checking
1994                 # for existence
1995                 my $foreign = $self->{OPTIONS}{indirect_login};
1996                 if ($foreign) {
1997                         my $uname = ($self->{PASSED_USERNAME} ||= $self->{USERNAME});
1998                         $uname = $udb->quote($uname);
1999                         my $q = "select $foreign from $self->{DB_ID} where $foreign = $uname";
2000                         my $ary = $udb->query($q)
2001                                 or do {
2002                                         my $msg = errmsg( "Database access error for query: %s", $q);
2003                                         die "$msg\n";
2004                                 };
2005                         @$ary == 0
2006                                 or do {
2007                                         my $msg = errmsg( "Username already exists (indirect).");
2008                                         die "$msg\n";
2009                                 };
2010                 }
2011
2012                 if ($udb->record_exists($self->{USERNAME})) {
2013                         die errmsg("Username already exists.") . "\n";
2014                 }
2015
2016                 if($foreign) {
2017                          $udb->set_field(
2018                                                 $self->{USERNAME},
2019                                                 $foreign,
2020                                                 $self->{PASSED_USERNAME},
2021                                                 )
2022                                 or die errmsg("Database access error.");
2023                 }
2024
2025                 $self->{OPTIONS}{enclair_db} and $self->set_enclair();
2026
2027                 my $pass = $udb->set_field(
2028                                                 $self->{USERNAME},
2029                                                 $self->{LOCATION}{PASSWORD},
2030                                                 $pw,
2031                                                 );
2032
2033                 die errmsg("Database access error.") . "\n" unless defined $pass;
2034
2035                 if($self->{OPTIONS}{username_email}) {
2036                         my $field_name = $self->{OPTIONS}{username_email_field} || 'email';
2037                         $::Values->{$field_name} ||= $self->{USERNAME};
2038                         $udb->set_field(
2039                                                 $self->{USERNAME},
2040                                                 $field_name,
2041                                                 $self->{USERNAME},
2042                                                 )
2043                                  or die errmsg("Database access error: %s", $udb->errstr) . "\n";
2044                 }
2045
2046                 my $dfield;
2047                 my $dstring;
2048                 if($dfield = $self->{OPTIONS}{created_date_iso}) {
2049                         if($self->{OPTIONS}{created_date_gmtime}) {
2050                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%SZ', gmtime());
2051                         }
2052                         elsif($self->{OPTIONS}{created_date_showzone}) {
2053                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S %z', localtime());
2054                         }
2055                         else {
2056                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
2057                         }
2058                 }
2059                 elsif($dfield = $self->{OPTIONS}{created_date_epoch}) {
2060                         $dstring = time;
2061                 }
2062
2063                 if($dfield and $dstring) {
2064                         $udb->set_field(
2065                                                 $self->{USERNAME},
2066                                                 $dfield,
2067                                                 $dstring,
2068                                                 )
2069                                 or do {
2070                                         my $msg = errmsg('Failed to set new account creation date: %s', $udb->errstr);
2071                                         Vend::Tags->warnings($msg);
2072                                 };
2073                 }
2074
2075                 if($options{no_login}) {
2076                         $Vend::Session->{auto_created_user} = $self->{USERNAME};
2077                 }
2078                 else {
2079                         $self->set_values() unless $self->{OPTIONS}{no_set};
2080                         $self->{USERNAME} = $foreign if $foreign;
2081                         username_cookies($self->{USERNAME}, $pw, $self->{OPTIONS}{secure_cookies})
2082                                 if $Vend::Cfg->{CookieLogin};
2083
2084                         $self->log('new account') if $options{'log'};
2085                         $self->login()
2086                                 or die errmsg(
2087                                                         "Cannot log in after new account creation: %s",
2088                                                         $self->{ERROR},
2089                                                 );
2090                 }
2091         };
2092
2093         scrub();
2094
2095         if($@) {
2096                 if(defined $self) {
2097                         $self->{ERROR} = $@;
2098                 }
2099                 else {
2100                         logError( "Vend::UserDB error: %s\n", $@ );
2101                 }
2102                 return undef;
2103         }
2104
2105         1;
2106 }
2107
2108 sub username_cookies {
2109                 my ($user, $pw, $secure) = @_;
2110                 return unless
2111                          $CGI::values{mv_cookie_password}               or
2112                          $CGI::values{mv_cookie_username}               or
2113                          Vend::Util::read_cookie('MV_PASSWORD') or
2114                          Vend::Util::read_cookie('MV_USERNAME');
2115                 $::Instance->{Cookies} = [] unless defined $::Instance->{Cookies};
2116                 my $exp = time() + $Vend::Cfg->{SaveExpire};
2117                 $secure ||= $CGI::secure;
2118                 push @{$::Instance->{Cookies}},
2119                         ['MV_USERNAME', $user, $exp];
2120                 return unless
2121                         $CGI::values{mv_cookie_password}                or
2122                         Vend::Util::read_cookie('MV_PASSWORD');
2123                 push @{$::Instance->{Cookies}},
2124                         ['MV_PASSWORD', $pw, $exp, undef, undef, $secure];
2125                 return;
2126 }
2127
2128 sub get_cart {
2129         my($self, %options) = @_;
2130
2131         my $from = $self->{NICKNAME};
2132         my $to;
2133
2134         my $opt = $self->{OPTIONS};
2135
2136         if ($opt->{target}) {
2137                 $to = ($::Carts->{$opt->{target}} ||= []);
2138         }
2139         else {
2140                 $to = $Vend::Items;
2141         }
2142
2143 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($from));
2144
2145         my $field_name = $self->{LOCATION}->{CARTS};
2146         my $cart = [];
2147
2148         eval {
2149                 die errmsg("no from cart name?")                                unless $from;
2150                 die errmsg("%s field not present to get %s", $field_name, $from) . "\n"
2151                                                                                 unless $self->{PRESENT}->{$field_name};
2152
2153                 my $s = $self->{DB}->field( $self->{USERNAME}, $field_name);
2154
2155                 die errmsg("no saved carts.") . "\n" unless $s;
2156
2157                 my @carts = split /\0/, $from;
2158                 my $d = string_to_ref($s);
2159 #::logDebug ("saved carts=" . ::uneval_it($d));
2160
2161                 die errmsg("eval failed?")                              unless ref $d;
2162
2163                 for(@carts) {
2164                         die errmsg("source cart '%s' does not exist.", $from) . "\n" unless ref $d->{$_};
2165                         push @$cart, @{$d->{$_}};
2166                 }
2167
2168         };
2169
2170         if($@) {
2171                 $self->{ERROR} = $@;
2172                 return undef;
2173         }
2174 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($cart));
2175
2176         if($opt->{merge}) {
2177                 $to = [] unless ref $to;
2178                 my %used;
2179                 my %alias;
2180                 my $max;
2181
2182                 for(@$to) {
2183                         my $master;
2184                         next unless $master = $_->{mv_mi};
2185                         $used{$master} = 1;
2186                         $max = $master if $master > $max;
2187                 }
2188
2189                 $max++;
2190
2191                 my $rename;
2192                 my $alias = 100;
2193                 for(@$cart) {
2194                         my $master;
2195                         next unless $master = $_->{mv_mi};
2196                         next unless $used{$master};
2197
2198                         if(! $_->{mv_si}) {
2199                                 $alias{$master} = $max++;
2200                                 $_->{mv_mi} = $alias{$master};
2201                         }
2202                         else {
2203                                 $_->{mv_mi} = $alias{$master};
2204                         }
2205                 }
2206
2207                 push(@$to,@$cart);
2208
2209         }
2210         else {
2211                 @$to = @$cart;
2212         }
2213 }
2214
2215 sub set_cart {
2216         my($self, %options) = @_;
2217
2218         my $from;
2219         my $to   = $self->{NICKNAME};
2220
2221         my $opt = $self->{OPTIONS};
2222
2223         if ($opt->{source}) {
2224                 $from = $::Carts->{$opt->{source}} || [];
2225         }
2226         else {
2227                 $from = $Vend::Items;
2228         }
2229
2230         my $field_name = $self->{LOCATION}->{CARTS};
2231         my ($cart,$s,$d);
2232
2233         eval {
2234                 die errmsg("no to cart name?") . "\n"                                   unless $to;
2235                 die errmsg('%s field not present to set %s', $field_name, $from) . "\n"
2236                                                                                 unless $self->{PRESENT}->{$field_name};
2237
2238                 $d = string_to_ref( $self->{DB}->field( $self->{USERNAME}, $field_name) );
2239
2240                 $d = {} unless $d;
2241
2242                 die errmsg("eval failed?")                              unless ref $d;
2243
2244                 if($opt->{merge}) {
2245                         $d->{$to} = [] unless ref $d->{$to};
2246                         push(@{$d->{$to}}, @{$from});
2247                 }
2248                 else {
2249                 }
2250
2251                 $d->{$to} = $from;
2252
2253                 $s = uneval $d;
2254
2255         };
2256
2257         if($@) {
2258                 $self->{ERROR} = $@;
2259                 return undef;
2260         }
2261
2262         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
2263
2264 }
2265
2266 sub userdb {
2267         my $function = shift;
2268         my $opt = shift;
2269
2270         my %options;
2271
2272         if(ref $opt) {
2273                 %options = %$opt;
2274         }
2275         else {
2276                 %options = ($opt, @_);
2277         }
2278
2279         my $status = 1;
2280         my $user;
2281
2282         my $module = $Vend::Cfg->{UserControl} ? 'Vend::UserControl' : 'Vend::UserDB';
2283
2284         if($function eq 'login') {
2285                 $Vend::Session->{logged_in} = 0;
2286                 delete $Vend::Session->{username};
2287                 delete $Vend::Session->{groups};
2288                 undef $Vend::username;
2289                 undef $Vend::groups;
2290                 undef $Vend::admin;
2291                 $user = $module->new(%options);
2292                 unless (defined $user) {
2293                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2294                         return undef;
2295                 }
2296                 if ($status = $user->login(%options) ) {
2297                         if( $Vend::ReadOnlyCfg->{AdminUserDB}{$user->{PROFILE}} ) {
2298                                 $Vend::admin = 1;
2299                         }
2300                         ::update_user();
2301                 }
2302         }
2303         elsif($function eq 'new_account') {
2304                 $user = $module->new(%options);
2305                 unless (defined $user) {
2306                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2307                         return undef;
2308                 }
2309                 $status = $user->new_account(%options);
2310                 if($status and ! $options{no_login}) {
2311                         $Vend::Session->{logged_in} = 1;
2312                         $Vend::Session->{username} = $user->{USERNAME};
2313                 }
2314         }
2315         elsif($function eq 'logout') {
2316                 $user = $module->new(%options)
2317                         or do {
2318                                 $Vend::Session->{failure} = errmsg("Unable to create user object.");
2319                                 return undef;
2320                         };
2321                 $user->logout();
2322         }
2323         elsif (! $Vend::Session->{logged_in}) {
2324                 $Vend::Session->{failure} = errmsg("Not logged in.");
2325                 return undef;
2326         }
2327         elsif($function eq 'save') {
2328                 $user = $module->new(%options);
2329                 unless (defined $user) {
2330                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2331                         return undef;
2332                 }
2333                 $status = $user->set_values();
2334         }
2335         elsif($function eq 'load') {
2336                 $user = $module->new(%options);
2337                 unless (defined $user) {
2338                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2339                         return undef;
2340                 }
2341                 $status = $user->get_values();
2342         }
2343         else {
2344                 $user = $module->new(%options);
2345                 unless (defined $user) {
2346                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2347                         return undef;
2348                 }
2349                 eval {
2350                         $status = $user->$function(%options);
2351                 };
2352                 $user->{ERROR} = $@ if $@;
2353         }
2354
2355         if(defined $status) {
2356                 delete $Vend::Session->{failure};
2357                 $Vend::Session->{success} = $user->{MESSAGE};
2358                 if($options{show_message}) {
2359                         $status = $user->{MESSAGE};
2360                 }
2361         }
2362         else {
2363                 $Vend::Session->{failure} = $user->{ERROR};
2364                 if($options{show_message}) {
2365                         $status = $user->{ERROR};
2366                 }
2367         }
2368         return $status unless $options{hide};
2369         return;
2370 }
2371
2372 sub do_crypt {
2373         my ($self, $password, $salt) = @_;
2374         my $sub = $self->{ENCSUB};
2375         unless ($sub) {
2376                 for (grep { $self->{OPTIONS}{$_} } keys %enc_subs) {
2377                         $sub = $enc_subs{$_};
2378                         last;
2379                 }
2380                 $self->{ENCSUB} = $sub ||= $enc_subs{default};
2381         }
2382         return $sub->($self, $password, $salt);
2383 }
2384
2385 1;