lib/Vend/Form.pm

   1 # Vend::Form - Generate Form widgets
   2 #
   3 # $Id: Form.pm,v 2.77 2009-04-05 19:24:36 mheins Exp $
   4 #
   5 # Copyright (C) 2002-2008 Interchange Development Group
   6 # Copyright (C) 1996-2002 Red Hat, Inc.
   7 #
   8 # This program was originally based on Vend 0.2 and 0.3
   9 # Copyright 1995 by Andrew M. Wilcox <amw@wilcoxsolutions.com>
  10 #
  11 # This program is free software; you can redistribute it and/or modify
  12 # it under the terms of the GNU General Public License as published by
  13 # the Free Software Foundation; either version 2 of the License, or
  14 # (at your option) any later version.
  15 #
  16 # This program is distributed in the hope that it will be useful,
  17 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 # GNU General Public License for more details.
  20 #
  21 # You should have received a copy of the GNU General Public
  22 # License along with this program; if not, write to the Free
  23 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  24 # MA  02110-1301  USA.
  25
  26 package Vend::Form;
  27
  28 require HTML::Entities;
  29 *encode = \&HTML::Entities::encode_entities;
  30 use Vend::Interpolate;
  31 use Vend::Util;
  32 use Vend::Tags;
  33 use strict;
  34 no warnings qw(uninitialized numeric);
  35 use POSIX qw{strftime};
  36
  37 use vars qw/@ISA @EXPORT @EXPORT_OK $VERSION %Template %ExtraMeta/;
  38
  39 require Exporter;
  40 @ISA = qw(Exporter);
  41
  42 $VERSION = substr(q$Revision: 2.77 $, 10);
  43
  44 @EXPORT = qw (
  45         display
  46 );
  47
  48 =head1 NAME
  49
  50 Vend::Form -- Interchange form element routines
  51
  52 =head1 SYNOPSIS
  53
  54 (no external use)
  55
  56 =head1 DESCRIPTION
  57
  58 Provides form element routines for Interchange, emulating the old
  59 tag_accessories stuff. Allows user-added widgets.
  60
  61 =head1 ROUTINES
  62
  63 =cut
  64
  65 my $Some = '(?s:.)*?';
  66 my $Codere = '[-\w#/.]+';
  67 my $Tag = new Vend::Tags;
  68
  69 %Template = (
  70         value =>
  71                 qq({PREPEND}{VALUE}{APPEND})
  72                 ,
  73         selecthead =>
  74                 qq({PREPEND}<select name="{NAME}")
  75                 .
  76                 qq({ROWS?} size="{ROWS}"{/ROWS?})
  77                 .
  78                 qq({DISABLED?} disabled{/DISABLED?})
  79                 .
  80                 qq({TEXTID?} id="{TEXTID}"{/TEXTID?})
  81                 .
  82                 qq({MULTIPLE?} multiple{/MULTIPLE?})
  83                 .
  84                 qq({EXTRA?} {EXTRA}{/EXTRA?})
  85                 .
  86                 qq(>)
  87                 ,
  88         selecttail =>
  89                 qq(</select>{APPEND})
  90                 ,
  91         textarea =>
  92                 qq({PREPEND})
  93                 .
  94                 qq(<textarea name="{NAME}")
  95                 .
  96                 qq({ROWS?} rows="{ROWS}"{/ROWS?})
  97                 .
  98                 qq({COLS?} cols="{COLS}"{/COLS?})
  99                 .
 100                 qq({DISABLED?} disabled{/DISABLED?})
 101                 .
 102                 qq({MAXLENGTH?} maxlength="{MAXLENGTH}"{/MAXLENGTH?})
 103                 .
 104                 qq({TTITLE?} title="{TTITLE}"{/TTITLE?})
 105                 .
 106                 qq({TEXTID?} id="{TEXTID}"{/TEXTID?})
 107                 .
 108                 qq({WRAP?} wrap="{WRAP}"{/WRAP?})
 109                 .
 110                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 111                 .
 112                 qq(>{ENCODED}</textarea>)
 113                         .
 114                 qq({APPEND})
 115                 ,
 116         password =>
 117                 qq({PREPEND}<input type="password" name="{NAME}" value="{ENCODED}")
 118                 .
 119                 qq({COLS?} size="{COLS}"{/COLS?})
 120                 .
 121                 qq({TEXTID?} id="{TEXTID}"{/TEXTID?})
 122                 .
 123                 qq({MAXLENGTH?} maxlength="{MAXLENGTH}"{/MAXLENGTH?})
 124                 .
 125                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 126                 .
 127                 qq(>{APPEND})
 128                 ,
 129         file =>
 130                 qq({PREPEND}<input type="file" name="{NAME}" value="{ENCODED}")
 131                 .
 132                 qq({TTITLE?} title="{TTITLE}"{/TTITLE?})
 133                 .
 134                 qq({TEXTID?} id="{TEXTID}"{/TEXTID?})
 135                 .
 136                 qq({COLS?} size="{COLS}"{/COLS?})
 137                 .
 138                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 139                 .
 140                 qq(>{APPEND})
 141                 ,
 142         filetext =>
 143                 qq({PREPEND}<input type="file" name="{NAME}" value="{ENCODED}")
 144                 .
 145                 qq({TTITLE?} title="{TTITLE}"{/TTITLE?})
 146                 .
 147                 qq({TEXTID?} id="{TEXTID}"{/TEXTID?})
 148                 .
 149                 qq({COLS?} size="{COLS}"{/COLS?})
 150                 .
 151                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 152                 .
 153                 qq(><br{XTRAILER}><textarea cols="{WIDTH}" rows="{HEIGHT}" name="{NAME}">{ENCODED}</textarea>{APPEND})
 154                 ,
 155         text =>
 156                 qq({PREPEND}<input type="text" name="{NAME}" value="{ENCODED}")
 157                 .
 158                 qq({COLS?} size="{COLS}"{/COLS?})
 159                 .
 160                 qq({TTITLE?} title="{TTITLE}"{/TTITLE?})
 161                 .
 162                 qq({TEXTID?} id="{TEXTID}"{/TEXTID?})
 163                 .
 164                 qq({DISABLED?} disabled{/DISABLED?})
 165                 .
 166                 qq({MAXLENGTH?} maxlength="{MAXLENGTH}"{/MAXLENGTH?})
 167                 .
 168                 qq({TTITLE?} title="{TTITLE}"{/TTITLE?})
 169                 .
 170                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 171                 .
 172                 qq(>{APPEND})
 173                 ,
 174         hidden =>
 175                 qq({PREPEND}<input type="hidden" name="{NAME}" value="{ENCODED}")
 176                 .
 177                 qq({TEXTID?} id="{TEXTID}"{/TEXTID?})
 178                 .
 179                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 180                 .
 181                 qq(>{APPEND})
 182                 ,
 183         hiddentext =>
 184                 qq({PREPEND}<input type="hidden" name="{NAME}" value="{ENCODED}")
 185                 .
 186                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 187                 .
 188                 qq(>{FILTERED?}{FILTERED}{/FILTERED?}{FILTERED:}{ENCODED}{/FILTERED:}{APPEND})
 189                 ,
 190         boxstd =>
 191                 qq(<input type="{VARIANT}" name="{NAME}" value="{TVALUE}")
 192                 .
 193                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 194                 .
 195                 qq({TEXTID?} id="{TEXTID}"{/TEXTID?})
 196                 .
 197                 qq({TTITLE?} title="{TTITLE}"{/TTITLE?})
 198                 .
 199                 qq({DISABLED?} disabled{/DISABLED?})
 200                 .
 201                 qq({SELECTED?} checked{/SELECTED?})
 202                 .
 203                 qq(>&nbsp;{TTITLE?}<span title="{TTITLE}">{/TTITLE?}{TEXTID?}<label for="{TEXTID}">{/TEXTID?}{TLABEL}{TEXTID?}</label>{/TEXTID?}{TTITLE?}</span>{/TTITLE?})
 204                 ,
 205         boxnbsp =>
 206                 qq(<input type="{VARIANT}" name="{NAME}" value="{TVALUE}")
 207                 .
 208                 qq({TTITLE?} title="{TTITLE}"{/TTITLE?})
 209                 .
 210                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 211                 .
 212                 qq({DISABLED?} disabled{/DISABLED?})
 213                 .
 214                 qq({SELECTED?} checked{/SELECTED?})
 215                 .
 216                 qq(>&nbsp;{TTITLE?}<span title="{TTITLE}">{/TTITLE?}{TEXTID?}<label for="{TEXTID}">{/TEXTID?}{TLABEL}{TEXTID?}</label>{/TEXTID?}{TTITLE?}</span>{/TTITLE?}&nbsp;&nbsp;)
 217                 ,
 218         boxlabel =>
 219                 qq(<td{TD_LABEL?} {TD_LABEL}{/TD_LABEL?}{TTITLE?} title="{TTITLE}"{/TTITLE?}>)
 220                 .
 221                 qq({FONT?}<font size="{FONT}">{/FONT?})
 222                 .
 223                 qq({TEXTID?}<label for="{TEXTID}">{/TEXTID?}{TLABEL}{TEXTID?}</label>{/TEXTID?}{FONT?}</font>{/FONT?})
 224                 .
 225                 qq(</td>)
 226                 ,
 227         boxvalue =>
 228                 qq(<td{TD_VALUE?} {TD_VALUE}{/TD_VALUE?}>)
 229                 .
 230                 qq(<input type="{VARIANT}" name="{NAME}" value="{TVALUE}")
 231                 .
 232                 qq({TTITLE?} title="{TTITLE}"{/TTITLE?})
 233                 .
 234                 qq({TEXTID?} id="{TEXTID}"{/TEXTID?})
 235                 .
 236                 qq({DISABLED?} disabled{/DISABLED?})
 237                 .
 238                 qq({EXTRA?} {EXTRA}{/EXTRA?})
 239                 .
 240                 qq({SELECTED?} checked{/SELECTED?})
 241                 .
 242                 qq(>)
 243                 .
 244                 qq(</td>)
 245                 ,
 246         boxgroup =>
 247                 qq(</tr><tr><td{TD_GROUP?} {TD_GROUP}{/TD_GROUP?} colspan="2">)
 248                 .
 249                 qq(<b>{TVALUE}</b>)
 250                 .
 251                 qq(</td></tr>)
 252                 ,
 253 );
 254
 255 $Template{default} = $Template{text};
 256
 257 sub attr_list {
 258         my ($body, $hash) = @_;
 259         return $body unless ref($hash) eq 'HASH';
 260
 261         $body =~ s!\{([A-Z_]+)\}!$hash->{lc $1}!g;
 262         $body =~ s!\{([A-Z_]+)\|($Some)\}!$hash->{lc $1} || $2!eg;
 263         $body =~ s!\{([A-Z_]+)\s+($Some)\}! $hash->{lc $1} ? $2 : ''!eg;
 264         1 while $body =~ s!\{([A-Z_]+)\?\}($Some){/\1\?\}! $hash->{lc $1} ? $2 : ''!eg;
 265         1 while $body =~ s!\{([A-Z_]+)\:\}($Some){/\1\:\}! $hash->{lc $1} ? '' : $2!eg;
 266         return $body;
 267 }
 268
 269 sub show_data {
 270         my $opt = shift;
 271         my $ary = shift;
 272         return undef if ! $ary;
 273         my @out;
 274         for(@$ary) {
 275                 push @out, join "=", @$_;
 276         }
 277         my $delim = Vend::Interpolate::get_joiner($opt->{delimiter}, ',');
 278         return join $delim, @out;
 279 }
 280
 281 sub show_options {
 282         my $opt = shift;
 283         my $ary = shift;
 284         my $idx = shift || 0;
 285         return undef if ! $ary;
 286         my @out;
 287         eval {
 288                 @out = map {$_->[$idx]} @$ary;
 289         };
 290         my $delim = Vend::Interpolate::get_joiner($opt->{delimiter}, ',');
 291         return join $delim, @out;
 292 }
 293
 294 sub show_labels {
 295         return show_options($_[0], $_[1], 1);
 296 }
 297
 298 sub template_sub {
 299         my $opt = shift;
 300         return attr_list($Template{$opt->{type}} || $Template{default}, $opt);
 301 }
 302
 303 ## Retrieve the *first* current label
 304 sub current_label {
 305         my($opt, $data) = @_;
 306         my $val;
 307         my $default;
 308         if (defined $opt->{value}) {
 309                 $val = $opt->{value};
 310         }
 311         elsif(defined $opt->{default}) {
 312                 $val = $opt->{default};
 313         }
 314         $val =~ s/\0//;
 315         for(@$data) {
 316                 my ($setting, $label) = @$_;
 317                 $default = $label if $label =~ s/\*$//;
 318                 return ($label || $setting) if $val eq $setting;
 319         }
 320         return $val || $default;
 321 }
 322
 323 sub links {
 324         my($opt, $opts) = @_;
 325
 326         $opt->{joiner} = Vend::Interpolate::get_joiner($opt->{joiner}, "<br$Vend::Xtrailer>");
 327         my $name = $opt->{name};
 328         my $default = defined $opt->{value} ? $opt->{value} : $opt->{default};
 329
 330         $opt->{extra} = " $opt->{extra}" if $opt->{extra};
 331
 332         my $template = $opt->{template} || <<EOF;
 333 <a href="{URL}"{EXTRA}>{SELECTED <b>}{LABEL}{SELECTED </b>}</a>
 334 EOF
 335
 336         my $o_template = $opt->{o_template} || <<EOF;
 337 <b>{TVALUE}</b>
 338 EOF
 339
 340         my $href = $opt->{href} || $Global::Variable->{MV_PAGE};
 341         $opt->{form} = "mv_action=return" unless $opt->{form};
 342
 343         my $no_encode = $opt->{pre_filter} eq 'decode_entities' ? 1 : 0;
 344
 345         my @out;
 346         for(@$opts) {
 347 #warn "iterating links opt $_ = " . uneval_it($_) . "\n";
 348                 my $attr = { extra => $opt->{extra}};
 349
 350                 s/\*$// and $attr->{selected} = 1;
 351
 352                 ($attr->{value},$attr->{label}) = @$_;
 353                 encode($attr->{label}, $ESCAPE_CHARS::std) unless $no_encode;
 354                 if($attr->{value} =~ /^\s*\~\~(.*)\~\~\s*$/) {
 355                         my $lab = $1;
 356                         $lab =~ s/"/&quot;/g;
 357                         $opt->{tvalue} = $lab;
 358                         $opt->{tlabel} = $lab;
 359                         push @out, attr_list($o_template, $opt);
 360                         next;
 361                 }
 362
 363                 next if ! $attr->{value} and ! $opt->{empty};
 364                 if( ! length($attr->{label}) ) {
 365                         $attr->{label} = $attr->{value} or next;
 366                 }
 367
 368                 if ($default) {
 369                         $attr->{selected} = $default eq $attr->{value} ? 1 : '';
 370                 }
 371
 372                 my $form = $opt->{form};
 373
 374                 $attr->{label} =~ s/\s/&nbsp;/g if $opt->{nbsp};
 375
 376                 $attr->{url} = Vend::Interpolate::tag_area(
 377                                                 $href,
 378                                                 undef,
 379                                                 {
 380                                                         form => "$name=$attr->{value}\n$opt->{form}",
 381                                                         secure => $opt->{secure},
 382                                                 },
 383                                                 );
 384                 push @out, attr_list($template, $attr);
 385         }
 386         return join $opt->{joiner}, @out;
 387 }
 388
 389 my @Years;
 390 my @Months;
 391 my @Days;
 392
 393 INITTIME: {
 394         my @t = localtime();
 395         (@Years) = ( $t[5] + 1899 .. $t[5] + 1910 );
 396
 397         for(1 .. 12) {
 398                 $t[4] = $_ - 1;
 399                 $t[3] = 1;
 400                 push @Months, [sprintf("%02d", $_), POSIX::strftime("%B", @t)];
 401         }
 402
 403         for(1 .. 31) {
 404                 push @Days, [sprintf("%02d", $_), $_];
 405         }
 406 }
 407
 408 sub round_to_fifteen {
 409         my $val = shift;
 410 #::logDebug("round_to_fifteen val in=$val");
 411         $val = substr($val, 0, 4);
 412         $val = "0$val" if length($val) == 3;
 413         return '0000' if length($val) < 4;
 414         if($val !~ /(00|15|30|45)$/) {
 415                 my $hr = substr($val, 0, 2);
 416                 $hr =~ s/^0//;
 417                 my $min = substr($val, 2, 2);
 418                 $min =~ s/^0//;
 419                 if($min > 45 and $hr < 23) {
 420                         $hr++;
 421                         $min = 0;
 422                 }
 423                 elsif($min > 30) {
 424                         $min = 45;
 425                 }
 426                 elsif($min > 15) {
 427                         $min = 30;
 428                 }
 429                 elsif($min > 0) {
 430                         $min = 15;
 431                 }
 432                 elsif ($hr == 23) {
 433                         $min = 45;
 434                 }
 435                 else {
 436                         $min = 0;
 437                 }
 438                 $val = sprintf('%02d%02d', $hr, $min);
 439         }
 440 #::logDebug("round_to_fifteen val out=$val");
 441         return $val;
 442 }
 443
 444 sub date_widget {
 445         my($opt) = @_;
 446
 447         my $name = $opt->{name};
 448         my $val  = $opt->{value};
 449
 450         if($val =~ /\D/) {
 451                 $val = Vend::Interpolate::filter_value('date_change', $val);
 452         }
 453         my $now;
 454         if($opt->{time} and $opt->{time_adjust} =~ /([-+]?)(\d+)/) {
 455                 my $sign = $1 || '+';
 456                 my $adjust = $2;
 457                 $adjust *= 3600;
 458                 $now = time;
 459                 $now += $sign eq '+' ? $adjust : -$adjust;
 460         }
 461
 462         my $sel_extra;
 463         my $opt_extra;
 464         for(qw/ class style extra /) {
 465                 my $stag = "select_$_";
 466                 my $otag = "option_$_";
 467                 my $selapp;
 468                 my $optapp;
 469
 470                 if($_ eq 'extra') {
 471                         $selapp = " $opt->{$stag}";
 472                         $optapp = " $opt->{$otag}";
 473                 }
 474                 else {
 475                         $selapp = qq{ $_="$opt->{$stag}"};
 476                         $optapp = qq{ $_="$opt->{$otag}"};
 477                 }
 478                 $sel_extra .= $opt->{$stag} ? $selapp : '';
 479                 $opt_extra .= $opt->{$otag} ? $optapp : '';
 480         }
 481
 482         my @t = localtime($now || time);
 483         my $sel = 0;
 484         my $out = qq{<select name="$name"$sel_extra>};
 485         my $o;
 486         if ($opt->{blank}) {
 487                 $out .= qq{<option value="0"$opt_extra>------</option>};
 488         } elsif (not $val) {
 489                 # use current time with possible adjustments as default value
 490                 $t[2]++ if $t[2] < 23;
 491                 $val = POSIX::strftime("%Y%m%d%H00", @t);
 492         }
 493         for(@Months) {
 494                 $o = qq{<option value="$_->[0]"$opt_extra>} . errmsg($_->[1]) . '</option>';
 495                 ($out .= $o, next) unless ! $sel and $val;
 496                 $o =~ s/>/ SELECTED>/ && $sel++
 497                         if substr($val, 4, 2) eq $_->[0];
 498                 $out .= $o;
 499         }
 500         $sel = 0;
 501         $out .= qq{</select>};
 502         $out .= qq{<input type="hidden" name="$name" value="/">};
 503         $out .= qq{<select name="$name"$sel_extra>};
 504         if ($opt->{blank}) {
 505                 $out .= qq{<option value="0"$opt_extra>--</option>};
 506         }
 507         for(@Days) {
 508                 $o = qq{<option value="$_->[0]"$opt_extra>$_->[1]} . '</option>';
 509                 ($out .= $o, next) unless ! $sel and $val;
 510                 $o =~ s/>/ SELECTED>/ && $sel++
 511                         if substr($val, 6, 2) eq $_->[0];
 512                 $out .= $o;
 513         }
 514         $sel = 0;
 515         $out .= qq{</select>};
 516         $out .= qq{<input type="hidden" name="$name" value="/">};
 517         $out .= qq{<select name="$name"$sel_extra>};
 518
 519         my $cy = $t[5] + 1900;
 520
 521         # If year_begin or year_end are /00+/, make current year
 522         for(qw/ year_begin year_end /) {
 523                 if( length($opt->{$_}) > 1 and $opt->{$_} == 0) {
 524                         $opt->{$_} = $cy;
 525                 }
 526         }
 527
 528         if(my $by = $opt->{year_begin} || $::Variable->{UI_DATE_BEGIN}) {
 529                 my $ey = $opt->{year_end}  || $::Variable->{UI_DATE_END} || ($cy + 10);
 530                 if($by < 100) {
 531                         $by = $cy - abs($by);
 532                 }
 533                 if($ey < 100) {
 534                         $ey += $cy;
 535                 }
 536                 @Years = $by <= $ey ? ($by .. $ey) : reverse ($ey .. $by);
 537         }
 538         if ($opt->{blank}) {
 539                 $out .= qq{<option value="0000"$opt_extra>----</option>};
 540         }
 541         for(@Years) {
 542                 $o = qq{<option$opt_extra>$_} . '</option>';
 543                 ($out .= $o, next) unless ! $sel and $val;
 544                 $o =~ s/>/ SELECTED>/ && $sel++
 545                         if substr($val, 0, 4) eq $_;
 546                 $out .= $o;
 547         }
 548         $out .= qq{</select>};
 549         return $out unless $opt->{time};
 550
 551         $val =~ s/^(\d{8})//;
 552         # If the date is blank (0000-00-00), treat time of 00:00 as blank,
 553         # not midnight, in the option selection below
 554         my $blank_time = ($opt->{blank} and $1 !~ /[1-9]/);
 555         $val =~ s/\D+//g;
 556         $val = round_to_fifteen($val);
 557         $out .= qq{<input type="hidden" name="$name" value=":">};
 558         $out .= qq{<select name="$name"$sel_extra>};
 559         if ($opt->{blank}) {
 560                 $out .= qq{<option value="0"$opt_extra>--:--</option>};
 561         }
 562
 563         my $ampm = defined $opt->{ampm} ? $opt->{ampm} : 1;
 564         my $mod = '';
 565         undef $sel;
 566         my %special = qw/ 0 midnight 12 noon /;
 567
 568         my @min;
 569
 570         $opt->{minutes} ||= '';
 571
 572         if($opt->{minutes} =~ /half/i) {
 573                 @min = (0,30);
 574         }
 575         elsif($opt->{minutes} =~ /hourly/i) {
 576                 @min = (0);
 577         }
 578         elsif($opt->{minutes} =~ /ten/i) {
 579                 @min = (0,10,20,30,40,50);
 580         }
 581         elsif($opt->{minutes} =~ /[\0,]/) {
 582                 @min = grep /^\d+$/ && $_ <= 59, split /[\0,\s]+/, $opt->{minutes};
 583         }
 584         else {
 585                 @min = (0,15,30,45);
 586         }
 587
 588         $opt->{start_hour} ||= 0;
 589         for(qw/start_hour end_hour/) {
 590                 $opt->{$_} = int(abs($opt->{$_}));
 591                 if($opt->{$_} > 23) {
 592                         $opt->{$_} = 0;
 593                 }
 594         }
 595         $opt->{start_hour}      ||= 0;
 596         $opt->{end_hour}        ||= 23;
 597
 598         for my $hr ( $opt->{start_hour} .. $opt->{end_hour} ) {
 599                 next if defined $opt->{start_hour} and $hr < $opt->{start_hour};
 600                 next if defined $opt->{end_hour} and $hr > $opt->{end_hour};
 601                 for my $min ( @min ) {
 602                         my $disp_hour = $hr;
 603                         if($opt->{ampm}) {
 604                                 if( $hr < 12) {
 605                                         $mod = 'am';
 606                                 }
 607                                 else {
 608                                         $mod = 'pm';
 609                                         $disp_hour = $hr - 12 unless $hr == 12;
 610                                 }
 611                                 $mod = errmsg($mod);
 612                                 $mod = " $mod";
 613                         }
 614                         if($special{$hr} and $min == 0) {
 615                                 $disp_hour = errmsg($special{$hr});
 616                         }
 617                         elsif($ampm) {
 618                                 $disp_hour = sprintf("%2d:%02d%s", $disp_hour, $min, $mod);
 619                         }
 620                         else {
 621                                 $disp_hour = sprintf("%02d:%02d", $hr, $min);
 622                         }
 623                         my $time = sprintf "%02d%02d", $hr, $min;
 624                         $o = sprintf qq{<option value="%s"$opt_extra>%s}, $time, $disp_hour;
 625                         ($out .= $o, next) unless ! $sel and $val;
 626 #::logDebug("prospect=$time actual=$val");
 627                         $o =~ s/>/ SELECTED>/ && $sel++
 628                                 if ! $blank_time and $val eq $time;
 629                         $out .= $o;
 630                 }
 631         }
 632         $out .= "</select>";
 633         return $out;
 634 }
 635
 636 sub option_widget_box {
 637         my ($name, $val, $lab, $default, $width) = @_;
 638         my $half = int($width / 2);
 639         my $sel = $default ? ' SELECTED' : '';
 640         $val =~ s/"/&quot;/g;
 641         $lab =~ s/"/&quot;/g;
 642         $width = 10 if ! $width;
 643         return qq{<tr><td><small><input type="text" name="$name" value="$val" size="$half"></small></td><td><small><input type="text" name="$name" value="$lab" size="$width"></small></td><td><small><select name="$name"><option value="0">no<option value="1"$sel>default*</select></small></td></tr>};
 644 }
 645
 646 sub option_widget {
 647         my($opt) = @_;
 648         my($name, $val) = ($opt->{name}, $opt->{value});
 649
 650         my $width = $opt->{width} || 16;
 651         $opt->{filter} = 'option_format'
 652                 unless length($opt->{filter});
 653         $val = Vend::Interpolate::filter_value($opt->{filter}, $val);
 654         my @opts = split /\s*,\s*/, $val;
 655
 656         my $out = qq{<table cellpadding="0" cellspacing="0"><tr><th><small>};
 657         $out .= errmsg('Value');
 658         $out .= qq{</small></th><th align="left" colspan="2"><small>};
 659         $out .= errmsg('Label');
 660         $out .= qq{</small></th></tr>};
 661
 662         my $done;
 663         my $height = $opt->{height} || 5;
 664         $height -= 2;
 665         for(@opts) {
 666                 my ($v,$l) = split /\s*=\s*/, $_, 2;
 667                 next unless $l || length($v);
 668                 $done++;
 669                 my $default;
 670                 ($l =~ s/\*$// or ! $l && $v =~ s/\*$//)
 671                         and $default = 1;
 672                 $out .= option_widget_box($name, $v, $l, $default, $width);
 673         }
 674         while($done++ < $height) {
 675                 $out .= option_widget_box($name, '', '', '', $width);
 676         }
 677         $out .= option_widget_box($name, '', '', '', $width);
 678         $out .= option_widget_box($name, '', '', '', $width);
 679         $out .= "</table>";
 680 }
 681
 682
 683 sub movecombo {
 684         my ($opt, $opts) = @_;
 685         my $name = $opt->{name};
 686         $opt->{name} = "X$name";
 687         my $usenl = $opt->{rows} > 1 ? 1 : 0;
 688         my $only = $opt->{replace} ? 1 : 0;
 689         $opt->{extra} .= qq{ onChange="addItem(this.form['X$name'],this.form['$name'],$usenl,$only)"}
 690             unless $opt->{extra} =~ m/\bonchange\s*=/i;
 691
 692         $opt->{rows} = $opt->{height} unless length($opt->{rows});
 693         $opt->{cols} = $opt->{width} unless length($opt->{cols});
 694
 695         my $tbox = '';
 696         my $out = dropdown($opt, $opts);
 697
 698         my $template = $opt->{o_template} || '';
 699         if(! $template) {
 700                 if($opt->{rows} > 1) {
 701                         $template .= q(<textarea rows="{ROWS|4}" wrap="{WRAP|virtual}");
 702                         $template .= q( cols="{COLS|20}" name="{NAME}">{ENCODED}</textarea>);
 703                 }
 704                 else {
 705                         $template .= qq(<input type="text" size="{COLS||40}");
 706                         $template .= qq( name="{NAME}" value="{ENCODED}">);
 707                 }
 708         }
 709         $opt->{name} = $name;
 710         $tbox = attr_list($template, $opt);
 711
 712         return $opt->{reverse} ? $tbox . $out : $out . $tbox;
 713 }
 714
 715 sub combo {
 716         my ($opt, $opts) = @_;
 717         my $addl;
 718         if($opt->{textarea}) {
 719                 my $template = $opt->{o_template};
 720                 if(! $template) {
 721                         $template = "<br$Vend::Xtrailer>";
 722                         if(! $opt->{rows} or $opt->{rows} > 1) {
 723                                 $template .= q(<textarea rows="{ROWS|2}" wrap="{WRAP|virtual}");
 724                                 $template .= q( cols="{COLS|60}" name="{NAME}">);
 725                                 $template .= '{ENCODED}'
 726                                         unless $opt->{conditional_text} and length($opt->{value}) < 3;
 727                                 $template .= q(</textarea>);
 728                         }
 729                         else {
 730                                 $template .= qq(<input type="text" size="{COLS|40}");
 731                                 $template .= qq( name="{NAME}" value=");
 732                                 $template .= '{ENCODED}'
 733                                         unless $opt->{conditional_text} and length($opt->{value}) < 3;
 734                                 $template .= qq(">);
 735                         }
 736                 }
 737                 $addl = attr_list($template, $opt);
 738         }
 739         else {
 740                 $addl = qq|<input type="text" name="$opt->{name}"|;
 741                 $addl   .= qq| size="$opt->{cols}" value="">|;
 742         }
 743         if($opt->{reverse}) {
 744                 $opt->{append} = length($opt->{append}) ? "$addl$opt->{append}" : $addl;
 745         }
 746         else {
 747                 $opt->{prepend} = length($opt->{prepend}) ? "$opt->{prepend}$addl" : $addl;
 748         }
 749         return dropdown($opt, $opts);
 750 }
 751
 752 sub dropdown {
 753         my($opt, $opts) = @_;
 754 #::logDebug("called select opt=" . ::uneval($opt) . "\nopts=" . ::uneval($opts));
 755         $opt->{multiple} = 1 if $opt->{type} eq 'multiple';
 756
 757         $opts ||= [];
 758
 759         my $price = $opt->{price} || {};
 760
 761         my $select;
 762 #::logDebug("template for selecthead: $Template{selecthead}");
 763 #::logDebug("opt is " . ::uneval($opt));
 764         my $run = attr_list($Template{selecthead}, $opt);
 765 #::logDebug("run is now: $run");
 766         my ($multi, $re_b, $re_e, $regex);
 767 #::logDebug("select multiple=$opt->{multiple}");
 768         if($opt->{multiple}) {
 769                 $multi = 1;
 770                 if($opt->{rawvalue}) {
 771                         $re_b = '(?:\0|^)';
 772                         $re_e = '(?:\0|$)';
 773                 }
 774                 else {
 775                         $re_b = '(?:[\0,\s]|^)';
 776                         $re_e = '(?:[\0,\s]|$)';
 777                 }
 778         }
 779         else {
 780                 $re_b = '^';
 781                 $re_e = '$';
 782         }
 783
 784         my $limit;
 785         if($opt->{cols}) {
 786                 my $cols = $opt->{cols};
 787                 $limit = sub {
 788                         return $_[0] if length($_[0]) <= $cols;
 789                         return substr($_[0], 0, $cols - 2) . '..';
 790                 };
 791         }
 792         else {
 793                 $limit = sub { return $_[0] };
 794         }
 795
 796         my $default = $opt->{value};
 797
 798         my $optgroup_one;
 799         my $no_encode = $opt->{pre_filter} eq 'decode_entities' ? 1 : 0;
 800
 801         for(@$opts) {
 802                 my ($value, $label, $help) = @$_;
 803                 encode($label, $ESCAPE_CHARS::std) unless $no_encode;
 804                 encode($help, $ESCAPE_CHARS::std) if $help;
 805                 if($value =~ /^\s*\~\~(.*)\~\~\s*$/) {
 806                         my $label = $1;
 807                         if($optgroup_one++) {
 808                                 $run .= "</optgroup>";
 809                         }
 810                         $run .= qq{<optgroup label="$label">};
 811                         next;
 812                 }
 813                 $run .= '<option';
 814                 $select = '';
 815
 816                 if($label) {
 817                         $label =~ s/\*$// and $select = 1;
 818                 }
 819                 else {
 820                         $value =~ s/\*$// and $select = 1;
 821                 }
 822
 823                 $select = '' if defined $default;
 824
 825                 my $extra = '';
 826                 my $attr = {};
 827                 if(my $p = $price->{$value}) {
 828                         $attr->{negative} = $p < 0 ? 1 : 0;
 829                         $attr->{price_noformat} = $p;
 830                         $attr->{absolute} = currency(abs($p), undef, 1);
 831                         $attr->{price} = $extra = currency($p, undef, 1);
 832                         $extra = " ($extra)";
 833                 }
 834
 835                 my $vvalue = $value;
 836                 encode($vvalue, $ESCAPE_CHARS::std);
 837                 $run .= qq| value="$vvalue"|;
 838                 $run .= qq| title="$help"| if $help;
 839                 if (length($default)) {
 840                         $regex  = qr/$re_b\Q$value\E$re_e/;
 841                         $default =~ $regex and $select = 1;
 842                 } elsif (defined($default) && length($value) == 0) {
 843                         $select = 1;
 844                 }
 845                 $run .= ' SELECTED' if $select;
 846                 $run .= '>';
 847                 if($opt->{option_template}) {
 848                         $attr->{label} = $label || $value;
 849                         $attr->{value} = $value;
 850                         $run .= attr_list($opt->{option_template}, $attr);
 851                 }
 852                 elsif($label) {
 853                         $run .= $limit->($label);
 854                         $run .= $extra;
 855                 }
 856                 else {
 857                         $run .= $limit->($value);
 858                         $run .= $extra;
 859                 }
 860         }
 861         $run .= "</optgroup>" if $optgroup_one++;
 862         $run .= attr_list($Template{selecttail}, $opt);
 863 }
 864
 865 =head2 yesno
 866
 867 Provides an easy "Yes/No" widget. C<No> returns a value of blank/false,
 868 and C<Yes> returns 1/true.
 869
 870 Calling:
 871
 872   {
 873     name => 'varname' || undef,       ## Derived from item if called by
 874                                        # [PREFIX-options] or [PREFIX-accessories]
 875     type => 'yesno' || 'yesno radio', ## Second is shorthand for variant=>radio
 876     variant => 'radio' || 'select',   ## Default is select
 877   }
 878
 879 The data array passed by C<passed> is never used, it is overwritten
 880 with the equivalent of '=No,1=Yes'. C<No> and C<Yes> are generated from
 881 the locale, so if you want a translated version set those keys in the locale.
 882
 883 If you want another behavior the same widget can be constructed with:
 884
 885         [display passed="=My no,0=My yes" type=select ...]
 886
 887 =cut
 888
 889
 890 sub yesno {
 891         my $opt = shift;
 892         $opt->{value} = is_yes($opt->{value});
 893         my $yes = defined $opt->{yes_value} ? $opt->{yes_value} : 1;
 894         my $no  = defined $opt->{no_value} ? $opt->{no_value} : '';
 895         my $yes_title = defined $opt->{yes_title} ? $opt->{yes_title} : errmsg('Yes');
 896         my $no_title  = defined $opt->{no_title} ? $opt->{no_title} : errmsg('No');
 897         my @opts;
 898         my $routine = $opt->{subwidget} || \&dropdown;
 899         if($opt->{variant} eq 'checkbox') {
 900                 @opts = [$yes, ' '];
 901         }
 902         else {
 903                 @opts = (
 904                                         [$no, $no_title],
 905                                         [$yes, $yes_title],
 906                                 );
 907         }
 908         return $routine->($opt, \@opts);
 909 }
 910
 911 =head2 noyes
 912
 913 Same as C<yesno> except sense is reversed. C<No> returns a value of 1/true,
 914 and C<Yes> returns blank/false.
 915
 916 =cut
 917
 918 sub noyes {
 919         my $opt = shift;
 920         $opt->{value} = is_no($opt->{value});
 921         my @opts = (
 922                                         ['1', errmsg('No')],
 923                                         ['', errmsg('Yes')],
 924                                 );
 925         my $routine = $opt->{subwidget} || \&dropdown;
 926         return $routine->($opt, \@opts);
 927 }
 928
 929 sub box {
 930         my($opt, $opts) = @_;
 931 #::logDebug("Called box type=$opt->{type}");
 932         my $inc = $opt->{breakmod};
 933         my ($xlt, $template, $o_template, $header, $footer, $row_hdr, $row_ftr);
 934
 935         $opt->{variant} ||= $opt->{type};
 936
 937         $header = $template = $footer = $row_hdr = $row_ftr = '';
 938
 939         if($opt->{nbsp}) {
 940                 $xlt = 1;
 941                 $template = $Template{boxnbsp};
 942         }
 943         elsif ($opt->{left}) {
 944                 $header = '<table>';
 945                 $footer = '</table>';
 946                 $template = '<tr>' unless $inc;
 947                 $template .= $Template{boxvalue};
 948                 $template .= $Template{boxlabel};
 949                 $template .= '</tr>' unless $inc;
 950                 $o_template = $Template{boxgroup};
 951         }
 952         elsif ($opt->{right}) {
 953                 $header = '<table>';
 954                 $footer = '</table>';
 955                 $template = '<tr>' unless $inc;
 956                 $template .= $Template{boxlabel};
 957                 $template .= $Template{boxvalue};
 958                 $template .= '</tr>' unless $inc;
 959                 $o_template = $Template{boxgroup};
 960         }
 961         else {
 962                 $template = $Template{boxstd};
 963         }
 964         $o_template ||= "<br$Vend::Xtrailer><b>{TVALUE}</b><br$Vend::Xtrailer>";
 965
 966         my $run = $header;
 967
 968         my $price = $opt->{price} || {};
 969
 970         my $i = 0;
 971         my $default = $opt->{value};
 972         my $no_encode = $opt->{pre_filter} eq 'decode_entities' ? 1 : 0;
 973
 974         for(@$opts) {
 975                 my($value,$label,$help) = @$_;
 976                 encode($label, $ESCAPE_CHARS::std) unless $no_encode;
 977                 encode($help, $ESCAPE_CHARS::std) if $help;
 978                 if($value =~ /^\s*\~\~(.*)\~\~\s*$/) {
 979                         my $lab = $1;
 980                         $lab =~ s/"/&quot;/g;
 981                         $opt->{tvalue} = $lab;
 982                         $opt->{tlabel} = $lab;
 983                         $run .= attr_list($o_template, $opt);
 984                         $i = 0;
 985                         next;
 986                 }
 987                 $value = ''     if ! length($value);
 988                 $label = $value if ! length($label);
 989
 990                 $run .= '<tr>' if $inc && ! ($i % $inc);
 991                 $i++;
 992
 993                 undef $opt->{selected};
 994                 $label =~ s/\*$//
 995                         and $opt->{selected} = 1;
 996                 $opt->{selected} = '' if defined $opt->{value};
 997
 998                 my $extra;
 999                 my $attr = { label => $label, value => $value };
1000                 if(my $p = $price->{$value}) {
1001                         $attr->{negative} = $p < 0 ? 1 : 0;
1002                         $attr->{price_noformat} = $p;
1003                         $attr->{absolute} = currency(abs($p), undef, 1);
1004                         $attr->{price} = $extra = currency($p, undef, 1);
1005                         $label .= "&nbsp;($attr->{price})";
1006                 }
1007
1008                 $value eq ''
1009                         and defined $default
1010                         and $default eq ''
1011                         and $opt->{selected} = 1;
1012
1013                 if(length $value) {
1014                         my $regex       = $opt->{contains}
1015                                                 ? qr/\Q$value\E/
1016                                                 : qr/\b\Q$value\E\b/;
1017                         $default =~ $regex and $opt->{selected} = 1;
1018                 }
1019
1020                 $opt->{tvalue} = encode($value, $ESCAPE_CHARS::std);
1021
1022                 if($opt->{option_template}) {
1023                         $opt->{tlabel} = attr_list($opt->{option_template}, $attr);
1024                         $opt->{tlabel} =~ s/ /&nbsp;/g if $xlt;
1025                 }
1026                 else {
1027                         $label =~ s/ /&nbsp;/g if $xlt;
1028                         $opt->{tlabel} = $label;
1029                 }
1030
1031                 $opt->{ttitle} = $help;
1032
1033                 if($opt->{id}) {
1034                         $opt->{textid} = $opt->{id} . ($value eq '' ? 0 : $value);
1035                         $opt->{textid} =~ s/[^-\w]+//g;
1036                 }
1037
1038                 $run .= attr_list($template, $opt);
1039                 $run .= '</tr>' if $inc && ! ($i % $inc);
1040         }
1041         $run .= $footer;
1042 }
1043
1044 sub options_to_array {
1045         my ($passed, $opt) = @_;
1046         return $passed if ref($passed) eq 'ARRAY'
1047                 and (
1048                         ! scalar @$passed
1049                                 or
1050                         ref($passed->[0]) eq 'ARRAY'
1051                 );
1052
1053         $opt ||= {};
1054         my @out;
1055
1056         if($passed =~ m{^[^=]*\0}) {
1057                 $passed = Vend::Interpolate::filter_value($passed, 'option_format');
1058         }
1059
1060         my $delim = $opt->{delimiter} || ',';
1061         $delim = '\s*' . $delim . '\s*';
1062
1063         if (ref $passed eq 'SCALAR') {
1064                 $passed = [ split /$delim/, $$passed ];
1065         }
1066         elsif(! ref $passed) {
1067                 $passed = [ split /$delim/, $passed ];
1068         }
1069
1070         if (ref $passed eq 'ARRAY') {
1071                 for(@$passed) {
1072                         push @out, [split /\s*=\s*/, HTML::Entities::decode($_), 2];
1073                 }
1074         }
1075         elsif (ref $passed eq 'HASH') {
1076                 my @keys;
1077                 my $sub;
1078                 my $nsub = sub { ($_->{$a} || $a) <=> ($_->{$b} || $b) };
1079                 my $asub = sub { ($_->{$a} || $a) cmp ($_->{$b} || $b) };
1080                 if(! $opt->{sort_option}) {
1081                         $sub = $asub;
1082                 }
1083                 elsif($opt->{sort_option} eq 'none') {
1084                         # do nothing
1085                 }
1086                 elsif($opt->{sort_option} =~ /n/i) {
1087                         $sub = $nsub;
1088                 }
1089                 else {
1090                         $sub = $asub;
1091                 }
1092
1093                 @keys = $sub ? (sort $sub keys %$passed) : (keys %$passed);
1094
1095                 for(@keys) {
1096                         push @out, [$_, $passed->{$_}];
1097                 }
1098         }
1099         else {
1100                 die "bad data type to options_to_array";
1101         }
1102
1103         if ($opt->{applylocale}) {
1104                 for (@out) {
1105                         $_->[1] = errmsg($_->[1]);
1106                 }
1107         }
1108
1109         return \@out;
1110 }
1111
1112 sub display {
1113         my($opt, $item, $data) = @_;
1114
1115 if($opt->{debug}) {
1116         ::logDebug("display called, options=" . uneval($opt));
1117         ::logDebug("item=" . uneval($item)) if $item;
1118 }
1119
1120         if(! ref $opt) {
1121                 ### Has effect of simple default widget for name
1122                 ### or some text output
1123                 if($opt =~ /^$Codere$/) {
1124                         $opt = { name => $opt };
1125                 }
1126                 else {
1127                         return $opt;
1128                 }
1129         }
1130         elsif (ref $opt eq 'ARRAY') {
1131                 ### Handle multiple things passed
1132                 my @out;
1133                 for(@$opt) {
1134                         push @out, display( ref $_ eq 'ARRAY' ? @$_ : ($_));
1135                 }
1136                 return join "", @out;
1137         }
1138
1139         if($opt->{override}) {
1140                 $opt->{value} = $opt->{default};
1141         }
1142
1143         $opt->{default} = $opt->{value}    if defined $opt->{value};
1144
1145         if($opt->{pre_filter} and defined $opt->{value}) {
1146                 $opt->{value} = Vend::Interpolate::filter_value(
1147                                                         $opt->{pre_filter},
1148                                                         $opt->{value},
1149                                                 );
1150         }
1151
1152         my $ishash;
1153         if(ref ($item) eq 'HASH') {
1154 #::logDebug("item=$item");
1155                 $ishash = 1;
1156         }
1157         else {
1158                 $item = get_option_hash($item || $opt->{item});
1159         }
1160 #::logDebug("item=" . ::uneval($item));
1161
1162         # Just in case
1163         $opt  ||= {};
1164         $item ||= {};
1165
1166         ## Set some defaults, can't have attribute or type '0';
1167         ## Note the fact that attribute can take its value from name
1168         ## and vice-versa
1169         $opt->{attribute} ||= $opt->{name};
1170         $opt->{prepend}   = ''  unless defined $opt->{prepend};
1171         $opt->{append}    = ''  unless defined $opt->{append};
1172         $opt->{delimiter} = ',' unless length($opt->{delimiter});
1173         $opt->{cols}      ||= $opt->{width} || $opt->{size};
1174         $opt->{rows}      ||= $opt->{height};
1175
1176         if($opt->{js_check}) {
1177                 my @checks = grep /\w/, split /[\s,\0]+/, $opt->{js_check};
1178                 for(@checks) {
1179                         if(my $sub = Vend::Util::codedef_routine('JavaScriptCheck', $_)) {
1180                                 $sub->($opt);
1181                         }
1182                         else {
1183                                 ::logError('Unknown %s: %s', 'JavaScriptCheck', $_);
1184                         }
1185                 }
1186         }
1187
1188         # This handles the embedded attribute information in certain types,
1189         # for example:
1190         #
1191         #       text_60       is the same as type => 'text', width => '60'
1192         #   datetime_ampm is the same as type => 'datetime', ampm => 1
1193
1194         # Warning -- this sets $opt->{type} and has possible side-effects
1195         #            in $opt
1196         my $type = parse_type($opt);
1197
1198 #::logDebug("name=$opt->{name} type=$type");
1199
1200         my $look;
1201
1202         if($look = $opt->{lookup_query}) {
1203 #::logDebug("lookup_query called, opt=" . uneval($opt));
1204                 my $tab = $opt->{db} || $opt->{table} || $Vend::Cfg->{ProductFiles}[0];
1205                 my $db = Vend::Data::database_exists_ref($tab);
1206                 my @looks = split /\s*;\s*/, $look;
1207                 $data = [];
1208                 for my $l (@looks) {
1209                         next unless $db;
1210                         next unless $l =~ /^\s*select\s+/i;
1211                         my $qr = $db->query($l);
1212                         ref($qr) eq 'ARRAY' and push @$data, @$qr;
1213                 }
1214                 if($data->[0] and @{$data->[0]} > 2) {
1215                         my $j = $opt->{label_joiner} || '-';
1216                         for(@$data) {
1217                                 $_->[1] = join $j, splice @$_, 1;
1218                         }
1219                 }
1220         }
1221         elsif($look = $opt->{lookup}) {
1222 #::logDebug("lookup called, opt=" . uneval($opt));
1223                 LOOK: {
1224                         my $tab = $opt->{db} || $opt->{table} || $Vend::Cfg->{ProductFiles}[0];
1225                         my $db = Vend::Data::database_exists_ref($tab)
1226                                 or last LOOK;
1227                         my $fld = $opt->{field} || $look;
1228                         my $key = $look;
1229
1230                         if($key ne $fld and $fld !~ /,/) {
1231                                 $fld = "$key,$fld";
1232                         }
1233
1234                         my @f = split /\s*,\s*/, $fld;
1235                         my $order = $opt->{sort} || $f[1] || $f[0];
1236                         last LOOK unless $tab;
1237                         my $q = qq{SELECT DISTINCT $fld FROM $tab ORDER BY $order};
1238                         eval {
1239                                 $data = $db->query($q) || die;
1240                                 if(@f > 2) {
1241                                         for(@$data) {
1242                                                 my $join = $opt->{label_joiner} || '-';
1243                                                 my $string = join $join, splice @$_, 1;
1244                                                 $_->[1] = $string;
1245                                         }
1246                                 }
1247                         };
1248                 }
1249         }
1250         elsif($opt->{passed}) {
1251                 $data = options_to_array($opt->{passed}, $opt);
1252         }
1253         elsif(! $opt->{already_got_data} and $opt->{column} and $opt->{table} ) {
1254                 GETDATA: {
1255                         last GETDATA if $opt->{table} eq 'mv_null';
1256                         my $key = $opt->{outboard} || $item->{code} || $opt->{code};
1257                         last GETDATA unless length($key);
1258                         last GETDATA unless ::database_exists_ref($opt->{table});
1259                         $opt->{passed} = $Tag->data($opt->{table}, $opt->{column}, $key)
1260                                 and
1261                         $data = options_to_array($opt->{passed}, $opt);
1262                 }
1263         }
1264
1265         ## This means a lookup was attempted above
1266         if($look and $data) {
1267                 my $ary;
1268                 if($opt->{options}) {
1269                         $ary = options_to_array($opt->{options}, $opt) || [];
1270                 }
1271                 elsif(! scalar(@$data)) {
1272                         $ary = [['', errmsg('--no current values--')]];
1273                 }
1274                 if($opt->{lookup_exclude}) {
1275                         my $re;
1276                         eval {
1277                                 $re = qr/$opt->{lookup_exclude}/;
1278                         };
1279                         if ($@) {
1280                                 logError(
1281                                         "Bad lookup pattern m{%s}: %s", $opt->{lookup_exclude}, $@,
1282                                 );
1283                                 undef $re;
1284                         }
1285
1286                         $re and @$data = grep "$_->[0]=$_->[1]" !~ /$re/, @$data;
1287                 }
1288
1289                 unless($opt->{lookup_merge}) {
1290                         unshift @$data, @$ary if $ary;
1291                 }
1292                 elsif($ary) {
1293                         my %existing;
1294                         for(@$ary) {
1295                                 $existing{$_->[0]}++;
1296                         }
1297                         for(@$data) {
1298                                 next if $existing{$_->[0]};
1299                                 push @$ary, $_;
1300                         }
1301                         $data = $ary;
1302                 }
1303         }
1304
1305 ## Some legacy stuff, has to do with default behavior when called from
1306 ## item-accessories or item-options
1307         if($ishash) {
1308                 my $adder;
1309                 $adder = $item->{mv_ip} if      defined $item->{mv_ip}
1310                                                                 and $opt->{item} || ! $opt->{name};
1311                 $opt->{name} = $opt->{attribute}
1312                         unless $opt->{name};
1313                 $opt->{value} = $item->{$opt->{attribute} || $opt->{name}};
1314                 $opt->{name} .= $adder if defined $adder;
1315 #::logDebug("tag_accessories: name=$opt->{name} ISHASH");
1316         }
1317         else {
1318 #::logDebug("display: name=$opt->{name} IS NOT HASH");
1319                 $opt->{name} = "mv_order_$opt->{attribute}" unless $opt->{name};
1320         }
1321
1322         $opt->{price} = get_option_hash($opt->{price_data})
1323                 if $opt->{price};
1324
1325         $opt->{name} ||= $opt->{attribute};
1326
1327         if(defined $opt->{value}) {
1328                 # do nothing
1329         }
1330         elsif(defined $item->{$opt->{name}}) {
1331            $opt->{value}   = $item->{$opt->{name}};
1332         }
1333         elsif($opt->{cgi_default} and ! $opt->{override}) {
1334                 my $def = $CGI::values{$opt->{name}};
1335                 $opt->{value} = $def if defined($def);
1336         }
1337         elsif($opt->{values_default} and ! $opt->{override}) {
1338                 my $def = $::Values->{$opt->{name}};
1339                 $opt->{value} = $def if defined($def);
1340         }
1341
1342         if($opt->{id}) {
1343                 $opt->{textid} = $opt->{id};
1344         }
1345
1346         $opt->{value} = $opt->{default} if ! defined $opt->{value};
1347
1348         if(length($opt->{blank_default}) and ! length($opt->{value}) ) {
1349                 $opt->{value} = $opt->{blank_default};
1350         }
1351
1352     $opt->{encoded} = encode($opt->{value}, $ESCAPE_CHARS::std);
1353         if($opt->{display_filter}) {
1354                 my $newv = Vend::Interpolate::filter_value(
1355                                                                 $opt->{display_filter},
1356                                                                 $opt->{value},
1357                                                         );
1358                 $opt->{filtered} = encode($newv, $ESCAPE_CHARS::std);
1359         }
1360     $opt->{value} =~ s/&#91;/\[/g if $opt->{enable_itl};
1361
1362         if($opt->{class}) {
1363                 if($opt->{extra}) {
1364                         $opt->{extra} =~ s{(^|\s+)class=(["'])?[^\s'"]+\2}{$1};
1365                         $opt->{extra} =~ s/\s+$//;
1366                         $opt->{extra} .= qq{ class="$opt->{class}"};
1367                 }
1368                 else {
1369                         $opt->{extra} = qq{class="$opt->{class}"};
1370                 }
1371         }
1372
1373         # Optimization for large lists, we cache the widgets
1374         $Vend::UserWidget ||= Vend::Config::map_widgets();
1375         $Vend::UserWidgetDefault ||= Vend::Config::map_widget_defaults();
1376
1377         my $sub =  $Vend::UserWidget->{$type};
1378         if(! $sub and $Global::AccumulateCode) {
1379                 $sub = Vend::Config::code_from_file('Widget', $type)
1380                         and $Vend::UserWidget->{$type} = $sub;
1381         }
1382
1383         # Last in case "default" widget is removed
1384         $sub ||= $Vend::UserWidget->{default} || \&template_sub;
1385
1386         if(my $attr = $Vend::UserWidgetDefault->{$type}) {
1387                 while (my ($k, $v) = each %$attr) {
1388                         next if defined $opt->{$k};
1389                         $opt->{$k} = $v;
1390                 }
1391         }
1392
1393         if($opt->{variant}) {
1394 #::logDebug("variant='$opt->{variant}'");
1395                 $opt->{subwidget}       =  $Vend::UserWidget->{$opt->{variant}}
1396                                                         ||  $Vend::UserWidget->{default};
1397         }
1398
1399         if(my $c = $opt->{check}) {
1400                 $c = "$opt->{name}=$c" unless $c =~ /=/;
1401                 HTML::Entities::encode($c);
1402                 $opt->{append} .= qq{<input type="hidden" name="mv_individual_profile" value="$c">};
1403         }
1404
1405         if($opt->{js}) {
1406                 $opt->{extra} ||= '';
1407                 $opt->{extra} .= " $opt->{js}";
1408                 $opt->{extra} =~ s/^\s+//;
1409         }
1410         return $sub->($opt, $data);
1411 }
1412
1413 sub parse_type {
1414         my $opt = shift;
1415         if(ref($opt) ne 'HASH') {
1416                 warn "parse_type: needs passed hash reference";
1417                 return $opt;
1418         }
1419
1420         my %alias = (qw/ datetime date_time /);
1421         my $type = $opt->{type} = lc($opt->{type}) || 'text';
1422         $type = $alias{$type} if $alias{$type};
1423         return $type if $type =~ /^[a-z][a-z0-9]*$/;
1424
1425         if($type =~ /^text/i) {
1426                 my $cols;
1427                 if ($type =~ /^textarea(?:_(\d+)_(\d+))?(_[a-z]+)?/i) {
1428                         my $rows = $1 || $opt->{rows} || 4;
1429                         $cols = $2 || $opt->{cols} || 40;
1430                         $opt->{type} = 'textarea';
1431                         $opt->{rows} = $rows;
1432                         $opt->{cols} = $cols;
1433                 }
1434                 elsif("\L$type" =~ /^text_?(\d+)$/) {
1435                         $opt->{cols} = $1;
1436                         $opt->{type} = 'text';
1437                 }
1438                 else {
1439                         $opt->{type} = 'text';
1440                 }
1441         }
1442         elsif($type =~ /^(date|time)(.*)/i) {
1443                 $opt->{type} = lc $1;
1444                 my $extra = $2;
1445                 if ($extra) {
1446                         $opt->{time} = 1 if $extra =~ /time/i;
1447                         $opt->{ampm} = 1 if $extra =~ /ampm/i;
1448                         $opt->{blank} = 1 if $extra =~ /blank/i;
1449                         $opt->{year_begin} = $1 if $extra =~ s/year_?begin(\d+)//i;
1450                         $opt->{year_end} = $1 if $extra =~ s/year_?end(\d+)//i;
1451                         ($extra =~ /\(\s*(\s*\d+\s*(,\s*\d+\s*)+)\s*\)/i
1452                                         and $opt->{minutes} = $1)
1453                           or
1454                         ($extra =~ /half/i and $opt->{minutes} = 'half_hourly')
1455                           or
1456                         ($extra =~ /hourly/i and $opt->{minutes} = 'hourly')
1457                           or
1458                         ($extra =~ /tens/i and $opt->{minutes} = 'tens')
1459                         ;
1460                         if($extra =~ s/(\d+)-(\d+)//) {
1461                                 $opt->{start_hour} = $1;
1462                                 $opt->{end_hour} = $2;
1463                         }
1464                         $opt->{time_adjust} = $1
1465                                 if $extra =~ /([+-]?\d+)/i;
1466                 }
1467 #::logDebug("minutes=$opt->{minutes}");
1468         }
1469         elsif($type =~ /^hidden_text/i) {
1470                 $opt->{type} = 'hiddentext';
1471         }
1472         elsif($type =~ /^password/i) {
1473                 $type =~ /(\d+)/ and $opt->{cols} = $1;
1474                 $opt->{type} = 'password';
1475         }
1476         # Ranging type, for price breaks based on quantity
1477         elsif ($type =~ s/^range:?(.*)//) {
1478                 my $select = $1 || 'quantity';
1479                 $opt->{type} = 'range';
1480                 my $default;
1481                 $opt->{default} = $opt->{item}{$select}
1482                          if $opt->{item};
1483         }
1484         elsif ($type =~ /^(radio|check)/i) {
1485                 $opt->{type} = 'box';
1486                 if ($type =~ /check/i) {
1487                         $opt->{type} = 'checkbox';
1488                 }
1489                 else {
1490                         $opt->{type} = 'radio';
1491                 }
1492
1493                 if ($type  =~ /font(?:size)?[\s_]*(-?\d)/i ) {
1494                         $opt->{fontsize} = $1;
1495                 }
1496
1497                 if($type =~ /nbsp/i) {
1498                         $opt->{nbsp} = 1;
1499                 }
1500                 elsif ($type  =~ /left[\s_]*(\d*)/i ) {
1501                         $opt->{breakmod} = $1;
1502                         $opt->{left} = 1;
1503                 }
1504                 elsif ($type  =~ /right[\s_]*(\d*)/i ) {
1505                         $opt->{breakmod} = $1;
1506                         $opt->{right} = 1;
1507                 }
1508         }
1509         elsif($type =~ /^combo[ _]*(?:(\d+)(?:[ _]+(\d+))?)?/i) {
1510                 $opt->{rows} = $opt->{rows} || $1 || 1;
1511                 $opt->{cols} = $opt->{cols} || $2 || 16;
1512                 $opt->{type} = 'combo';
1513         }
1514         elsif($type =~ /^fillin_combo[ _]*(?:(\d+)(?:[ _]+(\d+))?)?/i) {
1515                 $opt->{rows} ||= $1;
1516                 $opt->{cols} ||= $2;
1517                 $opt->{type} = 'combo';
1518                 $opt->{textarea} = 1;
1519                 $opt->{reverse} = 1;
1520                 $opt->{conditional_text} = 1;
1521         }
1522         elsif($type =~ /^reverse_combo[ _]*(?:(\d+)(?:[ _]+(\d+))?)?/i) {
1523                 $opt->{rows} = $opt->{rows} || $1 || 1;
1524                 $opt->{cols} = $opt->{cols} || $2 || 16;
1525                 $opt->{type} = 'combo';
1526                 $opt->{reverse} = 1;
1527         }
1528         elsif($type =~ /^links_*nbsp/i) {
1529                 $opt->{nbsp} = 1;
1530                 $opt->{type} = 'links';
1531         }
1532         elsif($type =~ /^move_*combo[ _]*(?:(\d+)(?:[ _]+(\d+))?)?/i) {
1533                 $opt->{rows} = $opt->{rows} || $opt->{height} || $1 || 1;
1534                 $opt->{cols} = $opt->{cols} || $opt->{width} || $2 || 16;
1535                 $opt->{type} = 'movecombo';
1536                 $opt->{replace} = 1 if $type =~ /replace/;
1537         }
1538         elsif($type =~ /multi/i) {
1539                 $opt->{type} = 'select';
1540                 $opt->{multiple} = 1;
1541                 $type =~ /.*?multiple\s+(.*)/
1542                         and $opt->{extra} ||= $1;
1543         }
1544         elsif($type =~ /^yesno/i) {
1545                 $type =~ s/^yesno[_\s]+//;
1546                 $opt->{type}    = 'yesno';
1547                 $type =~ s/\W+//g;
1548                 $opt->{variant} = $type =~ /radio/ ? 'radio' : $type;
1549         }
1550         elsif($type =~ /^noyes/i) {
1551                 $type =~ s/^noyes[_\s]+//;
1552                 $opt->{type}    = 'noyes';
1553                 $type =~ s/\W+//g;
1554                 $opt->{variant} = $type =~ /radio/ ? 'radio' : $type;
1555         }
1556
1557         return $opt->{type};
1558 }
1559
1560 1;