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                                 $::Values->{$_} = $hash->{$_};
 887                         }
 888                 }
 889         }
 890
 891         for(@fields) {
 892                 if($ignore{$_}) {
 893                         $self->{PRESENT}->{$_} = 1;
 894                         next;
 895                 }
 896                 my $val;
 897                 if ($outboard{$_}) {
 898                         my ($t, $c, $k) = split /:+/, $outboard{$_};
 899                         $val = ::tag_data($t, ($c || $_), $outkey, { foreign => $k });
 900                 }
 901                 else {
 902                         $val = $row->{$_};
 903                 }
 904
 905                 my $k;
 906                 if($k = $scratch{$_}) {
 907                         $scratchref->{$k} = $val;
 908                         next;
 909                 }
 910                 elsif($k = $constant{$_}) {
 911                         $constref->{$k} = $val;
 912                         next;
 913                 }
 914                 elsif($k = $session_hash{$_}) {
 915                         $Vend::Session->{$k} = string_to_ref($val) || {};
 916                         next;
 917                 }
 918                 $valref->{$_} = $val;
 919
 920         }
 921
 922         my $area;
 923         foreach $area (qw!SHIPPING BILLING PREFERENCES CARTS!) {
 924                 my $f = $self->{LOCATION}->{$area};
 925                 if ($self->{PRESENT}->{$f}) {
 926                         my $s = $self->get_hash($area);
 927                         die errmsg("Bad structure in %s: %s", $f, $@) if $@;
 928                         $::Values->{$f} = join "\n", sort keys %$s;
 929                 }
 930         }
 931
 932         1;
 933 }
 934
 935 sub set_values {
 936         my($self, $valref, $scratchref) = @_;
 937
 938         $valref = $::Values unless ref($valref);
 939         $scratchref = $::Scratch unless ref($scratchref);
 940
 941         my $user = $self->{USERNAME};
 942
 943         my @fields = @{$self->{DB_FIELDS}};
 944
 945         my $db = $self->{DB};
 946
 947         unless ( $db->record_exists($self->{USERNAME}) ) {
 948                 $self->{ERROR} = errmsg("username %s does not exist.", $self->{USERNAME});
 949                 return undef;
 950         }
 951         my %scratch;
 952         my %constant;
 953         my %session_hash;
 954
 955         if($self->{OPTIONS}->{scratch}) {
 956                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{scratch} ;
 957                 for(@s) {
 958                         my ($k, $v) = split /=/, $_;
 959                         $v ||= $k;
 960                         $scratch{$k} = $v;
 961                 }
 962         }
 963
 964         if($self->{OPTIONS}->{constant}) {
 965                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{constant} ;
 966                 for(@s) {
 967                         my ($k, $v) = split /=/, $_;
 968                         $v ||= $k;
 969                         $constant{$k} = $v;
 970                 }
 971         }
 972
 973         if($self->{OPTIONS}->{session_hash}) {
 974                 my (@s) = grep /\w/, split /[\s,]+/, $self->{OPTIONS}{session_hash} ;
 975                 for(@s) {
 976                         my ($k, $v) = split /=/, $_;
 977                         $v ||= $k;
 978                         $session_hash{$k} = $v;
 979                 }
 980         }
 981
 982         my $val;
 983         my %outboard;
 984         if($self->{OUTBOARD}) {
 985                 %outboard = split /[\s=,]+/, $self->{OUTBOARD};
 986                 push @fields, keys %outboard;
 987         }
 988
 989         my @bfields;
 990         my @bvals;
 991
 992   eval {
 993
 994         my @extra;
 995
 996         if(my $ef = $self->{OPTIONS}->{extra_fields}) {
 997                 my $row = $db->row_hash($user);
 998                 my @s = grep /\w/, split /[\s,]+/, $ef;
 999                 my $field = $self->{LOCATION}{PREFERENCES};
1000                 my $loc   = $self->{OPTIONS}{extra_selector} || 'default';
1001                 my $hash = get_option_hash( $row->{$field} ) || {};
1002
1003                 my $subhash = $hash->{$loc} ||= {};
1004                 for(@s) {
1005                         $subhash->{$_} = $valref->{$_};
1006                 }
1007
1008                 push @extra, $field;
1009                 push @extra, uneval_it($hash);
1010         }
1011
1012         for( @fields ) {
1013 #::logDebug("set_values saving $_ as $valref->{$_}\n");
1014                 my $val;
1015                 my $k;
1016                 if ($k = $scratch{$_}) {
1017                         $val = $scratchref->{$k}
1018                                 if defined $scratchref->{$k};
1019                 }
1020                 elsif ($constant{$_}) {
1021                         # we never store constants
1022                         next;
1023                 }
1024                 elsif ($k = $session_hash{$_}) {
1025                         $val = uneval_it($Vend::Session->{$k});
1026                 }
1027                 else {
1028                         $val = $valref->{$_}
1029                                 if defined $valref->{$_};
1030                 }
1031
1032                 next if ! defined $val;
1033
1034                 if($outboard{$_}) {
1035                         my ($t, $c, $k) = split /:+/, $outboard{$_};
1036                         ::tag_data($t, ($c || $_), $self->{USERNAME}, { value => $val, foreign => $k });
1037                 }
1038                 elsif ($db->test_column($_)) {
1039                         push @bfields, $_;
1040                         push @bvals, $val;
1041                 }
1042                 else {
1043                         ::logDebug( errmsg(
1044                                                         "cannot set unknown userdb field %s to: %s",
1045                                                         $_,
1046                                                         $val,
1047                                                 )
1048                                         );
1049                 }
1050         }
1051
1052         my $dfield;
1053         my $dstring;
1054         if($dfield = $self->{OPTIONS}{updated_date_iso}) {
1055                 if($self->{OPTIONS}{updated_date_gmtime}) {
1056                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%SZ', gmtime());
1057                 }
1058                 elsif($self->{OPTIONS}{updated_date_showzone}) {
1059                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S %z', localtime());
1060                 }
1061                 else {
1062                         $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
1063                 }
1064         }
1065         elsif($dfield = $self->{OPTIONS}{updated_date_epoch}) {
1066                 $dstring = time;
1067         }
1068
1069         if($dfield and $dstring) {
1070                 if($db->test_column($dfield)) {
1071                         push @bfields, $dfield;
1072                         push @bvals, $dstring;
1073                 }
1074                 else {
1075                         my $msg = errmsg("updated field %s doesn't exist", $dfield);
1076                         Vend::Tags->warnings($msg);
1077                 }
1078         }
1079
1080         while(@extra) {
1081                 push @bfields, shift @extra;
1082                 push @bvals, shift @extra;
1083         }
1084
1085 #::logDebug("bfields=" . ::uneval(\@bfields));
1086 #::logDebug("bvals=" . ::uneval(\@bvals));
1087         if(@bfields) {
1088                 $db->set_slice($user, \@bfields, \@bvals);
1089         }
1090   };
1091
1092         if($@) {
1093           my $msg = errmsg("error saving values in userdb: %s", $@);
1094           $self->{ERROR} = $msg;
1095           logError($msg);
1096           return undef;
1097         }
1098
1099 # Changes made to support Accounting Interface.
1100
1101         if(my $l = $Vend::Cfg->{Accounting}) {
1102                 my %hashvar;
1103                 my $indexvar = 0;
1104                 while ($indexvar <= (scalar @bfields)) {
1105                         $hashvar{ $bfields[$indexvar] } = $bvals[$indexvar];
1106                         $indexvar++;
1107                 };
1108                 my $obj;
1109                 my $class = $l->{Class};
1110                 eval {
1111                         $obj = $class->new;
1112                 };
1113
1114                 if($@) {
1115                         die errmsg(
1116                                 "Failed to save customer data with accounting system %s: %s",
1117                                 $class,
1118                                 $@,
1119                                 );
1120                 }
1121                 my $returnval = $obj->save_customer_data($user, \%hashvar);
1122         }
1123
1124         return 1;
1125 }
1126
1127 sub set_billing {
1128         my $self = shift;
1129         my $ref = $self->set_hash('BILLING', @B_FIELDS );
1130         return $ref;
1131 }
1132
1133 sub set_shipping {
1134         my $self = shift;
1135         my $ref = $self->set_hash('SHIPPING', @S_FIELDS );
1136         return $ref;
1137 }
1138
1139 sub set_preferences {
1140         my $self = shift;
1141         my $ref = $self->set_hash('PREFERENCES', @P_FIELDS );
1142         return $ref;
1143 }
1144
1145 sub get_shipping {
1146         my $self = shift;
1147         my $ref = $self->get_hash('SHIPPING', @S_FIELDS );
1148         return $ref;
1149 }
1150
1151 sub get_billing {
1152         my $self = shift;
1153         my $ref = $self->get_hash('BILLING', @B_FIELDS );
1154         return $ref;
1155 }
1156
1157 sub get_preferences {
1158         my $self = shift;
1159         my $ref = $self->get_hash('PREFERENCES', @P_FIELDS );
1160         return $ref;
1161 }
1162
1163 sub get_shipping_names {
1164         my $self = shift;
1165         my $ref = $self->get_hash('SHIPPING');
1166         return undef unless ref $ref;
1167         $::Values->{$self->{LOCATION}{SHIPPING}} = join "\n", sort keys %$ref;
1168         return $::Values->{$self->{LOCATION}{SHIPPING}} if $self->{OPTIONS}{show};
1169         return '';
1170 }
1171
1172 sub get_shipping_hashref {
1173         my $self = shift;
1174         my $ref = $self->get_hash('SHIPPING');
1175         return $ref if ref($ref) eq 'HASH';
1176         return undef;
1177 }
1178
1179 sub get_billing_names {
1180         my $self = shift;
1181         my $ref = $self->get_hash('BILLING');
1182         return undef unless ref $ref;
1183         $::Values->{$self->{LOCATION}{BILLING}} = join "\n", sort keys %$ref;
1184         return $::Values->{$self->{LOCATION}{BILLING}} if $self->{OPTIONS}{show};
1185         return '';
1186 }
1187
1188 sub get_billing_hashref {
1189         my $self = shift;
1190         my $ref = $self->get_hash('BILLING');
1191         return $ref if ref($ref) eq 'HASH';
1192         return undef;
1193 }
1194
1195 sub get_preferences_names {
1196         my $self = shift;
1197         my $ref = $self->get_hash('PREFERENCES');
1198         return undef unless ref $ref;
1199         $::Values->{$self->{LOCATION}{PREFERENCES}} = join "\n", sort keys %$ref;
1200         return $::Values->{$self->{LOCATION}{PREFERENCES}} if $self->{OPTIONS}{show};
1201         return '';
1202 }
1203
1204 sub get_cart_names {
1205         my $self = shift;
1206         my $ref = $self->get_hash('CARTS');
1207         return undef unless ref $ref;
1208         $::Values->{$self->{LOCATION}{CARTS}} = join "\n", sort keys %$ref;
1209         return $::Values->{$self->{LOCATION}{CARTS}} if $self->{OPTIONS}{show};
1210         return '';
1211 }
1212
1213 sub delete_billing {
1214         my $self = shift;
1215         $self->delete_nickname('BILLING', @B_FIELDS );
1216         return '';
1217 }
1218
1219 sub delete_cart {
1220         my $self = shift;
1221         $self->delete_nickname('CARTS', $self->{NICKNAME});
1222         return '';
1223 }
1224
1225 sub delete_shipping {
1226         my $self = shift;
1227         $self->delete_nickname('SHIPPING', @S_FIELDS );
1228         return '';
1229 }
1230
1231 sub delete_preferences {
1232         my $self = shift;
1233         $self->delete_nickname('PREFERENCES', @P_FIELDS );
1234         return '';
1235 }
1236
1237 sub delete_nickname {
1238         my($self, $name, @fields) = @_;
1239
1240         die errmsg("no fields?") unless @fields;
1241         die errmsg("no name?") unless $name;
1242
1243         $self->get_hash($name) unless ref $self->{$name};
1244
1245         my $nick_field = shift @fields;
1246         my $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1247
1248         delete $self->{$name}{$nick};
1249
1250         my $field_name = $self->{LOCATION}->{$name};
1251         unless($self->{PRESENT}->{$field_name}) {
1252                 $self->{ERROR} = errmsg('%s field not present to set %s', $field_name, $name);
1253                 return undef;
1254         }
1255
1256         my $s = uneval_it($self->{$name});
1257
1258         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
1259
1260         return ($s, $self->{$name});
1261 }
1262
1263 sub set_hash {
1264         my($self, $name, @fields) = @_;
1265
1266         die errmsg("no fields?") unless @fields;
1267         die errmsg("no name?") unless $name;
1268
1269         $self->get_hash($name) unless ref $self->{$name};
1270
1271         my $nick_field = shift @fields;
1272         my $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1273         $nick =~ s/^[\0\s]+//;
1274         $nick =~ s/[\0\s]+.*//;
1275         $::Values->{$nick_field} = $nick;
1276         $CGI::values{$nick_field} = $nick if $self->{CGI};
1277
1278         die errmsg("no nickname?") unless $nick;
1279
1280         $self->{$name}{$nick} = {} unless $self->{OPTIONS}{keep}
1281                                                            and    defined $self->{$name}{$nick};
1282
1283         for(@fields) {
1284                 $self->{$name}{$nick}{$_} = $::Values->{$_}
1285                         if defined $::Values->{$_};
1286         }
1287
1288         my $field_name = $self->{LOCATION}->{$name};
1289         unless($self->{PRESENT}->{$field_name}) {
1290                 $self->{ERROR} = errmsg('%s field not present to set %s', $field_name, $name);
1291                 return undef;
1292         }
1293
1294         my $s = uneval_it($self->{$name});
1295
1296         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
1297
1298         return ($s, $self->{$name});
1299 }
1300
1301 sub get_hash {
1302         my($self, $name, @fields) = @_;
1303
1304         my $field_name = $self->{LOCATION}->{$name};
1305         my ($nick, $s);
1306
1307         eval {
1308                 die errmsg("no name?")                                  unless $name;
1309                 die errmsg("%s field not present to get %s", $field_name, $name) . "\n"
1310                                                                                 unless $self->{PRESENT}->{$field_name};
1311
1312                 $s = $self->{DB}->field( $self->{USERNAME}, $field_name);
1313
1314                 if($s) {
1315                         $self->{$name} = string_to_ref($s);
1316                         die errmsg("Bad structure in %s: %s", $field_name, $@) if $@;
1317                 }
1318                 else {
1319                         $self->{$name} = {};
1320                 }
1321
1322                 die errmsg("eval failed?") . "\n"               unless ref $self->{$name};
1323         };
1324
1325         if($@) {
1326                 $self->{ERROR} = $@;
1327                 return undef;
1328         }
1329
1330         return $self->{$name} unless @fields;
1331
1332         eval {
1333                 my $nick_field = shift @fields;
1334                 $nick = $self->{NICKNAME} || $::Values->{$nick_field};
1335                 $nick =~ s/^[\0\s]+//;
1336                 $nick =~ s/[\0\s]+.*//;
1337                 $::Values->{$nick_field} = $nick;
1338                 $CGI::values{$nick_field} = $nick if $self->{CGI};
1339                 die errmsg("no nickname?") unless $nick;
1340         };
1341
1342         if($@) {
1343                 $self->{ERROR} = $@;
1344                 return undef;
1345         }
1346
1347         $self->{$name}->{$nick} = {} unless defined $self->{$name}{$nick};
1348
1349         for(@fields) {
1350                 delete $::Values->{$_};
1351                 $::Values->{$_} = $self->{$name}{$nick}{$_}
1352                         if defined  $self->{$name}{$nick}{$_};
1353                 next unless $self->{CGI};
1354                 $CGI::values{$_} = $::Values->{$_};
1355         }
1356         ::update_user() if $self->{CGI};
1357         return $self->{$name}{$nick};
1358 }
1359
1360 sub login {
1361         my $self;
1362
1363         $self = shift
1364                 if ref $_[0];
1365
1366         my(%options) = @_;
1367         my ($user_data, $pw);
1368
1369         # Show this generic error message on login page to avoid
1370         # helping would-be intruders
1371         my $stock_error = errmsg("Invalid user name or password.");
1372
1373         eval {
1374                 unless($self) {
1375                         $self = new Vend::UserDB %options;
1376                 }
1377
1378                 if($Vend::Cfg->{CookieLogin}) {
1379                         $self->{USERNAME} = Vend::Util::read_cookie('MV_USERNAME')
1380                                 if ! $self->{USERNAME};
1381                         $self->{PASSWORD} = Vend::Util::read_cookie('MV_PASSWORD')
1382                                 if ! $self->{PASSWORD};
1383                 }
1384
1385                 if ($self->{VALIDCHARS} !~ / /) {
1386                         # If space isn't a valid character in usernames,
1387                         # be nice and strip leading and trailing whitespace.
1388                         $self->{USERNAME} =~ s/^\s+//;
1389                         $self->{USERNAME} =~ s/\s+$//;
1390                 }
1391
1392                 if ($self->{OPTIONS}{ignore_case}) {
1393                         $self->{PASSWORD} = lc $self->{PASSWORD};
1394                         $self->{USERNAME} = lc $self->{USERNAME};
1395                 }
1396
1397                 # We specifically check for login attempts with group names to see if
1398                 # anyone is trying to exploit a former vulnerability in the demo catalog.
1399                 if ($self->{USERNAME} =~ /^:/) {
1400                         $self->log_either(errmsg("Denied attempted login with group name '%s'",
1401                                 $self->{USERNAME}));
1402                         die $stock_error, "\n";
1403                 }
1404
1405                 # Username must be long enough
1406                 if (length($self->{USERNAME}) < $self->{USERMINLEN}) {
1407                         $self->log_either(errmsg("Denied attempted login for user name '%s'; must have at least %s characters",
1408                                 $self->{USERNAME}, $self->{USERMINLEN}));
1409                         die $stock_error, "\n";
1410                 }
1411
1412                 # Username must contain only valid characters
1413                 if ($self->{USERNAME} !~ m{^$self->{VALIDCHARS}+$}) {
1414                         $self->log_either(errmsg("Denied attempted login for user name '%s' with illegal characters",
1415                                 $self->{USERNAME}));
1416                         die $stock_error, "\n";
1417                 }
1418
1419                 # Fail if password is too short
1420                 if (length($self->{PASSWORD}) < $self->{PASSMINLEN}) {
1421                         $self->log_either(errmsg("Denied attempted login with user name '%s' and password less than %s characters",
1422                                 $self->{USERNAME}, $self->{PASSMINLEN}));
1423                         die $stock_error, "\n";
1424                 }
1425
1426                 my $udb = $self->{DB};
1427                 my $foreign = $self->{OPTIONS}{indirect_login};
1428
1429                 if($foreign) {
1430                         my $uname = ($self->{PASSED_USERNAME} ||= $self->{USERNAME});
1431                         my $ufield = $self->{LOCATION}{USERNAME};
1432                         $uname = $udb->quote($uname);
1433                         my $q = "select $ufield from $self->{DB_ID} where $foreign = $uname";
1434 #::logDebug("indirect login query: $q");
1435                         my $ary = $udb->query($q)
1436                                 or do {
1437                                         my $msg = errmsg( "Database access error for query: %s", $q);
1438                                         die "$msg\n";
1439                                 };
1440                         @$ary == 1
1441                                 or do {
1442                                         $self->log_either(errmsg(
1443                                                 @$ary ? "Denied attempted login with ambiguous (indirect from %s) user name %s" : "Denied attempted login with nonexistent (indirect from %s) user name %s",
1444                                                 $foreign,
1445                                                 $uname,
1446                                                 $self->{USERNAME},
1447                                         ));
1448                                         die $stock_error, "\n";
1449                                 };
1450                         $self->{USERNAME} = $ary->[0][0];
1451                 }
1452
1453                 # If not superuser, an entry must exist in access database
1454                 unless ($Vend::superuser) {
1455                         unless ($udb->record_exists($self->{USERNAME})) {
1456                                 $self->log_either(errmsg("Denied attempted login with nonexistent user name '%s'",
1457                                         $self->{USERNAME}));
1458                                 die $stock_error, "\n";
1459                         }
1460                         unless ($user_data = $udb->row_hash($self->{USERNAME})) {
1461                                 $self->log_either(errmsg("Login denied after failed fetch of user data for user '%s'",
1462                                         $self->{USERNAME}));
1463                                 die $stock_error, "\n";
1464                         }
1465                         my $db_pass = $user_data->{ $self->{LOCATION}{PASSWORD} };
1466                         unless ($db_pass) {
1467                                 $self->log_either(errmsg("Refusing to use blank password from '%s' database for user '%s'", $self->{DB_ID}, $self->{USERNAME}));
1468                                 die $stock_error, "\n";
1469                         }
1470                         $pw = $self->{PASSWORD};
1471
1472                         if ( $self->{CRYPT} && $self->{OPTIONS}{promote} ) {
1473                                 my ($cur_method) = grep { $self->{OPTIONS}{ $_ } } keys %enc_subs;
1474                                 $cur_method ||= 'default';
1475
1476                                 my $stored_by = $enc_id{ length($db_pass) };
1477
1478                                 if (
1479                                         $cur_method ne $stored_by
1480                                         &&
1481                                         $db_pass eq $enc_subs{$stored_by}->($self, $pw, $db_pass)
1482                                 ) {
1483
1484                                         my $newpass = $enc_subs{$cur_method}->($self, $pw, $db_pass);
1485                                         my $db_newpass = eval {
1486                                                 $self->{DB}->set_field(
1487                                                         $self->{USERNAME},
1488                                                         $self->{LOCATION}{PASSWORD},
1489                                                         $newpass,
1490                                                 );
1491                                         };
1492
1493                                         if ($db_newpass ne $newpass) {
1494                                                 # Usually, an error in the update will cause $db_newpass to be set to a
1495                                                 # useful error string. The usefulness is dependent on DB store itself, though.
1496                                                 my $err_msg = qq{Could not update database "%s" field "%s" with promoted password due to error:\n}
1497                                                         . "%s\n"
1498                                                         . qq{Check that field "%s" is at least %s characters wide.\n};
1499                                                 $err_msg = ::errmsg(
1500                                                         $err_msg,
1501                                                         $self->{DB_ID},
1502                                                         $self->{LOCATION}{PASSWORD},
1503                                                         $DBI::errstr,
1504                                                         $self->{LOCATION}{PASSWORD},
1505                                                         length($newpass),
1506                                                 );
1507                                                 ::logError($err_msg);
1508                                                 die $err_msg;
1509                                         }
1510                                         $db_pass = $newpass;
1511                                 }
1512                         }
1513
1514                         if ($self->{CRYPT}) {
1515                                 $self->{PASSWORD} = $self->do_crypt($pw, $db_pass);
1516                         }
1517                         else {
1518                                 $db_pass = lc $db_pass if $self->{OPTIONS}{ignore_case};
1519                         }
1520 #::logDebug(errmsg("crypt: %s", $self->{CRYPT}));
1521 #::logDebug(errmsg("ignore_case: %s", $self->{OPTIONS}{ignore_case}));
1522 #::logDebug(errmsg("given password: %s", $self->{PASSWORD}));
1523 #::logDebug(errmsg("stored password: %s", $db_pass));
1524                         unless ($self->{PASSWORD} eq $db_pass) {
1525                                 $self->log_either(errmsg("Denied attempted login by user '%s' with incorrect password",
1526                                         $self->{USERNAME}));
1527                                 die $stock_error, "\n";
1528                         }
1529                         $self->log_either(errmsg("Successful login by user '%s'", $self->{USERNAME}));
1530                 }
1531
1532                 if($self->{PRESENT}->{ $self->{LOCATION}{EXPIRATION} } ) {
1533                         my $now = time();
1534                         my $cmp = $now;
1535                         $cmp = POSIX::strftime("%Y%m%d%H%M", localtime($now))
1536                                 unless $self->{OPTIONS}->{unix_time};
1537                         my $exp = $udb->field(
1538                                                 $self->{USERNAME},
1539                                                 $self->{LOCATION}{EXPIRATION},
1540                                                 );
1541                         die errmsg("Expiration date not set.") . "\n"
1542                                 if ! $exp and $self->{EMPTY_EXPIRE_FATAL};
1543                         if($exp and $exp < $cmp) {
1544                                 die errmsg("Expired %s.", $exp) . "\n";
1545                         }
1546                 }
1547
1548                 if($self->{PRESENT}->{ $self->{LOCATION}{MERGED_USER} } ) {
1549                         my $old = $self->{USERNAME};
1550                         my $new = $udb->field(
1551                                                 $self->{USERNAME},
1552                                                 $self->{LOCATION}{MERGED_USER},
1553                                                 );
1554                         if($new) {
1555                                 $self->{USERNAME} = $new;
1556                                 my $msg = errmsg('%s logged in as user %s, merged.', $old, $new);
1557                                 Vend::Tags->warnings($msg);
1558                                 $self->log_either($msg);
1559                         }
1560                 }
1561
1562                 if($self->{PRESENT}->{ $self->{LOCATION}{GROUPS} } ) {
1563                         $Vend::groups
1564                         = $Vend::Session->{groups}
1565                         = $udb->field(
1566                                                 $self->{USERNAME},
1567                                                 $self->{LOCATION}{GROUPS},
1568                                                 );
1569                 }
1570
1571                 username_cookies($self->{PASSED_USERNAME} || $self->{USERNAME}, $pw)
1572                         if $Vend::Cfg->{CookieLogin};
1573
1574                 if ($self->{LOCATION}{LAST} ne 'none') {
1575                         my $now = time();
1576                         my $login_time;
1577                         unless($self->{OPTIONS}{null_time}) {
1578                                 $login_time = $self->{OPTIONS}{iso_time}
1579                                                 ? POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime($now))
1580                                                 : $now;
1581                         }
1582                         eval {
1583                                 $udb->set_field( $self->{USERNAME},
1584                                                                         $self->{LOCATION}{LAST},
1585                                                                         $login_time
1586                                                                         );
1587                         };
1588                         if ($@) {
1589                                 my $msg = errmsg("Failed to record timestamp in UserDB: %s", $@);
1590                                 logError($msg);
1591                                 die $msg, "\n";
1592                         }
1593                 }
1594                 $self->log('login') if $options{'log'};
1595
1596                 $self->get_values() unless $self->{OPTIONS}{no_get};
1597         };
1598
1599         scrub();
1600
1601         if($@) {
1602                 if(defined $self) {
1603                         $self->{ERROR} = $@;
1604                 }
1605                 else {
1606                         logError( "Vend::UserDB error: %s\n", $@ );
1607                 }
1608                 return undef;
1609         }
1610
1611         PRICING: {
1612                 my $pprof;
1613                 last PRICING
1614                         unless  $self->{LOCATION}{PRICING}
1615                         and             $pprof = $user_data->{ $self->{LOCATION}{PRICING} };
1616
1617                 Vend::Interpolate::tag_profile(
1618                                                                 $pprof,
1619                                                                 { tag => $self->{OPTIONS}{profile} },
1620                                                                 );
1621         }
1622
1623         $Vend::login_table = $Vend::Session->{login_table} = $self->{DB_ID};
1624         $Vend::username = $Vend::Session->{username} = $self->{USERNAME};
1625         $Vend::Session->{logged_in} = 1;
1626
1627         if (my $macros = $self->{OPTIONS}{postlogin_action}) {
1628                 eval {
1629                         Vend::Dispatch::run_macro $macros;
1630                 };
1631                 if ($@) {
1632                         logError("UserDB postlogin_action execution error: %s\n", $@);
1633                 }
1634         }
1635
1636         1;
1637 }
1638
1639 sub scrub {
1640         for(qw/ mv_password mv_verify mv_password_old /) {
1641                 delete $CGI::values{$_};
1642                 delete $::Values->{$_};
1643         }
1644 }
1645
1646 sub logout {
1647         my $self = shift or return undef;
1648         scrub();
1649
1650         my $opt = $self->{OPTIONS};
1651
1652         if( is_yes($opt->{clear}) ) {
1653                 $self->clear_values();
1654         }
1655
1656         Vend::Interpolate::tag_profile("", { restore => 1 });
1657         no strict 'refs';
1658
1659         my @dels = qw/
1660                                         groups
1661                                         admin
1662                                         superuser
1663                                         login_table
1664                                         username
1665                                         logged_in
1666                                 /;
1667
1668         for(@dels) {
1669                 delete $Vend::Session->{$_};
1670                 undef ${"Vend::$_"};
1671         }
1672
1673         delete $CGI::values{mv_username};
1674         delete $::Values->{mv_username};
1675         $self->log('logout') if $opt->{log};
1676         $self->{MESSAGE} = errmsg('Logged out.');
1677         if ($opt->{clear_cookie}) {
1678                 my @cookies = split /[\s,\0]+/, $opt->{clear_cookie};
1679                 my $exp = 10;
1680                 for(@cookies) {
1681                         Vend::Util::set_cookie($_, '', $exp);
1682                 }
1683         }
1684         if ($opt->{clear_session}) {
1685                 Vend::Session::init_session();
1686         }
1687         return 1;
1688 }
1689
1690 sub change_pass {
1691
1692         my ($self, $original_self);
1693
1694         $self = shift
1695                 if ref $_[0];
1696
1697         my(%options) = @_;
1698
1699         if ($self->{OPTIONS}{ignore_case}) {
1700            $self->{USERNAME} = lc $self->{USERNAME};
1701            $self->{OLDPASS} = lc $self->{OLDPASS};
1702            $self->{PASSWORD} = lc $self->{PASSWORD};
1703            $self->{VERIFY} = lc $self->{VERIFY};
1704         }
1705
1706         eval {
1707                 # Create copies so that ignore_case doesn't lc the originals.
1708                 my $vend_username = $Vend::username;
1709                 my $cgi_mv_username = $CGI::values{mv_username};
1710                 if ($self->{OPTIONS}{ignore_case}) {
1711                         $vend_username = lc $vend_username;
1712                         $cgi_mv_username = lc $cgi_mv_username
1713                                 if defined $cgi_mv_username;
1714                 }
1715
1716                 # Database operations still use the mixed-case original.
1717                 my $super = $Vend::superuser || (
1718                         $Vend::admin and
1719                         $self->{DB}->field($Vend::username, $self->{LOCATION}{SUPER})
1720                 );
1721
1722                 if ($self->{USERNAME} ne $vend_username or
1723                         defined $cgi_mv_username and
1724                         $self->{USERNAME} ne $cgi_mv_username
1725                 ) {
1726                         if ($super) {
1727                                 if ($cgi_mv_username and
1728                                         $cgi_mv_username ne $self->{USERNAME}) {
1729                                         $original_self = $self;
1730                                         $options{username} = $cgi_mv_username;
1731                                         undef $self;
1732                                 }
1733                         } else {
1734                                 errmsg("Unprivileged user '%s' attempted to change password of user '%s'",
1735                                         $vend_username, $self->{USERNAME}) if $options{log};
1736                                 die errmsg("You are not allowed to change another user's password.");
1737                         }
1738                 }
1739
1740                 unless($self) {
1741                         $self = new Vend::UserDB %options;
1742                 }
1743
1744                 die errmsg("Bad object.") unless defined $self;
1745
1746                 die errmsg("'%s' not a user.", $self->{USERNAME}) . "\n"
1747                         unless $self->{DB}->record_exists($self->{USERNAME});
1748
1749                 unless ($super and $self->{USERNAME} ne $Vend::username) {
1750                         my $db_pass = $self->{DB}->field($self->{USERNAME}, $self->{LOCATION}{PASSWORD});
1751                         if ($self->{CRYPT}) {
1752                                 $self->{OLDPASS} = $self->do_crypt($self->{OLDPASS}, $db_pass);
1753                         }
1754                         die errmsg("Must have old password.") . "\n"
1755                                 if $self->{OLDPASS} ne $db_pass;
1756                 }
1757
1758                 die errmsg("Must enter at least %s characters for password.",
1759                         $self->{PASSMINLEN}) . "\n"
1760                         if length($self->{PASSWORD}) < $self->{PASSMINLEN};
1761                 die errmsg("Password and check value don't match.") . "\n"
1762                         unless $self->{PASSWORD} eq $self->{VERIFY};
1763
1764                 if ( $self->{CRYPT} ) {
1765                         $self->{PASSWORD} = $self->do_crypt(
1766                                 $self->{PASSWORD},
1767                                 Vend::Util::random_string(2),
1768                         );
1769                 }
1770
1771                 my $pass = $self->{DB}->set_field(
1772                                                 $self->{USERNAME},
1773                                                 $self->{LOCATION}{PASSWORD},
1774                                                 $self->{PASSWORD}
1775                                                 );
1776                 die errmsg("Database access error.") . "\n" unless defined $pass;
1777                 $self->log(errmsg('change password')) if $options{'log'};
1778         };
1779
1780         scrub();
1781
1782         $self = $original_self if $original_self;
1783
1784         if($@) {
1785                 if(defined $self) {
1786                         $self->{ERROR} = $@;
1787                         $self->log(errmsg('change password failed')) if $options{'log'};
1788                 }
1789                 else {
1790                         logError( "Vend::UserDB error: %s", $@ );
1791                 }
1792                 return undef;
1793         }
1794
1795         1;
1796 }
1797
1798 sub assign_username {
1799         my $self = shift;
1800         my $file = shift || $self->{OPTIONS}{counter};
1801         my $start = $self->{OPTIONS}{username} || 'U00000';
1802         $file = './etc/username.counter' if ! $file;
1803
1804         my $o = { start => $start, sql => $self->{OPTIONS}{sql_counter} };
1805
1806         my $custno;
1807
1808         if(my $l = $Vend::Cfg->{Accounting}) {
1809
1810                 my $class = $l->{Class};
1811
1812                 my $assign = defined $l->{assign_username} ? $l->{assign_username} : 1;
1813
1814                 if($assign) {
1815 #::logDebug("Accounting class is $class");
1816                 my $obj;
1817                 eval {
1818                                 $obj = $class->new;
1819                 };
1820 #::logDebug("Accounting object is $obj");
1821
1822                 if($@) {
1823                         die errmsg(
1824                                 "Failed to assign new customer number with accounting system %s",
1825                                 $class,
1826                                 );
1827                 }
1828                 $custno = $obj->assign_customer_number();
1829                 }
1830 #::logDebug("assigned new customer number $custno");
1831         }
1832
1833         return $custno || Vend::Interpolate::tag_counter($file, $o);
1834 }
1835
1836 sub new_account {
1837
1838         my $self;
1839
1840         $self = shift
1841                 if ref $_[0];
1842
1843         my(%options) = @_;
1844
1845         eval {
1846                 unless($self) {
1847                         $self = new Vend::UserDB %options;
1848                 }
1849
1850                 delete $Vend::Session->{auto_created_user};
1851
1852                 die errmsg("Bad object.") . "\n" unless defined $self;
1853
1854                 die errmsg("Already logged in. Log out first.") . "\n"
1855                         if $Vend::Session->{logged_in} and ! $options{no_login};
1856                 die errmsg("Sorry, reserved user name.") . "\n"
1857                         if $self->{OPTIONS}{username_mask}
1858                                 and $self->{USERNAME} =~ m!$self->{OPTIONS}{username_mask}!;
1859                 die errmsg("Sorry, user name must be an email address.") . "\n"
1860                         if $self->{OPTIONS}{username_email}
1861                                 and $self->{USERNAME} !~ m!^[[:alnum:]]([.]?([[:alnum:]._-]+)*)?@([[:alnum:]\-_]+\.)+[a-zA-Z]{2,4}$!;
1862                 die errmsg("Must enter at least %s characters for password.",
1863                         $self->{PASSMINLEN}) . "\n"
1864                         if length($self->{PASSWORD}) < $self->{PASSMINLEN};
1865                 die errmsg("Password and check value don't match.") . "\n"
1866                         unless $self->{PASSWORD} eq $self->{VERIFY};
1867
1868                 if ($self->{OPTIONS}{ignore_case}) {
1869                         $self->{PASSWORD} = lc $self->{PASSWORD};
1870                         $self->{USERNAME} = lc $self->{USERNAME};
1871                 }
1872
1873                 my $pw = $self->{PASSWORD};
1874                 if($self->{CRYPT}) {
1875                         eval {
1876                                 $pw = $self->do_crypt($pw, Vend::Util::random_string(2));
1877                         };
1878                 }
1879
1880                 my $udb = $self->{DB};
1881
1882                 if($self->{OPTIONS}{assign_username}) {
1883                         $self->{PASSED_USERNAME} = $self->{USERNAME};
1884                         $self->{USERNAME} = $self->assign_username();
1885                         $self->{USERNAME} = lc $self->{USERNAME}
1886                                 if $self->{OPTIONS}{ignore_case};
1887                 }
1888                 # plain error message without user-supplied username
1889                 # to avoid XSS exploit (RT #306)
1890                 die errmsg("Username contains illegal characters.") . "\n"
1891                         if $self->{USERNAME} !~ m{^$self->{VALIDCHARS}+$};
1892                 die errmsg("Must have at least %s characters in username.",
1893                         $self->{USERMINLEN}) . "\n"
1894                         if length($self->{USERNAME}) < $self->{USERMINLEN};
1895
1896                 if($self->{OPTIONS}{captcha}) {
1897                         my $status = Vend::Tags->captcha( { function => 'check' });
1898                         die errmsg("Must input captcha code correctly.") . "\n"
1899                                 unless $status;
1900                 }
1901
1902                 # Here we put the username in a non-primary key field, checking
1903                 # for existence
1904                 my $foreign = $self->{OPTIONS}{indirect_login};
1905                 if ($foreign) {
1906                         my $uname = ($self->{PASSED_USERNAME} ||= $self->{USERNAME});
1907                         $uname = $udb->quote($uname);
1908                         my $q = "select $foreign from $self->{DB_ID} where $foreign = $uname";
1909                         my $ary = $udb->query($q)
1910                                 or do {
1911                                         my $msg = errmsg( "Database access error for query: %s", $q);
1912                                         die "$msg\n";
1913                                 };
1914                         @$ary == 0
1915                                 or do {
1916                                         my $msg = errmsg( "Username already exists (indirect).");
1917                                         die "$msg\n";
1918                                 };
1919                 }
1920
1921                 if ($udb->record_exists($self->{USERNAME})) {
1922                         die errmsg("Username already exists.") . "\n";
1923                 }
1924
1925                 if($foreign) {
1926                          $udb->set_field(
1927                                                 $self->{USERNAME},
1928                                                 $foreign,
1929                                                 $self->{PASSED_USERNAME},
1930                                                 )
1931                                 or die errmsg("Database access error.");
1932                 }
1933
1934                 my $pass = $udb->set_field(
1935                                                 $self->{USERNAME},
1936                                                 $self->{LOCATION}{PASSWORD},
1937                                                 $pw,
1938                                                 );
1939
1940                 die errmsg("Database access error.") . "\n" unless defined $pass;
1941
1942                 if($self->{OPTIONS}{username_email}) {
1943                         my $field_name = $self->{OPTIONS}{username_email_field} || 'email';
1944                         $::Values->{$field_name} ||= $self->{USERNAME};
1945                         $udb->set_field(
1946                                                 $self->{USERNAME},
1947                                                 $field_name,
1948                                                 $self->{USERNAME},
1949                                                 )
1950                                  or die errmsg("Database access error: %s", $udb->errstr) . "\n";
1951                 }
1952
1953                 my $dfield;
1954                 my $dstring;
1955                 if($dfield = $self->{OPTIONS}{created_date_iso}) {
1956                         if($self->{OPTIONS}{created_date_gmtime}) {
1957                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%SZ', gmtime());
1958                         }
1959                         elsif($self->{OPTIONS}{created_date_showzone}) {
1960                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S %z', localtime());
1961                         }
1962                         else {
1963                                 $dstring = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime());
1964                         }
1965                 }
1966                 elsif($dfield = $self->{OPTIONS}{created_date_epoch}) {
1967                         $dstring = time;
1968                 }
1969
1970                 if($dfield and $dstring) {
1971                         $udb->set_field(
1972                                                 $self->{USERNAME},
1973                                                 $dfield,
1974                                                 $dstring,
1975                                                 )
1976                                 or do {
1977                                         my $msg = errmsg('Failed to set new account creation date: %s', $udb->errstr);
1978                                         Vend::Tags->warnings($msg);
1979                                 };
1980                 }
1981
1982                 if($options{no_login}) {
1983                         $Vend::Session->{auto_created_user} = $self->{USERNAME};
1984                 }
1985                 else {
1986                         $self->set_values() unless $self->{OPTIONS}{no_set};
1987                         $self->{USERNAME} = $foreign if $foreign;
1988                         username_cookies($self->{USERNAME}, $pw)
1989                                 if $Vend::Cfg->{CookieLogin};
1990
1991                         $self->log('new account') if $options{'log'};
1992                         $self->login()
1993                                 or die errmsg(
1994                                                         "Cannot log in after new account creation: %s",
1995                                                         $self->{ERROR},
1996                                                 );
1997                 }
1998         };
1999
2000         scrub();
2001
2002         if($@) {
2003                 if(defined $self) {
2004                         $self->{ERROR} = $@;
2005                 }
2006                 else {
2007                         logError( "Vend::UserDB error: %s\n", $@ );
2008                 }
2009                 return undef;
2010         }
2011
2012         1;
2013 }
2014
2015 sub username_cookies {
2016                 my ($user, $pw) = @_;
2017                 return unless
2018                          $CGI::values{mv_cookie_password}               or
2019                          $CGI::values{mv_cookie_username}               or
2020                          Vend::Util::read_cookie('MV_PASSWORD') or
2021                          Vend::Util::read_cookie('MV_USERNAME');
2022                 $::Instance->{Cookies} = [] unless defined $::Instance->{Cookies};
2023                 my $exp = time() + $Vend::Cfg->{SaveExpire};
2024                 push @{$::Instance->{Cookies}},
2025                         ['MV_USERNAME', $user, $exp];
2026                 return unless
2027                         $CGI::values{mv_cookie_password}                or
2028                         Vend::Util::read_cookie('MV_PASSWORD');
2029                 push @{$::Instance->{Cookies}},
2030                         ['MV_PASSWORD', $pw, $exp];
2031                 return;
2032 }
2033
2034 sub get_cart {
2035         my($self, %options) = @_;
2036
2037         my $from = $self->{NICKNAME};
2038         my $to;
2039
2040         my $opt = $self->{OPTIONS};
2041
2042         if ($opt->{target}) {
2043                 $to = ($::Carts->{$opt->{target}} ||= []);
2044         }
2045         else {
2046                 $to = $Vend::Items;
2047         }
2048
2049 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($from));
2050
2051         my $field_name = $self->{LOCATION}->{CARTS};
2052         my $cart = [];
2053
2054         eval {
2055                 die errmsg("no from cart name?")                                unless $from;
2056                 die errmsg("%s field not present to get %s", $field_name, $from) . "\n"
2057                                                                                 unless $self->{PRESENT}->{$field_name};
2058
2059                 my $s = $self->{DB}->field( $self->{USERNAME}, $field_name);
2060
2061                 die errmsg("no saved carts.") . "\n" unless $s;
2062
2063                 my @carts = split /\0/, $from;
2064                 my $d = string_to_ref($s);
2065 #::logDebug ("saved carts=" . ::uneval_it($d));
2066
2067                 die errmsg("eval failed?")                              unless ref $d;
2068
2069                 for(@carts) {
2070                         die errmsg("source cart '%s' does not exist.", $from) . "\n" unless ref $d->{$_};
2071                         push @$cart, @{$d->{$_}};
2072                 }
2073
2074         };
2075
2076         if($@) {
2077                 $self->{ERROR} = $@;
2078                 return undef;
2079         }
2080 #::logDebug ("to=$to nick=$opt->{target} from=$from cart=" . ::uneval_it($cart));
2081
2082         if($opt->{merge}) {
2083                 $to = [] unless ref $to;
2084                 my %used;
2085                 my %alias;
2086                 my $max;
2087
2088                 for(@$to) {
2089                         my $master;
2090                         next unless $master = $_->{mv_mi};
2091                         $used{$master} = 1;
2092                         $max = $master if $master > $max;
2093                 }
2094
2095                 $max++;
2096
2097                 my $rename;
2098                 my $alias = 100;
2099                 for(@$cart) {
2100                         my $master;
2101                         next unless $master = $_->{mv_mi};
2102                         next unless $used{$master};
2103
2104                         if(! $_->{mv_si}) {
2105                                 $alias{$master} = $max++;
2106                                 $_->{mv_mi} = $alias{$master};
2107                         }
2108                         else {
2109                                 $_->{mv_mi} = $alias{$master};
2110                         }
2111                 }
2112
2113                 push(@$to,@$cart);
2114
2115         }
2116         else {
2117                 @$to = @$cart;
2118         }
2119 }
2120
2121 sub set_cart {
2122         my($self, %options) = @_;
2123
2124         my $from;
2125         my $to   = $self->{NICKNAME};
2126
2127         my $opt = $self->{OPTIONS};
2128
2129         if ($opt->{source}) {
2130                 $from = $::Carts->{$opt->{source}} || [];
2131         }
2132         else {
2133                 $from = $Vend::Items;
2134         }
2135
2136         my $field_name = $self->{LOCATION}->{CARTS};
2137         my ($cart,$s,$d);
2138
2139         eval {
2140                 die errmsg("no to cart name?") . "\n"                                   unless $to;
2141                 die errmsg('%s field not present to set %s', $field_name, $from) . "\n"
2142                                                                                 unless $self->{PRESENT}->{$field_name};
2143
2144                 $d = string_to_ref( $self->{DB}->field( $self->{USERNAME}, $field_name) );
2145
2146                 $d = {} unless $d;
2147
2148                 die errmsg("eval failed?")                              unless ref $d;
2149
2150                 if($opt->{merge}) {
2151                         $d->{$to} = [] unless ref $d->{$to};
2152                         push(@{$d->{$to}}, @{$from});
2153                 }
2154                 else {
2155                 }
2156
2157                 $d->{$to} = $from;
2158
2159                 $s = uneval $d;
2160
2161         };
2162
2163         if($@) {
2164                 $self->{ERROR} = $@;
2165                 return undef;
2166         }
2167
2168         $self->{DB}->set_field( $self->{USERNAME}, $field_name, $s);
2169
2170 }
2171
2172 sub userdb {
2173         my $function = shift;
2174         my $opt = shift;
2175
2176         my %options;
2177
2178         if(ref $opt) {
2179                 %options = %$opt;
2180         }
2181         else {
2182                 %options = ($opt, @_);
2183         }
2184
2185         my $status = 1;
2186         my $user;
2187
2188         my $module = $Vend::Cfg->{UserControl} ? 'Vend::UserControl' : 'Vend::UserDB';
2189
2190         if($function eq 'login') {
2191                 $Vend::Session->{logged_in} = 0;
2192                 delete $Vend::Session->{username};
2193                 delete $Vend::Session->{groups};
2194                 undef $Vend::username;
2195                 undef $Vend::groups;
2196                 undef $Vend::admin;
2197                 $user = $module->new(%options);
2198                 unless (defined $user) {
2199                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2200                         return undef;
2201                 }
2202                 if ($status = $user->login(%options) ) {
2203                         if( $Vend::ReadOnlyCfg->{AdminUserDB}{$user->{PROFILE}} ) {
2204                                 $Vend::admin = 1;
2205                         }
2206                         ::update_user();
2207                 }
2208         }
2209         elsif($function eq 'new_account') {
2210                 $user = $module->new(%options);
2211                 unless (defined $user) {
2212                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2213                         return undef;
2214                 }
2215                 $status = $user->new_account(%options);
2216                 if($status and ! $options{no_login}) {
2217                         $Vend::Session->{logged_in} = 1;
2218                         $Vend::Session->{username} = $user->{USERNAME};
2219                 }
2220         }
2221         elsif($function eq 'logout') {
2222                 $user = $module->new(%options)
2223                         or do {
2224                                 $Vend::Session->{failure} = errmsg("Unable to create user object.");
2225                                 return undef;
2226                         };
2227                 $user->logout();
2228         }
2229         elsif (! $Vend::Session->{logged_in}) {
2230                 $Vend::Session->{failure} = errmsg("Not logged in.");
2231                 return undef;
2232         }
2233         elsif($function eq 'save') {
2234                 $user = $module->new(%options);
2235                 unless (defined $user) {
2236                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2237                         return undef;
2238                 }
2239                 $status = $user->set_values();
2240         }
2241         elsif($function eq 'load') {
2242                 $user = $module->new(%options);
2243                 unless (defined $user) {
2244                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2245                         return undef;
2246                 }
2247                 $status = $user->get_values();
2248         }
2249         else {
2250                 $user = $module->new(%options);
2251                 unless (defined $user) {
2252                         $Vend::Session->{failure} = errmsg("Unable to access user database.");
2253                         return undef;
2254                 }
2255                 eval {
2256                         $status = $user->$function(%options);
2257                 };
2258                 $user->{ERROR} = $@ if $@;
2259         }
2260
2261         if(defined $status) {
2262                 delete $Vend::Session->{failure};
2263                 $Vend::Session->{success} = $user->{MESSAGE};
2264                 if($options{show_message}) {
2265                         $status = $user->{MESSAGE};
2266                 }
2267         }
2268         else {
2269                 $Vend::Session->{failure} = $user->{ERROR};
2270                 if($options{show_message}) {
2271                         $status = $user->{ERROR};
2272                 }
2273         }
2274         return $status unless $options{hide};
2275         return;
2276 }
2277
2278 sub do_crypt {
2279         my ($self, $password, $salt) = @_;
2280         my $sub = $self->{ENCSUB};
2281         unless ($sub) {
2282                 for (grep { $self->{OPTIONS}{$_} } keys %enc_subs) {
2283                         $sub = $enc_subs{$_};
2284                         last;
2285                 }
2286                 $self->{ENCSUB} = $sub ||= $enc_subs{default};
2287         }
2288         return $sub->($self, $password, $salt);
2289 }
2290
2291 1;