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