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