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