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