Interchange Reference Pages: Tags


For a complete introduction to the Interchange Tag Language and the supported syntax, please see the ITL glossary entry.

Table of Contents

accessories — access to product options attributes
accounting
add-gpg-key — add a GPG/PGP key to keyring
address
area — produce a hypertext link URL
assign — assign overrides for salestax, shipping, handling and subtotal
assume-identity — override value of MV_PAGE on a page
attr_list
auto-wizard
available_ups_internal
available_www_shipping
backup-database — backup Interchange databases, even rows selectively
backup-file — backup Interchange file
banner — display banner ads or messages, based on category and optional weighting
bar-button — display content (usually a menu bar) based on page name
base-url — retrieve value of the VendURL directive
bootmenu
breadcrumbs
button — create HTML or JavaScript form submit button
calc — evaluate the enclosed arithmetic expression or Perl block
calcn — evaluate the enclosed arithmetic expression or Perl block
captcha — handle captcha images used for authentication
capture_page — process page and save output to file and/or scratch variable
cart — set the current shopping cart
catch — handle failed 'try' blocks
cgi — expand to value of the CGI variable specified in body
charge — perform a transaction with a payment gateway
check-upload
checked — indicate checked status of checkboxes
child-process
comment — comment (disable) parts of Interchange or HTML code
component — display component
content-editor
content-info
content-modify
control — Retrieve component attributes
control-set — Retrieve component attributes
convert-date — convert date to a specified format
counter — manipulate a persistent, named counter
cp — copy a file
crypt — run Unix crypt() function on input data
css — generate CSS file and create a link to it
currency — format number as currency, honoring default or specified locale
data — get or set value of a named field or row from a database table or user session
db-date — report last-modified time of the named database source file
db-hash
db_columns — retrieve column names from a database table
debug — send messages to debug log
default — (deprecated) return content of the named form input field, defaulting to value 'default'
delete_cart — delete shopping cart from UserDB
deliver — deliver arbritary content verbatim, without Interchange processing
description — return description for a specific product from the products database
diff
diffmerge
directive_value
discount — implement per-customer item or order discounts
discount_space
dispatch
display — display HTML form element
div-organize
dump — display dump of current session
dump_session — dump named user session partially or in whole
either
email — send e-mail using SendMailProgram
email-raw — send raw-formatted e-mail using SendMailProgram
env — provides read-only access to the HTTP environment variables
error — display and manipulate errors stored in session
evalue — return encoded content of the named form input field
export — export a database to a text file
export-database
fcounter
field — quickly retrieve field from Products database
file — include file into the current page verbatim
file-info — retrieve file information
file-navigator
filter — apply one or multiple filters
flag
flag_job
flex-select — tabular overview for a database table
fly-list — display item in a flypage-like fashion
fly-tax
form-session-id — insert hidden form field containing the session ID
formel — generate HTML form elements
fortune — use the "fortune" program to display random saying
forum — display forum threads
forum-userlink
get-gpg-keys — lists GPG keys
get-url — dispatch HTTP request and return response
global-value
grep-mm
handling — calculate and display handling costs
harness
history-scan — generate link to (or just display name of) a previously visited page
href
html-table — output HTML table
if — conditional parsing
if-mm — check permissions for UI tasks
if_not_volatile
image — general purpose tag for generating HTML <img> tags
import — import records into database
import_fields
include — include file into the current page and reparse contents for tags
index
input-filter — add or remove filters applied to CGI variables
item-list — iterate through items in the cart
jsonq
jsq — return a string for use in JavaScript, quoted and with variables substituted
jsqn — return a string for use in JavaScript, quoted, without variables substituted
jsquote
l
labeled_data_row
levies — display total cost of levy charges
levy-list — display a list of levy charges
list-databases
list-keys
list_glob — list files matching a pattern
list_pages — list pages
load_cart — load shopping cart from UserDB
loc — localize provided input
local
log — write custom message to arbitrary log file
logger
loop — iterate through a list
loop_list
mail
menu — displays HTML menu
menu-load
meta-info
meta-record
mm-value — display UI access control value
mm_locale
more_list — pagination for Interchange lists
msg
mvasp
newer
nitems — return the total number of items in the electronic cart
object
onfly
options
order — produce an order link
output-to — map output
page — produce a hypertext link
page-meta
parse_locale
pay-cert
pay-cert-redeem
perl — evaluate embedded Perl code
price — calculate product price
process
process-order
process-target
profile — set UserDB profile
query — run SQL query
quick_table
rand — return random element from an arbitrarily-separated list
read-cookie — reads browser cookie
read-shipping
reconfig
reconfig-time
record
region
report-table
return_to
rotate-table
row
row-edit
run-profile — runs form profile
salestax — display salestax for products within cart
save_cart — save shopping cart to UserDB
scratch — return content of the named scratch variable
scratchd — return value of scratch variable, then delete the variable
search
search-region — container for search results
search_region
selected — identicate selected status of HTML options
self_contained_if
set — set value of scratch variable, without interpolation
set-cookie — sets browser cookie
seti — set value of scratch variable, with interpolation
setlocale — Change current locale
shipping — display shipping cost for items in electronic cart
shipping-desc — displays shipping mode description
shipping-description
soap
soap_entity
sort_ary
sort_hash
sql_list
strip — trim leading and trailing whitespace
su
substitute_file
subtotal — display total cost of products within cart
summary
tabbed-display
table-editor — table editor
table-organize — automatically organize table cells into rows or columns
tag
time — display formatted date, similar to strftime POSIX function
timed-build — save output of Interchange interpolation to named file (cache pages)
timed-display
title-bar
tmp — temporarily set value of scratch variable, with interpolation
tmpn — temporarily set value of scratch variable, without interpolation
tn
total-cost — display total cost of electronic cart, including all adjustments
traffic-report
tree — display tree-like structure from database
try — safely execute a code block and test for errors
ts
tv
uc-attr-list — replaces placeholders in curly braces with provided values
uneval
uninstall_feature
unless
unlink_file — safely delete a file within catalog root directory
unpack — unpacks mapped output into template
update — refresh specific set of internal data
update-order-status
ups-query
user-merge
userdb — access user database functions
usertrack — append usertrack entry with arbitrary key=value pair
usps-query
value — expand to value of the UserDB variable specified in body
value-extended — Expand value
value_extended
values-space — switch between value namespaces
var — access local (catalog) and global Interchange variables
version — print all sorts of Interchange-related system information
warning — display and manipulate warnings stored in session
warnings — display and manipulate warnings stored in session
weight — calculate total weight of items in shopping cart
widget
widget-info — Access information for a particular widget
widget-meta
write-relative-file — save content to a filename inside the catalog directory
write-shipping

Name

accessories — access to product options attributes

ATTRIBUTES

AttributePos.Req.DefaultDescription
code | row | key Yes
arg Yes Comma-separated list of values to use in setting attribute, type, column, table, name, outboard and passed arguments.
column | col | field Value of attribute=
attribute Value of name=
outboard Value of code=
table | db | base | database
passed If table= specified, then [data table column code], else [data products column code]
type select
attribute Value of name=
default
override
pre_filter
display_filter
item
item
prepend
append
delimiter
rows
cols
js_check
js
lookup_query
lookup_exclude
lookup_merge
lookup
label_joiner -
sort -
options -
price_data
value
cgi_default
values_default
blank_default
price_data
class
extra Value of class=
variant
check
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The accessories tag is the "swiss army-knife" tool for choosing or displaying Interchange's product options (also called attributes, of which typical examples are size or color).

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

The default item options can be set via UseModifier.

See the attribute glossary entry for a complete introduction to item options.

AVAILABILITY

accessories is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/accessories.coretag
Lines: 21


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: accessories.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag accessories         Order        code arg
UserTag accessories         addAttr
UserTag accessories         attrAlias    db table
UserTag accessories         attrAlias    base table
UserTag accessories         attrAlias    database table
UserTag accessories         attrAlias    col column
UserTag accessories         attrAlias    row code
UserTag accessories         attrAlias    field column
UserTag accessories         attrAlias    key code
UserTag accessories         PosNumber    2
UserTag accessories         Version      $Revision: 1.4 $
UserTag accessories         MapRoutine   Vend::Interpolate::tag_accessories

Source: lib/Vend/Interpolate.pm
Lines: 1543

sub tag_accessories {
my($code,$extra,$opt,$item) = @_;

my $ishash;
if(ref $item) {
#::logDebug("tag_accessories: item is a hash");
  $ishash = 1;
}

# Had extra if got here
#::logDebug("tag_accessories: code=$code opt=" . uneval_it($opt) . " item=" \
 . uneval_it($item) . " extra=$extra");
my($attribute, $type, $field, $db, $name, $outboard, $passed);
$opt = {} if ! $opt;
if($extra) {
  $extra =~ s/^\s+//;
  $extra =~ s/\s+$//;
  @{$opt}{qw/attribute type column table name outboard passed/} =
    split /\s*,\s*/, $extra;
}
($attribute, $type, $field, $db, $name, $outboard, $passed) = 
  @{$opt}{qw/attribute type column table name outboard passed/};

## Code only passed when we are a product
if($code) {
  GETACC: {
    my $col =  $opt->{column} || $opt->{attribute};
    my $key = $opt->{outboard} || $code;
    last GETACC if ! $col;
    if($opt->{table}) {
      $opt->{passed} ||= tag_data($opt->{table}, $col, $key);
    }
    else {
      $opt->{passed} ||= product_field($col, $key);
    }
  }

  return unless $opt->{passed} || $opt->{type};
  $opt->{type} ||= 'select';
  return unless
    $opt->{passed}
      or
    $opt->{type} =~ /^(text|password|hidden)/i;
}

return Vend::Form::display($opt, $item);
}

Source: lib/Vend/Interpolate.pm
Lines: 1543

sub tag_accessories {
my($code,$extra,$opt,$item) = @_;

my $ishash;
if(ref $item) {
#::logDebug("tag_accessories: item is a hash");
  $ishash = 1;
}

# Had extra if got here
#::logDebug("tag_accessories: code=$code opt=" . uneval_it($opt) . " item=" \
 . uneval_it($item) . " extra=$extra");
my($attribute, $type, $field, $db, $name, $outboard, $passed);
$opt = {} if ! $opt;
if($extra) {
  $extra =~ s/^\s+//;
  $extra =~ s/\s+$//;
  @{$opt}{qw/attribute type column table name outboard passed/} =
    split /\s*,\s*/, $extra;
}
($attribute, $type, $field, $db, $name, $outboard, $passed) = 
  @{$opt}{qw/attribute type column table name outboard passed/};

## Code only passed when we are a product
if($code) {
  GETACC: {
    my $col =  $opt->{column} || $opt->{attribute};
    my $key = $opt->{outboard} || $code;
    last GETACC if ! $col;
    if($opt->{table}) {
      $opt->{passed} ||= tag_data($opt->{table}, $col, $key);
    }
    else {
      $opt->{passed} ||= product_field($col, $key);
    }
  }

  return unless $opt->{passed} || $opt->{type};
  $opt->{type} ||= 'select';
  return unless
    $opt->{passed}
      or
    $opt->{type} =~ /^(text|password|hidden)/i;
}

return Vend::Form::display($opt, $item);
}

SEE ALSO


Name

accounting

ATTRIBUTES

AttributePos.Req.DefaultDescription
function Yes
system
can_do_function
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

accounting is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/accounting.coretag
Lines: 81


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: accounting.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag accounting Order   function
UserTag accounting addAttr
UserTag accounting Version $Revision: 1.5 $
UserTag accounting Routine <<EOR
my %account_super = (qw/
noparts_update 1
/);
my %account_admin = (qw/
inventory_update 1
/);

sub {
my ($func, $opt) = @_;

use vars qw/$Tag/;
die "Accounting not enabled!"
  unless $Vend::Cfg->{Accounting};

my $enable;
if($account_super{$func}) {
  eval {
    $enable = $Vend::admin && $Tag->if_mm('super');
  };
}
elsif($account_admin{$func}) {
  $enable = $Vend::admin;
}
else {
  $enable = 1;
}

if(! $enable) {
  die errmsg("Function '%s' not enabled for current user level.", $func);
}

if(my $sys = $opt->{system}) {
  my $former = $Vend::Cfg->{Accounting};
  $Vend::Cfg->{Accounting} = $Vend::Cfg->{Accounting_repository}{$sys}
    or do {
      logError(
        "Failed to change accounting system to %s, returning to %s.",
        $opt->{system},
        $former->{Class},
      );
      $Vend::Cfg->{Accounting} = $former;
      return undef;
    };
}

my $a = $Vend::Cfg->{Accounting} 
  or do {
    logError("No accounting system present. Aborting.");
    return undef;
  };

my $class = $a->{Class};
my $self = new $class;
my $can;
unless( $can = $self->can($func) ) {
  logError(
    "No function '%s' in accounting system %s. Aborting.",
    $func,
    $class,
  );
  return undef;
}

return $can if $opt->{can_do_function};

return $self->$func($opt);
}
EOR

SEE ALSO


Name

add-gpg-key — add a GPG/PGP key to keyring

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Name of the CGI variable where the key text can be found.
text GPG/PGP key text, specified in-place. If defined, takes precedence over the CGI variable pointed to by the name= attribute.
return_id 0 Return key ID upon import?
success 1 Value to return if key import action succeeds.
failure undef Value to return if key import action fails.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag imports a GPG/PGP key into the keyring.

Key text can either be specified in-place, or a name of the CGI variable containing the key text can be provided.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: GPG_PATH

EXAMPLES

Example: Importing a key by specifying CGI variable containing key text

[add-gpg-key name=pgpkeytext return_id=1 failure=FAILED]


Example: Importing a key by specifying key text in-place

[add-gpg-key text="[value pgpkeytext]" return_id=1 failure=FAILED]


NOTES

AVAILABILITY

add-gpg-key is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/add_gpg_key.coretag
Lines: 67


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: add_gpg_key.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag add-gpg-key Order   name
UserTag add-gpg-key addAttr
UserTag add-gpg-key Version $Revision: 1.6 $
UserTag add-gpg-key Routine <<EOR
sub {
my ($name, $opt) = @_;
my $gpgexe = $Global::Variable->{GPG_PATH} || 'gpg';

my $outfile = "$Vend::Cfg->{ScratchDir}/$Vend::Session->{id}.gpg_results";

my $flags = "--import --batch 2> $outfile";
#::logDebug("gpg_add flags=$flags");

my $keytext = $opt->{text} || $CGI::values{$name};
$keytext =~ s/^\s+//;
$keytext =~ s/\s+$//;
open(GPGIMP, "| $gpgexe $flags") 
  or die "Can't fork: $!";
print GPGIMP $keytext;
close GPGIMP;

if($?) {
  $::Scratch->{ui_failure} = ::errmsg("Failed GPG key import.");
  return defined $opt->{failure} ? $opt->{failure} : undef;
}
else {
  my $keylist = `$gpgexe --list-keys`;
  $::Scratch->{ui_message} =
            ::errmsg(
              "GPG key imported successfully.<PRE>\n%s\n</PRE>",
              $keylist,
              );
}

if($opt->{return_id}) {
  open(GETGPGID, "< $outfile")
    or do {
      ::logGlobal("GPG key ID read -- can't read %s: %s", $outfile, $!);
      return undef;
    };
  my $id;
  while(<GETGPGID>) {
    next unless /\bkey\s+(\w+)\s*:\s+(public\s+key|)(.*)(imported|not\s+changed)/i;
    $id = $1;
    last;
  }
  close GETGPGID;
  return $id || 'Failed ID get?';
  
}
elsif (defined $opt->{success}) {
  return $opt->{success};
}
else {
  return 1;
}
}
EOR

SEE ALSO


Name

address —

ATTRIBUTES

AttributePos.Req.DefaultDescription
if false
billing false
[ nickname | nick ]
username
address_label
address_book
joiner <br>
no_address false
widget false
set false
textarea false
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

address is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 3912

sub tag_address {
my ($count, $item, $hash, $opt, $body) = @_;
#::logDebug("in ship_address");
return pull_else($body) if defined $opt->{if} and ! $opt->{if};
return pull_else($body) if ! $Vend::username || ! $Vend::Session->{logged_in};
#::logDebug("logged in with usernam=$Vend::username");

my $tag = 'address';
my $attr = 'mv_ad';
my $nattr = 'mv_an';
my $pre = '';
if($opt->{billing}) {
  $tag = 'b_address';
  $attr = 'mv_bd';
  $nattr = 'mv_bn';
  $pre = 'b_';
}

#  if($item->{$attr} and ! $opt->{set}) {
#    my $pre = $opt->{prefix};
#    $pre =~ s/[-_]/[-_]/g;
#    $body =~ s:\[$pre\]($Some)\[/$pre\]:$item->{$attr}:g;
#    return pull_if($body);
#  }

my $nick = $opt->{nick} || $opt->{nickname} || $item->{$nattr};

#::logDebug("nick=$nick");

my $user;
if(not $user = $Vend::user_object) {
   $user = new Vend::UserDB username => ($opt->{username} || $Vend::username);
}
#::logDebug("user=$user");
! $user and return pull_else($body);

my $blob = $user->get_hash('SHIPPING')   or return pull_else($body);
#::logDebug("blob=$blob");
my $addr = $blob->{$nick};

if (! $addr) {
  %$addr = %{ $::Values };
}

#::logDebug("addr=" . uneval($addr));

$addr->{mv_an} = $nick;
my @nick = sort keys %$blob;
my $label;
if($label = $opt->{address_label}) {
  @nick = sort { $blob->{$a}{$label} cmp  $blob->{$a}{$label} } @nick;
  @nick = map { "$_=" . ($blob->{$_}{$label} || $_) } @nick;
  for(@nick) {
    s/,/&#44;/g;
  }
}
$opt->{blank} = '--select--' unless $opt->{blank};
unshift(@nick, "=$opt->{blank}");
$opt->{address_book} = join ",", @nick
  unless $opt->{address_book};

my $joiner = get_joiner($opt->{joiner}, "<br$Vend::Xtrailer>");
if(! $opt->{no_address}) {
  my @vals = map { $addr->{$_} }
        grep /^address_?\d*$/ && length($addr->{$_}), keys %$addr;
  $addr->{address} = join $joiner, @vals;
}

if($opt->{widget}) {
  $addr->{address_book} = tag_accessories(
                $item->{code},
                undef,
                {
                  attribute => $nattr,
                  type => $opt->{widget},
                  passed => $opt->{address_book},
                  form => $opt->{form},
                },
                $item
                );
}

if($opt->{set} || ! $item->{$attr}) {
  my $template = '';
  if($::Variable->{MV_SHIP_ADDRESS_TEMPLATE}) {
    $template .= $::Variable->{MV_SHIP_ADDRESS_TEMPLATE};
  }
  else {
    $template .= "{company}\n" if $addr->{"${pre}company"};
    $template .= <<EOF;
{address}
{city}, {state} {zip} 
{country} -- {phone_day}
EOF
  }
  $template =~ s/{(\w+.*?)}/{$pre$1}/g if $pre;
  $addr->{mv_ad} = $item->{$attr} = tag_attr_list($template, $addr);
}
else {
  $addr->{mv_ad} = $item->{$attr};
}

if($opt->{textarea}) {
  $addr->{textarea} = tag_accessories(
                $item->{code},
                undef,
                {
                  attribute => $attr,
                  type => 'textarea',
                  rows => $opt->{rows} || '4',
                  cols => $opt->{cols} || '40',
                },
                $item
                );
}

$body =~ s:\[$tag\]($Some)\[/$tag\]:tag_attr_list($1, $addr):eg;
return pull_if($body);
}

SEE ALSO


Name

area — produce a hypertext link URL

ATTRIBUTES

AttributePos.Req.DefaultDescription
hrefYesYes Name of page or action to link to
alias
once
search
form CGI parameters.
add_dot_html No No No Add HTML page suffix to page name?
secure 0 whether to use SecureURL or VendURL
match_security 0
no_session_id 0 suppress session identifier (id) if set
no_count 0 suppress page counter (mv_pc) if set
no_session 0 same as no_session_id and no_count combined
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The area tag expands to a proper hypertext URL link which preserves Interchange session information and arguments passed onto the targeted page or form action. The target page argument you supply is treated relatively to the pages/ directory inside your catalog root directory (CATROOT).

The enclosing <a href=""></a> HTML tag is not included, only the pure link is output. This makes area suitable for use in custom <a> links, Javascript constructs, imagemaps and elsewhere.

The reason this tag was named area in the first place is because it was planned to be used in client side Imagemaps.

The area and page tags are similar; the following two constructs are identical:

[page href="dir/page" arg="mv_arg"]Target Name</a>
<a href="[area href='dir/page' arg='mv_arg']">Target Name</a>

Besides just producing hypertext links to specific pages, you can also "embed" complete HTML forms in the target link (for say, one-click ordering or searches); see the section called “EXAMPLES”.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Produce the basic hypertext link

Add the following to an Interchange page:

Please visit our <a href="[area index]">Welcome</a> page.

Example: Implementing searches using search= option

The search attribute is a shorthand for the href / arg scheme. When search is used, href will be set to scan and arg to the value of search .

<a href="[area search="
    se=Impressionists
    sf=category"]
">Search for Impressionist Paintings</a>

Example: Embedding HTML forms in the area tag

<a href="[area form="
  mv_order_item=99-102
  mv_order_size=L
  mv_order_quantity=1
  mv_separate_items=1
  mv_todo=refresh"
]">Order T-shirt in Large size</a>

Or another example:

<a href="[area form="
  mv_todo=refresh
  mv_order_item=000101
  mv_order_fly=description=An on-the-fly item|price=100.01
"]">Order item 000101</a>

Which is equivalent to the usual HTML form:

<form action="[area process]" method="post">
  <input type='hidden' name='mv_todo' value="refresh">
  <input type='hidden' name='mv_order_item' value="000101">
  Qty: <input size='2' name='mv_order_quantity' value="1">
  <input type='hidden' name='mv_order_fly' value="description=An on-the-fly item|price=100.00">
  <input type='submit' value="Order button">
</form>

Example: Simple item ordering using the area tag

Order a <a href="[area order TK112]" target='newframe'>Toaster</a> today.

Example: Pass arguments onto the target page

Add the following link to an Interchange page:

Visit the <a href="[area href='test' arg='arg1=value1/arg2=value2']">test</a> page.

The relevant part of your test.html page could then look like this:

<p>This is a test page.</p>

[if session arg]
<p>You have passed an argument onto this page:</p>
<p>[data session arg]</p>
[else]
You did not pass any arguments to this page.
[/else]
[/if]

<p>Have a nice day!</p>


Example: Implementing searches using href=/arg= options

<a href="[area scan
    se=Impressionists
    sf=category]
">Search for Impressionist Paintings</a>

Or the equivalent, using named parameters and more understandable quoting:

<a href="[area href=scan
    arg="se=Impressionists
         sf=category"]
">Search for Impressionist Paintings</a>

If the arg parameter is set, it will be available within the search display page as [value mv_arg].


NOTES

The area tag examples use some advanced argument-quoting concepts. To minimize confusion, please see the proper and complete quoting explanation in the ITL glossary entry.

AVAILABILITY

area is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/area.coretag
Lines: 17


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: area.coretag,v 1.6 2007-09-21 16:15:48 kwalsh Exp $

UserTag href Alias        area

UserTag area Order        href arg
UserTag area addAttr
UserTag area Implicit     secure secure
UserTag area PosNumber    2
UserTag area Version      $Revision: 1.6 $
UserTag area MapRoutine   Vend::Interpolate::tag_area

Source: lib/Vend/Interpolate.pm
Lines: 2746

sub tag_area {
  ($page, $arg, $opt) = @_;

$page = '' if ! defined $page;

if( $page and $opt->{alias}) {
  my $aloc = $opt->{once} ? 'one_time_path_alias' : 'path_alias';
  $Vend::Session->{$aloc}{$page} = {}
    if not defined $Vend::Session->{path_alias}{$page};
  $Vend::Session->{$aloc}{$page} = $opt->{alias};
}

my ($r, $subname);

if ($opt->{search}) {
  $page = escape_scan($opt->{search});
}
elsif ($page =~ /^[a-z][a-z]+:/) {
  ### Javascript or absolute link
  return $page unless $opt->{form};
  $page =~ s{(\w+://[^/]+)/}{}
    or return $page;
  my $intro = $1;
  my @pieces = split m{/}, $page, 9999;
  $page = pop(@pieces);
  if(! length($page)) {
    $page = pop(@pieces);
    if(! length($page)) {
      $r = $intro;
      $r =~ s{/([^/]+)}{};
      $page = "$1/";
    }
    else {
      $page .= "/";
    }
  }
  $r = join "/", $intro, @pieces unless $r;
  $opt->{add_dot_html} = 0;
  $opt->{no_session} = 1;
  $opt->{secure} = 0;
  $opt->{no_count} = 1;
}
elsif ($page eq 'scan') {
  $page = escape_scan($arg);
  undef $arg;
}

elsif ($subname = $Vend::Cfg->{SpecialSub}{areapage}) {
          my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
          my $newpage = $sub->($page, $opt);
          $page = $newpage if defined $newpage;
          $arg = $opt->{arg};
      }

$urlroutine = $opt->{secure} ? \&secure_vendUrl : \&vendUrl;

return $urlroutine->($page, $arg, undef, $opt);
}

Source: lib/Vend/Interpolate.pm
Lines: 2746

sub tag_area {
  ($page, $arg, $opt) = @_;

$page = '' if ! defined $page;

if( $page and $opt->{alias}) {
  my $aloc = $opt->{once} ? 'one_time_path_alias' : 'path_alias';
  $Vend::Session->{$aloc}{$page} = {}
    if not defined $Vend::Session->{path_alias}{$page};
  $Vend::Session->{$aloc}{$page} = $opt->{alias};
}

my ($r, $subname);

if ($opt->{search}) {
  $page = escape_scan($opt->{search});
}
elsif ($page =~ /^[a-z][a-z]+:/) {
  ### Javascript or absolute link
  return $page unless $opt->{form};
  $page =~ s{(\w+://[^/]+)/}{}
    or return $page;
  my $intro = $1;
  my @pieces = split m{/}, $page, 9999;
  $page = pop(@pieces);
  if(! length($page)) {
    $page = pop(@pieces);
    if(! length($page)) {
      $r = $intro;
      $r =~ s{/([^/]+)}{};
      $page = "$1/";
    }
    else {
      $page .= "/";
    }
  }
  $r = join "/", $intro, @pieces unless $r;
  $opt->{add_dot_html} = 0;
  $opt->{no_session} = 1;
  $opt->{secure} = 0;
  $opt->{no_count} = 1;
}
elsif ($page eq 'scan') {
  $page = escape_scan($arg);
  undef $arg;
}

elsif ($subname = $Vend::Cfg->{SpecialSub}{areapage}) {
          my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
          my $newpage = $sub->($page, $opt);
          $page = $newpage if defined $newpage;
          $arg = $opt->{arg};
      }

$urlroutine = $opt->{secure} ? \&secure_vendUrl : \&vendUrl;

return $urlroutine->($page, $arg, undef, $opt);
}


Name

assign — assign overrides for salestax, shipping, handling and subtotal

ATTRIBUTES

AttributePos.Req.DefaultDescription
salestax None Override for salestax.
shipping None Override for shipping. Applies to total-cost only if mv_shipmode is set.
handling None Override for handling. Applies to total-cost only if mv_handling is set.
subtotal None Override for subtotal.
credit None Credit assignment.
clear No Clear all assignments?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The assign tag allows you to set direct, fixed values for some of the parts of the checkout process, instead of deriving the values by performing calculations, as it would happen in the normal course of action.

The value assignment is persistent for the duration of the user session, unless you clear it explicitly.

The clear option will cancel all active assignments. To clear an individual assignment, set its value to an empty string. (Beware, a specification such as handling=0 actually sets handling costs to zero, it does not clear the assignment. To clear the assignment, you must use handling="").

Rounding

Overrides for shipping and handling are rounded to locale-specific number of fractional digits. Overrides for subtotal and salestax are used verbatim.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Setting shipping costs to 4.99

[assign shipping=4.99]


Example: Setting handling costs to 0

[assign handling=0]


Example: Clearing the assignment for salestax

[assign salestax=""]


Example: Clearing all assignments

[assign clear=1]


NOTES

Assignments affect only the values returned by the corresponding tags. Other behavior (such as currency formatting) is, of course, not affected.

Assigning any value other than a number (or an empty string, when clearing assignments), will result in an error being reported and the assignment for the "subsystem" in question cleared.

An assignment is allowed to be a negative number.

You cannot directly assign a "total cost" amount — it will always be the sum of all assignment keys.

AVAILABILITY

assign is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/assign.coretag
Lines: 49


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: assign.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag assign              addAttr
UserTag assign              PosNumber    0
UserTag assign              Version      $Revision: 1.5 $
UserTag assign              Routine      <<EOR
my %_assignable = (qw/
      salestax  1
      shipping  1
      handling  1
      subtotal  1
      credit    1  
      /);
sub {
my ($opt) = @_;
if($opt->{clear}) {
  delete $Vend::Session->{assigned};
  return;
}
$Vend::Session->{assigned} ||= {};
for(keys %$opt) {
  next unless $_assignable{$_};
  my $value = $opt->{$_};
  $value =~ s/^\s+//;
  $value =~ s/\s+$//;
  if($value =~ /^-?\d+\.?\d*$/) {
    $Vend::Session->{assigned}{$_} = $value;
  }
  else {
          if ($value) {
        logError(
          "Attempted assign of non-numeric '%s' to %s. Deleted.",
          $value,
          $_,
        );
          }
    delete $Vend::Session->{assigned}{$_};
  }
}
return;
}
EOR


Name

assume-identity — override value of MV_PAGE on a page

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes .
name .
locale  1Honor locales?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: MV_PAGE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

assume-identity is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/assume_identity.tag
Lines: 32


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: assume_identity.tag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag assume-identity   Order        file locale
UserTag assume-identity   addAttr
UserTag assume-identity   PosNumber    2
UserTag assume-identity   Version      $Revision: 1.5 $
UserTag assume-identity   Routine      <<EOR
sub {
my ($file, $locale, $opt) = @_;
my $pn;
if($opt and $opt->{name}) {
$pn = $opt->{name};
}
else {
$pn = $file;
$pn =~ s/\.\w+$//;
$pn =~ s:^pages/::;
}
$Global::Variable->{MV_PAGE} = $pn;
$locale = 1 unless defined $locale;
return Vend::Interpolate::interpolate_html(
Vend::Util::readfile($file, undef, $locale)
);
}
EOR

AUTHORS

Mike Heins

SEE ALSO


Name

attr_list

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

attr_list is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/attr_list.coretag
Lines: 23


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: attr_list.coretag,v 1.8 2008-07-12 19:27:12 docelic Exp $

UserTag attr_list           addAttr
UserTag attr_list           hasEndTag
UserTag attr_list           PosNumber    0
UserTag attr_list           noRearrange
UserTag attr_list           Version      $Revision: 1.8 $
UserTag attr_list           Routine      <<EOR
sub {
my ($opt, $body) = @_;
if( ref $opt->{hash} ) {
  $opt = $opt->{hash};
}
return Vend::Interpolate::tag_attr_list($body, $opt);
}
EOR

Source:
Lines: 0

No extracted context

SEE ALSO


Name

auto-wizard

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes default Survey name.
already_title You already did that survey!
thanks_title Thanks for completing the survey!
already_message We only want to collect information once from each person. Thank you.
thanks_message Your survey is complete. Thank you.
intro_text
survey_file logs/survey/name.txt
survey_counter logs/survey/name.cnt
survey_counter_sql
email_subject Response to name
email_from
email_cc
output_fields
output_email
output_repeated
email_template
continue_template
output_href
output_parm
db_id
row_template
scratch
show
run
compile
title_scratch page_title
banner_scratch page_banner
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: SURVEY_LOG_DIR
Global Variables: MV_PAGE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

auto-wizard is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/auto_wizard.coretag
Lines: 972


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: auto_wizard.coretag,v 1.20 2007-03-30 23:40:54 pajamian Exp $

UserTag  auto-wizard  Order     name
UserTag  auto-wizard  AddAttr
UserTag  auto-wizard  HasEndTag
UserTag  auto-wizard  Version   $Revision: 1.20 $
UserTag  auto-wizard  Routine   <<EOR

use vars qw/$Session $Tag $CGI $Tmp $Scratch $Values $ready_safe/;
 
my @wanted_opts = qw/
 already_message
 already_title
 bottom_buttons
 break_row_class
 combo_row_class
 data_cell_class
 data_row_class
 display_type
 help_cell_class
 intro_text
 label_cell_class
 left_width
 output_type
 spacer_row_class
 table_width
 thanks_message
 thanks_title
 top_buttons
 widget_cell_class
 email_from
 email_cc
 email_subject
 email_template
 continue_template
 row_template
 output_email
 output_fields
 output_repeated
/;

my %overall_opt;
@overall_opt{@wanted_opts} = @wanted_opts;

sub thanks_title {
 my ($opt, $already, $default) = @_;
 my $tt = $already
     ?  ($opt->{already_title} ||= "You already did that survey!" )
     :  ($opt->{thanks_title} ||= $default || "Thanks for completing the survey!");
 return errmsg($tt);
}

sub thanks_message {
 my ($opt, $already) = @_;
 my $tm;
 if($already) {
   $opt->{already_message} ||=
     "We only want to collect information once from each person. Thank you.";
   $tm = $opt->{already_message};
 }
 else {
   $opt->{thanks_message} ||= "Your survey is complete. Thank you.";
   $tm = $opt->{thanks_message};
 }
 return errmsg($tm);
 $opt->{intro_text} .= "<h1>$tm</h1>" if $already;
}

sub title_and_message {
 my ($opt, $already) = @_;
 my $tt = thanks_title($opt, $already);
 my $tm = thanks_message($opt, $already);
 return (
       '',
       "final: $tt",
       'template: <<EOF',
       $tm,
       'EOF',
     );
}

sub already {
 my ($wizname, $set) = @_;
 my $surv = $Vend::Session->{surveys} ||= {};
 if(defined $set) {
   $surv->{$wizname} = $set;
 }

 if ($Vend::Session->{logged_in} and ! $Vend::admin) {
   if (! defined $surv->{$wizname}) {
     my $o = {
       function => 'check_file_acl',
       location => "survey/$wizname",
     };
     $surv->{$wizname} = $Tag->userdb($o);
   }
   else {
     my $o = {
       function => 'set_file_acl',
       location => "survey/$wizname",
       mode => $surv->{$wizname},
     };
     $Tag->userdb($o);
   }
 }

 return $surv->{$wizname};
}

sub survey_log_generate_final {
 my ($wizname, $opt, $ary) = @_;

 ref($opt) eq 'HASH'
   or die "bad call to generate_final routine, output options not hash ref ($opt)";
 ref($ary) eq 'ARRAY'
   or die "bad call to generate_final routine, output not array ref ($ary)";

 my $done = already($wizname);

 push @$ary, title_and_message($opt, $done);

 if ( $done ) {
   $opt->{intro_text} .= '<h1>' . thanks_title($opt, 1) . '</h1>';
 }
#  else {
#    $opt->{survey_counter}  ||= "logs/survey/$wizname.cnt";
#    $opt->{survey_file}    ||= "logs/survey/$wizname.txt";
#    push @$ary, "\tsurvey_file: $opt->{survey_file}";
#    push @$ary, "\tsurvey_counter: $opt->{survey_counter}";
#  }
 return;
}

sub gen_email_header {
 my ($wizname, $ref, $opt, $fnames) = @_;
 my $subject = errmsg($opt->{email_subject} || "Response to %s", $wizname);
 my $from_addr = $opt->{email_from};
 my $cc_addr = $opt->{email_cc};
 for(qw/ EMAIL_SURVEY EMAIL_INFO EMAIL_SERVICE /) {
   next unless $from_addr = $::Variable->{$_};
   last;
 }
 $from_addr ||= $Vend::Cfg->{MailOrderFrom} || $Vend::Cfg->{MailOrderTo};
 my $tpl = <<EOF;
From: $from_addr
Subject: $subject
To: {output_email}
EOF
 $tpl .= "Cc: $cc_addr\n" if $cc_addr;
 return $tpl;
}

sub gen_email_template {
 my ($wizname, $ref, $opt, $fnames) = @_;
 my $tpl = gen_email_header($wizname, $ref, $opt, $fnames);
 $tpl .= <<EOF;

{code?}Sequence: {code}
{/code?}Username: {username}
IP Address: $CGI::remote_addr
Host: $CGI::remote_host
Date: {date}
--------------------------------------------
EOF

 my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
 if(! @fields) {
   @fields = @$fnames;
 }

 for(@fields) {
   $tpl .= "$_: {$_}\n";
 }
 $tpl .= "--------------------------------------------\n";
 return $tpl;
}

sub email_output {
 my ($wizname, $ref, $opt, $fnames) = @_;
#::logDebug("Called email_output");
 return unless  $opt->{output_email};

#::logDebug("email_output has an address of $opt->{output_email}");
 ## Check and see if already sent
 if(! $opt->{output_repeated} and already($wizname)) {
#::logDebug("email_output already done, repeated=$opt->{output_repeated} \
 already=" . ::uneval($Vend::Session->{surveys}));
   return;
 }

#::logDebug("email_output is continuing");
 my $tpl   = $opt->{email_template};
 if(! $tpl or $tpl !~ /\S/) {
   $tpl = gen_email_template($wizname, $ref, $opt, $fnames);
 }
 else {
   $opt->{email_template} =~ s/\s+$//;
   $opt->{email_template} =~ s/^\s+//;
   if($opt->{email_template} !~ /[\r\n]/) {
     $tpl = interpolate_html(Vend::Util::readfile($opt->{email_template}));
   }
   else {
     $tpl = $opt->{email_template};
   }
   if($tpl !~ /^[-\w]+:/) {
     $tpl = join "\n", gen_email_header($wizname, $ref, $opt, $fnames), $tpl;
   }
 }

#::logDebug("email_output tpl=$tpl");

 my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
 if(! @fields) {
   @fields = @$fnames;
 }
 
 my $outref = { %$opt };

 $outref->{ip_address} = $CGI::remote_addr;
 $outref->{host_name} = $CGI::remote_host;
 $outref->{username} = $Vend::username || 'anonymous';
 $outref->{date} = POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime());

 for(@fields) {
   $outref->{$_} = $Values->{$_};
 }
 my $out = tag_attr_list($tpl, $outref);

 my $status;
 $status = $Tag->email_raw({}, $out)
   or ::logError("Failed to send survey email output:\n$out");
#::logDebug("email_output status=$status");
 return $status;
}

sub survey_log_to_file {
 my ($wizname, $ref, $opt, $fnames) = @_;

if(! $opt->{output_repeated} and already($wizname)) {
 return template_attr($wizname, $ref, $opt, $fnames);
}

my $fn   = $ref->{survey_file};
my $cfn  = $ref->{survey_counter};
my $sqlc = $ref->{survey_counter_sql};

if(! $fn) {
 $fn = $::Variable->{SURVEY_LOG_DIR} || 'logs/survey';
 $fn .= "/$wizname.txt";
}

if(! $cfn and ! $sqlc) {
   $cfn = $fn;
   $cfn =~ s/\.txt$//;
   $cfn .= '.cnt';
   $cfn =~ s:(.*/):$1.:;
 }

 my @fields = grep /\S/, split /\s+/, $opt->{output_fields};
 if(! @fields) {
   @fields = @$fnames;
 }
 if(! -f $fn) {
   my $string = join "\t",
           'code', 'ip_address', 'username', 'date', @fields;
   $string .= "\n";
   $Tag->write_relative_file($fn, $string);
 }

 my @o = $Tag->counter({file => $cfn, sql => $sqlc});
 push @o, $CGI::remote_addr;
 push @o, $Vend::username || 'anonymous';
 push @o, POSIX::strftime("%Y-%m-%d %H:%M:%S", localtime());

 for(@fields) {
   my $result = $Values->{$_};
   $result =~ s/\r?\n/\r/g;
   $result =~ s/\t/  /g;
   push @o, $result;
 }

 ::logData($fn, @o);
 email_output($wizname, $ref, $opt, $fnames);
 already($wizname => 1) unless $opt->{output_repeated};
 return template_attr($wizname, $ref, $opt, $fnames);
}

my %survey_genfinal = (
 survey_log => \&survey_log_generate_final,
 email_only => sub {
   my ($wizname, $opt, $ary) = @_;
   push @$ary, title_and_message($opt, already($wizname));
   if($opt->{continue_template}) {
     push @$ary, "template: <<EOF";
     push @$ary, $opt->{continue_template};
     push @$ary, 'EOF';
   }
   return;
 },
 default => sub {
   my ($wizname, $opt, $ary) = @_;
   my $line = "final: ";
   $line .= thanks_title(
           $opt,
           $Vend::Session->{surveys}{$wizname},
           errmsg("Finished with %s", $wizname),
         );
   push @$ary, '';
   push @$ary, $line;
   if($opt->{continue_template}) {
     push @$ary, "template: <<EOF";
     push @$ary, $opt->{continue_template};
     push @$ary, 'EOF';
   }
   return;
 },
);

sub template_attr {
 my ($wizname, $ref, $opt, $fields) = @_; 
 my %attr;

 if(ref($fields) eq 'hash') {
   %attr = { %$fields };
 }

 $attr{TITLE} = $ref->{_page_title} || "Finished with $wizname...";
 $attr{PROMPT} = $ref->{prompt};
 $attr{ANCHOR} = $ref->{anchor} || 'Go';
 $attr{EXTRA} = $ref->{extra} || '';
 $attr{EXTRA} = " $attr{EXTRA}" if $attr{EXTRA};
 $attr{URL} = wizard_url($ref, $opt, $fields);
#::logDebug("generated ATTR is: " . uneval(\%attr));
 my $template = $ref->{template} || <<EOF;
<H1>{TITLE}</h1>
{PROMPT}
<p>
<blockquote>
<A HREF="{URL}"{EXTRA}>{ANCHOR}</A>
</blockquote>
EOF
 return tag_attr_list($template, \%attr);
}

sub wizard_url {
 my ($ref, $opt, $fields) = @_; 
 my %attr;
 my %ignore = qw/
         page 
         href
         template
         remap
         /;
       
 my $form = { };
 for(keys %$ref) {
   next if /^_/;
   next if $ignore{$_};
   $form->{$_} = $ref->{$_};
 }

 $form->{href} = $opt->{output_href} || $ref->{href} || $ref->{page};
 if($opt->{output_parm}) {
   my $ref = Vend::Util::scalar_to_hash($opt->{output_parm}) || {};
   for (keys %$ref) {
     $form->{$_} = $ref->{$_};
   }
 }
 $form->{form} = 'auto';
 for(@$fields) {
   $form->{$_} = $Values->{$_};
 }

 my $save = { };
 if($ref->{remap}) {
   my @pairs = split /[\s,\0]+/, $ref->{remap};
   for(@pairs) {
     my ($k, $v) = split /=/, $_;
     next unless $k and $v;
     my $val = delete($form->{$k}) || $save->{$k};
     $save->{$k} = $val;
     $form->{$v} = $val;
   }
 }

 return $Tag->area($form);
}

my %survey_auto = qw/
           survey_log   1
           email_only   1
           auto_bounce  1
         /;
## Called with:
##
##  $$dest = $sub->($wizname, $ref, $opt, \@vals);
##
##   $wizname name of wizard/survey
##   $ref     copy of final stanza of auto_wizard, hash ref with keys, can modify
##   %opts    Options auto_wizard was created with, can modify
##   @vals    Fields names collected in the wizard, can modify

my %survey_action = (
 survey_log => \&survey_log_to_file,
 auto_bounce => sub {
   my ($wizname, $ref, $opt, $fnames) = @_;
   my $url = wizard_url($ref, $opt, $fnames);
   email_output($wizname, $ref, $opt, $fnames);
   my $status = $Tag->deliver( { type => 'text/html', location => $url });
   return $status;
 },
 default => sub {
   my ($wizname, $ref, $opt, $fnames) = @_;
   $ref->{wizard_name} = $wizname;
   email_output($wizname, $ref, $opt, $fnames);
   return template_attr($wizname, $ref, $opt, $fnames);
 },
);

sub compile_wizard {
 my ($wizname, $opt, $script) = @_;
#Debug("script in: $script");
 $script =~ s/^\s+//;
 $script =~ s/\r\n/\n/g;
 $script =~ s/\r/\n/g;
 my @lines = split /\n/, $script;
 my $ref;

 my @pages;

 my $qip; # question in progress
 my $iip; # item in progress
 my $fip; # final in progress
 my $bip; # breaks in progress
 my $blip; # break labels in progress
 my $began; # We have begun

 my $sip;
 my $vip;
 my $mark;
 my $break;
 my %opts;

 if($opt->{db_id}) {
#Debug("found db_id=$opt->{db_id}");
   my ($t, $k) = split /:+/, $opt->{db_id}, 2;
   BUILDWIZ: {
     my $met = $Tag->meta_record($k, undef, $t)
       or last BUILDWIZ;
     my($structure) = delete $met->{ui_data_fields};
     delete $met->{extended};
     %opts = %$met;
#Debug("display type=$opts{display_type} met=" . ::uneval($met) );
     $met->{row_template} = $opt->{row_template}
       if $opt->{row_template};
     my $ids = $t . '::' . $k . '::';
     $structure =~ s/\r\n?/\n/g;
     my $string = "\n\n$structure";
     my %break;
     while ($string =~ s/\n+(?:\n[ \t]*=(.*))?\n+[ \t]*(\w[:.\w]+)/\n$2/) {
       $break{$2} = $1;
     }
     $string =~ s/^[\s,\0]+//;
     $string =~ s/[\s,\0]+$//;
     $string =~ s/[,\0\s]+/ /g;
     my @fields = split /\s+/, $string;
     my @out = "$k: $met->{label}";
     my $i = 1;
     my $fields_line = join "\t", @fields;
     for(@fields) {
       if($break{$_}) {
         push @out, "$i: $break{$_}";
         $i++;
       }
       push @out, "\tdb_id: $ids$_";
       push @out, '';
     }
     $opts{output_fields} ||= join " ", @fields;
     my $otype = $opts{output_type} || 'default';
     my $sub = $survey_genfinal{$otype} || $survey_genfinal{default};
     $sub->($k, \%opts, \@out);
     @lines = @out;
   }
 }

#Debug("Found some lines, number=" . scalar @lines);
#Debug("display type=$opts{display_type}");
 for(@lines) {
   if($mark) {
     $sip .= "$_\n", next
       unless $_ eq $mark;
     $_ = $sip;
     undef $mark;
     undef $sip;
   }

   if (s/<<(\w+)$//) {
     $mark = $1;
     $sip = $_;
     next;
   }

   s/\s+$//;

   if(! $_) {
     undef $iip;
     next;
   }

   if(! $ref) {
     if(/^(\w+):\s*(.*)/) {
       $began = 1;
       $wizname ||= $1;
       my $title = $2;
       $ref = {
           _page_name => 'begin',
           _name => [],
           title => $title,
           %opts,
         };
     }
     next;
   }

   if(/^(\d+)[:.]\s*(.*)/) {
     my $pn = $1; my $title = $2;
     push @pages, $ref;
     my $lastpage = $ref->{_page_name};
     $qip = [];
     undef $bip;
     undef $blip;
     $ref = {  
           _page_name    => $pn,
           _name      => $qip,
           _breaks      => $bip,
           _break_labels  => $blip,
           _page_title    => $title,
           };
     next;
   }
   if(/^final[:.]\s*(.*)/) {
     undef $qip;
     undef $iip;
     $fip = 1;
     my $title = $1;
     push @pages, $ref;
     my $lastpage = $ref->{_page_name};
     $ref = { _page_name => 'final', _page_title => $title};
     next;
   }


   if($fip) {
     s/^\s+//;
     unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) {
       $Tag->warnings(qq{Unrecognized "$_" in middle of script.});
       next;
     }
     my $thing    = $1;
     my $modifier = $2;
     my $value    = $3;
     if($modifier) {
       $ref->{_modifier} ||= {};
       $ref->{_modifier}{$thing} = $modifier;
     }
     $ref->{$thing} = $value;
     next;
   }

   if($qip) {
     if(/^(itl|perl)(?:_condition)?:\s*(.*)$/s) {
       if(! $ref->{_condition}) {
         $ref->{_condition_type} = $1;
         $ref->{_condition} = $2;
       }
       else {
         $Tag->error(
           "%s_condition: cannot set twice in wizard %s screen %s",
           $1,
           $pages[0]->{_title},
           $ref->{_page_name},
         );
         return;
       }
       next;
     }
     elsif(/^opt:\s*(.*)$/s) {
       my $option = $1;
       $option =~ s/\s+$//;
       my ($n, $v) = split /=/, $option, 2;
       my $o = $ref->{_options} ||= [];
       push @$o, $n, $v;
       next;
     }

     s/^\s+//;
     unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) {
       $Tag->warnings(qq{Unrecognized "$_" in middle of script.});
       next;
     }
     my $thing = $1;
     my $modifier = $2;
     my $value = $3;

     if(! $iip) {

       ## This redoes the loop
       if($thing eq 'name') {
         $thing = $value;
         undef $value;
       }
       elsif($thing eq 'break') {
         $break = $value;
         $break =~ s/,/&#41;/g;
         $ref->{_breaks} ||= ($bip = []);
         $ref->{_break_labels} ||= ($blip = []);
         next;
       }
       elsif($thing eq 'db_id') {
         my ($t, $survey, $name) = split /:+/, $value, 3;
         $thing = $name;
         my $key = $survey . '::' . $name;
         my $meta = $Tag->meta_record($key, undef, $t);
         if($meta) {
           for(keys %$meta) {
             $ref->{$_} ||= {};
             $ref->{$_}{$thing} = $meta->{$_};
           }
         }
         $ref->{name}{$thing} = $thing;
#::logDebug("meta record is " . ::uneval($meta));

         undef $value;
       }

       $iip = $thing;
       push @$qip, $iip;
       if($break) {
         push @$bip, $iip;
         push @$blip, "$iip=$break";
         undef $break;
       }
       $ref->{label}{$iip} = $value if $value;
       next;
     }

     if($modifier) {
       $ref->{_modifier} ||= {};
       $ref->{_modifier}{$thing} ||= {};
       $ref->{_modifier}{$thing}{$iip} = $modifier;
     }
     $ref->{$thing} ||= {};
     $ref->{$thing}{$iip} = $value;
   }
   else {
     unless (/^([A-Za-z]\w+)(?:=([^:]+))?\s*:\s*(.*)/s) {
       $Tag->warnings(qq{Unrecognized "$_" in beginning section of script.});
       next;
     }
     my $thing = $1;
     my $modifier = $2;
     my $value = $3;
     $ref->{$thing} = $value;
   }
 }
 push @pages, $ref;
 $wizname ||= 'default';
 my $wiz_ary = $Session->{auto_wizard} ||= {};
 $wiz_ary->{$wizname} = \@pages;
#Debug("Wizard $wizname=" . ::uneval(\@pages));
 return $wizname;
}

sub {
 my ($wizname, $opt, $body) = @_;

 my $dest;
 $wizname ||= $CGI->{wizard_name};

 if($opt->{scratch}) {
   $Tag->tmp($opt->{scratch});
   $::Scratch->{$opt->{scratch}} ||= '';
   $dest = \$::Scratch->{$opt->{scratch}};
 }
 else {
   $Tmp->{auto_wizard} ||= '';
   $dest = \$Tmp->{auto_wizard};
 }
 return $$dest if $opt->{show} and ! $opt->{run};

 if($opt->{compile} eq 'auto') {
   $Session->{auto_wizard} ||= {};
   undef $opt->{compile} if $wizname && $Session->{auto_wizard}{$wizname};
   $opt->{show} = 1 unless defined $opt->{show};
   $opt->{run} = 1;
 }

 if($opt->{compile}) {
   my $n;
   $n = compile_wizard(@_)
     or do {
       ::logError(
         $$dest = errmsg(
                     "Wizard %s failed to compile.",
                     $wizname,
                   )
             );
       return;
       };
#Debug("compiler returned wizname=$n");
   $wizname = $n;
   undef $body;
 }

 if(! defined $opt->{run}) {
   $opt->{run} = 1;
   $opt->{show} = 0 if ! defined $opt->{show};
 }

 my $title_var = $opt->{title_scratch}   || 'page_title';
 my $banner_var = $opt->{banner_scratch} || 'page_banner';
 my $wiz;

 $wizname ||= $CGI->{wizard_name} || 'default';
#Debug("wizname=$wizname");

 return unless $wiz = $Vend::Session->{auto_wizard}{$wizname};
#Debug("we have a wiz! wizname=$wizname");

 my $beg = $wiz->[0];
 my $fin = $wiz->[-1];

 for($beg, $fin) {
   return "Bad wizard!" unless ref($_) eq 'HASH';
 }

 my $lastwiz = $#$wiz;
 my $lastpage = $CGI->{wizard_page} || 0;
 my $current_page;

 my %opts;
 copyref($beg, \%opts);

 # Get rid of internal stuff
 for(keys %opts) {
   next unless /^_/;
   delete $opts{$_};
 }

 if($CGI->{ui_wizard_action} eq 'Back') {
   $current_page = $lastpage - 1;
 }
 elsif($CGI->{ui_wizard_action} eq 'Cancel') {
   $current_page = 0;
 }
 elsif($CGI->{ui_wizard_action} eq 'Next') {
   $current_page = $lastpage + 1;
 }
 else {
   $current_page = $lastpage;
 }

 my $finished;
 my $condition_done;
 my $optref;
#::logDebug("Getting screens");
 GETSCREEN: {
   $optref = $wiz->[$current_page];
   if(! $condition_done and $optref->{_condition}) {
     $condition_done = 1;
     my $result;
     if($optref->{_condition_type} eq 'itl') {
       eval {
         $result = interpolate_html($optref->{_condition});
       };
       $result =~ s/\s+$//;
       $result =~ s/.*\s//s;
       $result += 0;
       $current_page += $result;
     }
     else {
       eval {
         $result = $ready_safe->reval($optref->{_condition});
       };
       if($@) {
         $Tag->error(
           "error during perl conditional: $@\ncode was:\n%s",
           $@,
           $optref->{_condition},
         );
         $current_page -= 1;
       }
       $result += 0;
#::logDebug("did perl conditional, result=$result");
       $current_page += $result;
     }
     redo GETSCREEN;
   }

   if($current_page <= 0) {
     $current_page = 1;
   }
   elsif ( ($current_page + 1) == $lastwiz ) {
     $opts{next_text} = errmsg('Finish')
       if $survey_auto{$opts{output_type}} or $fin->{auto};
   }
   elsif ($current_page >= $lastwiz) {
     $finished = 1;
   }
   $optref = $wiz->[$current_page];
 }
 
 unless($current_page <= 1) {
   delete $opts{intro_text};
   delete $optref->{intro_text};
 }

 my %modsub = (
     i    => sub {
             my $val = shift;
#              ::logDebug("running interpolate of $val");
             return interpolate_html($val);
           },
     default => sub {
             my $val = shift;
             my $filters = join " ", @_;
             return $Tag->filter($filters, $val);
           },
   );

 $Scratch->{$title_var}  = $optref->{_page_title};
 $Scratch->{$banner_var} = $optref->{_page_title};

 if($finished) {
     my $ref = { %$fin };

     my $mod;
     if( $mod = delete $ref->{_modifier}) {
       for(keys %$ref) {
         next if /^_/;
         if(my $m = $mod->{$_}) {
           my $v = $ref->{$_};
           my $sub = $modsub{$m} || $modsub{default};
           $ref->{$_} = $sub->($ref->{$_}, $m);
         }
       }
     }

     my @vals;
     for my $w (@$wiz) {
       next unless ref($w->{_name}) eq 'ARRAY';
       push @vals, @{$w->{_name}};
     }

     my $otype = $opts{output_type};
     $otype ||= 'auto_bounce' if $ref->{auto};
     my $sub = $survey_action{$otype} || $survey_action{default};
     $$dest = $sub->($wizname, $ref, \%opts, \@vals);
     return $$dest if $opt->{show};
     return;
#Debug("finished, page ref=" . uneval($ref));

 }

#Debug("we have a wiz=$wizname! current_page = $current_page");

#Debug("optref=" . $Tag->uneval(undef, $optref));

#::logDebug("prepping to walk optref");

### TODO: Find bad reference when no section title...

 my $name = $optref->{_name} || die;
#  $Scratch->{page_title} = $optref->{_page_title};

 if($optref->{_breaks} and ref($optref->{_breaks}) eq 'ARRAY') {
   $opts{ui_break_before} = join " ", @{$optref->{_breaks}};
   $opts{ui_break_before_label} = join ",", @{$optref->{_break_labels}};
 }

 if(my $o = $optref->{_options}) {
   for (my $i = 0; $i < @$o; $i += 2) {
     $opts{$o->[$i]} = $o->[$i + 1];
   }
 }

 $opts{form_name} ||= 'wizard';
 $opts{all_errors} = '1';
 $opts{hidden} = {
   wizard_name => $wizname,
   wizard_page => $current_page,
 };

 $opts{wizard} = 1;
 $opts{notable} = 1;
 $opts{no_meta} = 1;
 $opts{defaults} = 1;
 $opts{mv_cancelpage} ||= 'index';
 $opts{row_template} ||= $opt->{row_template} || <<'EOF' unless $opts{display_type};
{HELP?}<td>&nbsp;</td><td>
    <span style="color: blue">{HELP}</span>
  {HELP_URL?}<BR><A HREF="{HELP_URL}">more help</A>{/HELP_URL?}
  </td>
 </tr>
   <tr class=rnorm>
 {/HELP?}
  <td class=cdata width="20%" valign=top> 
    {LABEL}
 </td>
<td class=cdata width=500> 
        $WIDGET$
</td>
</tr>
<tr class=rspacer>
<td colspan=2><img src="bg.gif" height=1 width=1></td>
EOF

$opts{ui_wizard_fields} = join " ", @$name;
$opts{mv_nextpage} = $Global::Variable->{MV_PAGE};
$opts{mv_prevpage} = $Global::Variable->{MV_PAGE} if $current_page != 1;
$opts{bottom_buttons} = 1;

#::logDebug("walking optref");
my $mod = $optref->{_modifier} || '';
 for(keys %$optref) {
   next if /^_/;
   next if $overall_opt{$_};
   next unless ref($optref->{$_}) eq 'HASH';
   $opts{$_} = {} if ref($opts{$_}) ne 'HASH';
   Vend::Util::copyref($optref->{$_}, $opts{$_});
   my $m;
   if($mod and $m = $mod->{$_}) {
     my $r = $opts{$_};
     for my $k (keys %$r) {
       next unless $m->{$k};
       my @subs = split /\s*,\s*/, $m->{$k};
       for(@subs) {
         my $sub = $modsub{$_} || $modsub{default};
         $r->{$k} = $sub->($r->{$k}, $_);
       }
     }
   }
 }

 $opts{widget} ||= {};
 if( my $r = delete $opts{type} ) {
   for(keys %$r) {
     $opts{widget}{$_} = $r->{$_};
   }
 }

 delete $opts{type};
 # Prevent ui_data_fields from parent corrupting wizard
 delete $opts{ui_data_fields};
 delete $opts{extended};
#::logDebug("calling table_editor opts=" . ::uneval(\%opts));
 $$dest = $Tag->table_editor( {all_opts => \%opts });
 if($$dest !~ /<form\s+/i) {
   my $msg = errmsg("Auto wizard failed to run wizard %s.", $name);
   $$dest .= $Tag->error({ show => 1, set => $msg });
 }

 return $$dest if $opt->{show};
 return;
}
EOR

SEE ALSO


Name

available_ups_internal

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

available_ups_internal is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/available_ups_internal.coretag
Lines: 23


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: available_ups_internal.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag available_ups_internal Version $Revision: 1.4 $
UserTag available_ups_internal Routine <<EOR
sub {
my (@files) = glob('products/[0-9][0-9][0-9].csv');
return '' unless @files;
my $out = '';
for(@files) {
  s:/(\d+)::
    or next;
  $out .= "$1\t$1\n";
}
return $out;
}
EOR

SEE ALSO


Name

available_www_shipping

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

available_www_shipping is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/available_www_shipping.coretag
Lines: 61


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: available_www_shipping.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag available_www_shipping Order   only
UserTag available_www_shipping Version $Revision: 1.5 $
UserTag available_www_shipping Routine <<EOR
sub {
my ($only) = @_;
my $ups;

if(! $only or $only =~ /ups/i) {
  eval {
    require Business::UPS;
  };
  $ups = $@ ? 0 : 1;
}

my @ups_modes;
if($ups) {
  push @ups_modes,
    '1DM' => {type => 'UPS', description => 'Next Day Air Early AM'},
    '1DML' => {type => 'UPS', description => 'Next Day Air Early AM Letter'},
    '1DA' => {type => 'UPS', description => 'Next Day Air'},
    '1DAL' => {type => 'UPS', description => 'Next Day Air Letter'},
    '1DP' => {type => 'UPS', description => 'Next Day Air Saver'},
    '1DPL' => {type => 'UPS', description => 'Next Day Air Saver Letter'},
    '2DM' => {type => 'UPS', description => '2nd Day Air A.M.'},
    '2DA' => {type => 'UPS', description => '2nd Day Air'},
    '2DML' => {type => 'UPS', description => '2nd Day Air A.M. Letter'},
    '2DAL' => {type => 'UPS', description => '2nd Day Air Letter'},
    '3DS' => {type => 'UPS', description => '3 Day Select'},
    'GNDCOM' => {type => 'UPS', description => 'Ground Commercial'},
    'GNDRES' => {type => 'UPS', description => 'Ground Residential'},
    'XPR' => {type => 'UPS', description => 'Worldwide Express'},
    'XDM' => {type => 'UPS', description => 'Worldwide Express Plus'},
    'XPRL' => {type => 'UPS', description => 'Worldwide Express Letter'},
    'XDML' => {type => 'UPS', description => 'Worldwide Express Plus Letter'},
    'XPD' => {type => 'UPS', description => 'Worldwide Expedited'},
  ;
}

if (wantarray) {
  return @ups_modes;
}
else {
  my $out = '';
  my $i;
  for ($i = 0; $i < @ups_modes; $i += 2) {
    my $ref = $ups_modes[$i + 1];
    $out .= qq{UPSE:$ups_modes[$i]\t$ref->{type}: $ref->{description}\n};
  }
  return $out;
}
}
EOR

SEE ALSO


Name

backup-database — backup Interchange databases, even rows selectively

ATTRIBUTES

AttributePos.Req.DefaultDescription
tables Yes Yes Tables to back-up
force false Force export even if NoExportExternal would apply to this table?
dir BACKUP_DIRECTORY or CATROOT/backup/ Backup directory to dump database contents to
gnumeric 0 Save all backed databases to a gnumeric file DBDOWNLOAD.all in the backup directory?
xls 0 Save all backed databases to a Microsoft Excel file DBDOWNLOAD.xls in the backup directory? This option requires Spreadsheet::WriteExcel Perl module.
max_xls_string 255 Maximum length of a field within the Microsoft Excel .xls format
where An additional WHERE= SQL clause to selectively back-up only parts of databases
compress 0 GZip output backup files? This option requires Compress:Zlib Perl module.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag allows database backups. Databases are dumped into the backup directory, and named after their corresponding source files (taken from Database definitions).

The tag can also produce dumps in gnumeric or Microsoft Excel formats.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: BACKUP_DIRECTORY

EXAMPLES

Example: Backing-up the products database

For this example to work, CATROOT/backup/ directory must exist:

[either]
  [tmp name=backup set="[backup-database tables=products]" hide=1]
[or]
  [scratch ui_error]
[/either]

NOTES

The backup directory, whichever it is, must exist before backup-database is called.

AVAILABILITY

backup-database is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/backup_database.coretag
Lines: 238


# Copyright 2002-2016 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag backup-database Order    tables
UserTag backup-database AddAttr
UserTag backup-database Version  1.12
UserTag backup-database Routine  <<EOR
sub {
my ($tables, $opt) = @_;
my (@tables) = grep /\S/, split /['\s\0]+/, $tables;
my $backup_dir =  $opt->{dir}
        || $::Variable->{BACKUP_DIRECTORY}
        || "$Vend::Cfg->{VendRoot}/backup";
my $gnum   = $opt->{gnumeric};
my $agg = "$backup_dir/DBDOWNLOAD.all";

my $Max_xls_string = 255;

eval {
  require Compress::Zlib;
} if $opt->{compress};

my $xls;

if ($opt->{xls}) {
  eval {
    require Spreadsheet::WriteExcel;
    import Spreadsheet::WriteExcel;
    $xls = Spreadsheet::WriteExcel->new("$backup_dir/DBDOWNLOAD.xls");
  };
  if ($xls) {
    if ($opt->{max_xls_string}) {
      $Max_xls_string = int($opt->{max_xls_string}) || 255;
      $xls->{_xls_strmax} = $Max_xls_string;
    }
  }
  else {
    undef $opt->{xls};
  }
}

my $gz;

my @errors;

if($gnum) {
  open (AGG, ">$agg")
    or die "Cannot write aggregate file $agg; $!\n";
}
my $done = 0;
for my $table (@tables) {
  my $unlink;
  my $db = Vend::Data::database_exists_ref($table);
  my $fn = $db->config('file');
  $fn =~ s:.*/::;
  my $file = "$backup_dir/$fn";
  my $status;
  local $Vend::Cfg->{NoExportExternal} if $opt->{force};
  eval {
    $status = export(
          $table,
          {
            force => 1,
            table => $table,
            file => $file,
            type => 'TAB',
            where => $opt->{where},
          },
        );
  };

  if(! $status) {
    push @errors,
      errmsg(
          "Error exporting %s to %s: %s",
          $table,
          $file,
          $@ || 'unspecified',
        );
    next;
  }

  if($opt->{compress}) {
    my $new = "$file.gz";
    my $gz;
    eval {
      $gz = Compress::Zlib::gzopen($new, "wb")
        or die errmsg("error compressing %s to %s: %s", $new, $agg, $!);
      open(ZIN, $file)
        or die errmsg("error opening %s: %s", $file, $!);
      while(<ZIN>) {
        $gz->gzwrite($_)
          or die
            errmsg("gzwrite error on %s: %s", $new, $gz->gzerror());
      }
      $gz->gzclose();
      close ZIN;
    };
    if($@) {
      push @errors, $@;
      next;
    }
    $unlink = 1;
  }
  if($gnum) {
    print AGG "\f" if $done;
    print AGG "$table\n";
    open(RECENT, $file)
      or do {
        push @errors,
          errmsg("Can't read written file %s: %s", $file, $!);
        next;
      };
    while(<RECENT>) {
      /\t/ and s/^/'/ and
        (
          s/\t(0\d+)/\t'$1/g,
          s/\t\+/\t'+/g,
          s/\t( *\d[^\t]*[-A-Za-z ])/\t'$1/g
        );
      print AGG;
    }
    close RECENT;
  }
  if($xls) {
    my $sheet = $xls->addworksheet($table);
    $sheet->{_xls_strmax} = $Max_xls_string
      if defined $opt->{max_xls_string};
    $sheet->activate($table) if $table eq $Vend::Cfg->{ProductFiles}[0];
    open(RECENT, $file)
      or do {
        push @errors,
          errmsg("Can't read written file %s: %s", $file, $!);
        next;
      };
    my $fstring = <RECENT>;
    chomp $fstring;
    my @fields = split /\t/, $fstring;
    my $maxcol = scalar @fields - 1;
    my $j;
    for($j = 0; $j <= $maxcol; $j++) {
      $sheet->write_string(0, $j, $fields[$j])
        if length $fields[$j];
    }
    my $i = 1;
    while(<RECENT>) {
      chomp;
      my @extra;
      my @overflow;
      @fields = split /\t/, $_;
      for($j = 0; $j <= $maxcol; $j++) {
        my $l = 0;
        my $ptr;
        if ( length($fields[$j]) > $Max_xls_string) {
          $overflow[$j] = $fields[$j];
          $extra[$j] = [];
          while ( length($overflow[$j]) > $Max_xls_string) {
            for( ' ', "\n", "&nbsp;" ) {
              $ptr = rindex $overflow[$j], $_, $Max_xls_string;
#::logDebug("char='$_' ptr=$ptr length=" . length($overflow[$j]) ) if $l < 10;
              last if $ptr != -1;
            }
#::logDebug("char='$_' ptr=$ptr\nstring=$overflow[$j]") if $l++ < 10;

            $ptr = 254 if $ptr < 0;

            $ptr++;
            my $string = substr $overflow[$j], 0, $ptr;
            $overflow[$j] = substr $overflow[$j], $ptr;
            push @{$extra[$j]}, $string;
          }
          push @{$extra[$j]}, $overflow[$j];
          $fields[$j] = shift @{$extra[$j]};
        }
        $sheet->write_string($i, $j, $fields[$j]);
      }
      if(@extra) {
        my $max = 0;
        for(@extra) {
          next unless $_;
          my $current = scalar @$_;
          $max = $current if $max < $current;
        }
        for (my $k = 0; $k < $max; $k++) {
          $i++;
          for( $j = 0; $j < scalar @extra; $j++) {
            next unless $_;
            $sheet->write_string($i, $j, $extra[$j][$k]);
          }
        }
      }
      $i++;
    }
    close RECENT;
  }

  unlink($file) if $unlink;
  undef $unlink;
  $done++;
}

close AGG if $opt->{compress};

if($opt->{compress} and $gnum and $gnum =~ /^compress/i) {
  my $file = $agg;
  my $new = "$file.gz";
  eval {
    my $gz = Compress::Zlib::gzopen($new, "wb")
      or die errmsg("error compressing %s to %s: %s", $new, $agg, $!);
    open(ZIN, $file)
      or die errmsg("error opening %s: %s", $file, $!);
    while(<ZIN>) {
      $gz->gzwrite($_)
        or die
          errmsg("gzwrite error on %s: %s", $new, $gz->gzerror());
    }
    $gz->gzclose();
    close ZIN;
  };
  if($@) {
    push @errors, $@;
  }
  else {
    unlink($file);
  }
}
if(@errors) {
  $::Scratch->{ui_error} = '<ul><li>';
  $::Scratch->{ui_error} .= join "</li>\n<li>", @errors;
  $::Scratch->{ui_error} .= '</li></ul>';
}
return $opt->{hide} ? "" : $done;
}
EOR

SEE ALSO

cp(7ic)


Name

backup-file — backup Interchange file

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes Yes File to back-up
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag allows backing up of Interchange files. Files are simply copied to the backup/ subdirectory of the catalog root directory (CATROOT).

File paths are preserved during copy; a target catalog file of say, pages/index.html would be saved to backup/pages/index.html.

You can copy filenames specified with absolute paths, and in fact, you can backup any file that the Interchange process can read.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Backing-up catalog index page

[either]
  [tmp name=backup set="[backup-file pages/index.html]" hide=1]
[or]
  [scratch ui_error]
[/either]

Example: Backing-up system password file

[either]
  [tmp name=backup set="[backup-file /etc/passwd]" hide=1]
[or]
  [scratch ui_error]
[/either]

NOTES

The backup directory and the full pathname are automatically created if they don't already exist.

AVAILABILITY

backup-file is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/backup_file.coretag
Lines: 47


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: backup_file.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag backup-file Order     file
UserTag backup-file AddAttr
UserTag backup-file Version   $Revision: 1.5 $
UserTag backup-file Routine   <<EOR
require File::Copy;
require File::Path;
require File::Basename;
sub {
my ($file, $opt) = @_;
my $bu_file = "backup/$file";
$bu_file =~ s://+:/:g ;
$bu_file =~ m:(.*)/: ;
my $bu_dir = $1;
eval {
  die ::errmsg("Cannot figure out backup directory from %s", $bu_file)
    if ! $bu_dir;
  if (! -d $bu_dir) {
    File::Path::mkpath($bu_dir)
      or die ::errmsg("Cannot make backup directory %s: %s", $bu_dir, $!);
  }
  if (-f $bu_file) {
    my $fn = $bu_file;
    $fn =~ s:.*/::;
    UI::Primitive::rotate($fn, { Directory => $bu_dir } )
      or die ::errmsg("Cannot make backup of %s: %s", $bu_file, $!);
  }
#::logDebug("ready to copy $file to $bu_file");
  File::Copy::copy($file, $bu_file)
    or die ::errmsg("Copy %s to %s: %s", $file, $bu_file, $!);
};
if ($@) {
  $::Scratch->{ui_error} = $@;
  ::logError($::Scratch->{ui_error});
  return undef;
}
return 1;
}
EOR

SEE ALSO

cp(7ic)


Name

banner — display banner ads or messages, based on category and optional weighting

ATTRIBUTES

AttributePos.Req.DefaultDescription
category Yes default For a weighted banner display, this field specifies category name; only database entries where the category field matches this value are taken as possible candidates for display. In an unweighted display, this field specifies banner code; of course, only one database entry with the matching value in the code field should exist.
table   banner The banner table name. The default is reasonable and rarely needs to be changed. my_banner_table can be set to override this value.
r_field   rotate Row in a banner table may include multiple banners in the banner column (separated by specified delimiters). The column specified by r_field is consulted (expecting a boolean value) to determine whether to sequentially rotate banners. This is only used with non-weighted banner display scheme.
b_field   banner Banner descriptor field. In other words, name of the column that will contain actual banner text to display. If a proper delimiter is used, and the r_field column is true, this field may contain multiple banner texts.
c_field   category Specify the column containing banner category. Only banners from the selected category will be taken as possible candidates for display. This is only used with weighted ads.
w_field   weight Specify the table column containing banner weights. This is only used with weighted ads.
separator   : Separator within the table key (the code column), used for multilevel categorized ads. This is only used with unweighted ads.
delimiter   {or} Delimiter that sets different banner texts in the banner field apart. This is only used with unweighted ads.
weighted   0 Use weighted banner system? In a weighted system, the database is expected to contain multiple entries with the same category, and then the banners are selected in regard to their relative weight (more weight = more visibility). The sum of weights can be arbitrary and does not need to equal 1 (obviously - because that would require a manual intervention on every banner addition/remove operation).
once   0 Don't rebuild the banners until the appropriate tmp/Banners/*/total_weight files are manually removed? This is only used with weighted ads.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

Interchange has a built-in banner display system designed to show ad or other messages, according to optional categories and weighted values. All this functionality is accessible using the banner tag.

The weighted system, if used, will pre-built banners in the directory Banners/*/ under the catalog temporary directory (this will happen when the banners are first requested after a catalog reconfiguration or Interchange daemon start). It will build one copy of the banner for every value of weight. If one banner is weighted 7, one 2 and one 1 (in abstract points), then a total of 10 pre-built banners will be made. The first will be displayed 70 percent of the time, the second 20 percent and the third 10 percent, in random fashion. If all banners need to be equal (that is, displayed randomly with the same probability), give each a weight of 1.

Each category has its own separate weighting if categorized display is requested; otherwise all weights enter the same logical "pool".

Note that the term rotation refers to sequentially selecting and displaying banners from the same banner field (keeping a separate counter for each client). This, of course, makes sense in a context where banner contains multiple banner entries, separated by chosen delimiters.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Banner Ads

For the relevant supplemental description and all ready-to-use examples, see the Implement Banner Ads HOW-TO.


NOTES

AVAILABILITY

banner is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/banner.coretag
Lines: 119


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: banner.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag banner              Order        category
UserTag banner              addAttr
UserTag banner              PosNumber    1
UserTag banner              Version      $Revision: 1.6 $
UserTag banner              Routine      <<EOR
sub {
my ($place, $opt) = @_;


sub initialize_banner_directory {
  my ($dir, $category, $opt) = @_;
  mkdir $dir, 0777 if ! -d $dir;
  my $t = $opt->{table} || 'banner';
  my $c_field;
  my $append = '';
  if($category) {
    $append = ' AND ';
    $append .= ($opt->{c_field} || 'category');
    $category =~ s/'/''/g;
    $append .= " = '$category'";
  }
  my $db = database_exists_ref($t);
  if(! $db) {
    my $weight_file = "$dir/total_weight";
    return undef if -f $weight_file;
    $t = "no banners db $t\n";
    Vend::Util::writefile( $weight_file, $t, $opt);
    ::logError($t);
    return undef;
  }
  my $w_field = $opt->{w_field} || 'weight';
  my $b_field = $opt->{b_field} || 'banner';
  my $q = "select $w_field, $b_field from $t where $w_field >= 1$append";
  my $banners = $db->query({
    query => $q,
    st => 'db',
  });
  my $i = 0;
  for(@$banners) {
    my ($weight, $text) = @$_;
    for(1 .. $weight) {
      Vend::Util::writefile(">$dir/$i", $text, $opt);
      $i++;
    }
  }
  Vend::Util::writefile(">$dir/total_weight", $i, $opt);
}


sub tag_weighted_banner {
  my ($category, $opt) = @_;
  my $dir = catfile($Vend::Cfg->{ScratchDir}, 'Banners');
  mkdir $dir, 0777 if ! -d $dir;
  if($category) {
    my $c = $category;
    $c =~ s/\W//g;
    $dir .= "/$c";
  }
  my $statfile = $Vend::Cfg->{ConfDir};
  $statfile .= "/status.$Vend::Cat";
  my $start_time;
  if($opt->{once}) {
    $start_time = 0;
  }
  elsif(! -f $statfile) {
    Vend::Util::writefile( $statfile, "banners initialized " . time() . "\n");
    $start_time = time();
  }
  else {
    $start_time = (stat(_))[9];
  }
  my $weight_file = "$dir/total_weight";
  initialize_banner_directory($dir, $category, $opt)
    if  ( ! -f $weight_file  or  (stat(_))[9] < $start_time );
  my $n = int( rand( readfile($weight_file) ) );
  return Vend::Util::readfile("$dir/$n");
}
return tag_weighted_banner($place, $opt) if $opt->{weighted};

my $table = $opt->{table}     || 'banner';
my $r_field = $opt->{r_field} || 'rotate';
my $b_field = $opt->{b_field} || 'banner';
my $sep  = $opt->{separator}  || ':';
my $delim = $opt->{delimiter} || "{or}";
$place = 'default' if ! $place;
my $totrot;
do {
  my $banner_data;
  $totrot = tag_data($table, $r_field, $place);
  if(! length $totrot) {
    # No banner present
    unless ($place =~ /$sep/ or $place eq 'default') {
      $place = 'default';
      redo;
    }
  }
  elsif ($totrot) {
    my $current = $::Scratch->{"rotate_$place"}++ || 0;
    my $data = tag_data($table, $b_field, $place);
    my(@banners) = split /\Q$delim/, $data;
    return '' unless @banners;
    return $banners[$current % scalar(@banners)];
  }
  else {
    return tag_data($table, $b_field, $place);
  }
} while $place =~ s/(.*)$sep.*/$1/;
return;
}
EOR

SEE ALSO


Name

bar-button — display content (usually a menu bar) based on page name

ATTRIBUTES

AttributePos.Req.DefaultDescription
page YesYes Name of the page for which the button is defined.
current Yes Current page name (as obtained from MV_PAGE). Name of the current page. Usually you do not want to override the default.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag can display content depending on current (or provided) page name. It is most directly useful for creating menu bars (although other uses are not excluded).

The content between the selected/selected tags will be displayed if the name of the current page (MV_PAGE variable, or your custom current argument) matches the page parameter.

The default content (one outside of select tags) will be displayed when there is no match.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: MV_PAGE

EXAMPLES

Example: Create 3-button menubar

Create three different pages, page1.html, page2.html and page3.html, each with the identical content:

<table><tr>

[bar-button page=page1]
<td><a href="[area page1]">PAGE-1</a></td>
[selected]
<td bgcolor="red"><a href="[area page1]"><b>PAGE-1-selected</b></a></td>
[/selected]
[/bar-button]

[bar-button page=page2]
<td><a href="[area page2]">PAGE-2</a></td>
[selected]
<td bgcolor="red"><a href="[area page2]"><b>PAGE-2-selected</b></a></td>
[/selected]
[/bar-button]

[bar-button page=page3]
<td><a href="[area page3]">PAGE-3</a></td>
[selected]
<td bgcolor="red"><a href="[area page3]"><b>PAGE-3-selected</b></a></td>
[/selected]
[/bar-button]

</tr></table>

NOTES

AVAILABILITY

bar-button is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/bar_button.tag
Lines: 25


# Copyright 2003-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: bar_button.tag,v 1.5 2007-03-30 23:40:56 pajamian Exp $

UserTag bar-button Order     page current
UserTag bar-button PosNumber 2
UserTag bar-button HasEndTag 1
UserTag bar-button Version   $Revision: 1.5 $
UserTag bar-button Routine   <<EOR
sub {
use strict;
my ($page, $current, $html) = @_;
$current = $Global::Variable->{MV_PAGE}
if ! $current;
$html =~ s!\[selected\]((?s:.)*)\[/selected]!!i;
my $alt = $1;
return $html if $page ne $current;
return $alt;
}
EOR

SEE ALSO


Name

base-url — retrieve value of the VendURL directive

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag simply returns the value of the VendURL directive.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Retrieving VendURL

Catalog base URL is: [base-url]

NOTES

Similar and more general behavior can be achieved using AutoVariable.

AVAILABILITY

base-url is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/base_url.coretag
Lines: 11


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: base_url.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag base-url Version $Revision: 1.4 $
UserTag base-url Routine sub { return $Vend::Cfg->{VendURL} }


Name

bootmenu

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: MV_TREE_TABLE
Global Variables: MV_PAGE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

bootmenu is available in Interchange versions:

5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: dist/strap/config/bootmenu.tag
Lines: 583


UserTag bootmenu Order        name
UserTag bootmenu hasEndTag
UserTag bootmenu AddAttr
UserTag bootmenu Description  Display menu using jQuery and standard HTML + CSS.
UserTag bootmenu Documentation <<EOD

Returns a menu using an unordered list with associated Bootstrap-recognizable \
 classes (<ul><li>foo</li></ul>). No Javascript is needed for basic functionality.

Call with something like:
[timed-build file="timed/bootmenu" login=1 force=1 minutes=1440][bootmenu \
 name="catalog/menu" timed=1][/bootmenu][/timed-build]
(bootmenu's "name" opt requires a DB menu)
or for simple menu:
[bootmenu file="includes/menus/catalog/menu.txt"][/bootmenu]

You can also put a template inside, and also use "transforms" like "logged_in", e.g.:
[bootmenu file="include/menus/catalog/top.txt" class="nav nav-pills pull-right" logged_in=member]
  <li class="{HELP_NAME}"><a{PAGE?} href="{PAGE}"{/PAGE?} title="{DESCRIPTION}">{NAME}</a>
[/bootmenu]

To be used with Bootstrap and the Javascript plugin for dropdown menus. \
 See http://getbootstrap.com for more.

EOD
UserTag bootmenu Routine      <<EOR

my $indicated;
my $last_line;
my $first_line;
my $logical_field;

my %transform = (
nbsp => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    $row->{$_} =~ s/ /&nbsp;/g;
  }
  return 1;
},
entities => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    $row->{$_} = HTML::Entities::encode_entities($row->{$_});
  }
  return 1;
},
localize => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    $row->{$_} = errmsg($row->{$_});
  }
  return 1;
},
first_line => sub {
  my ($row, $fields) = @_;
  return undef if ref($fields) ne 'ARRAY';
  return 1 if $first_line;
  my $status;
  for(@$fields) {
    if(s/^!\s*//) {
      $status = $status && ! $row->{$_};
    }
    else {
      $status = $status && $row->{$_};
    }
  }
  return $first_line = $status;
},
last_line => sub {
  my ($row, $fields) = @_;
#::logDebug("last_line transform, last_line=$last_line");
  return 1 if ref($fields) ne 'ARRAY';
  return 0 if $last_line;
  my $status;
  for(@$fields) {
#::logDebug("last_line transform checking field $_=$row->{$_}");
    if(s/^!\s*//) {
      $status = ! $row->{$_};
    }
    else {
      $status = $row->{$_};
    }
#::logDebug("last_line transform checked field $_=$row->{$_}, status=$status");
    last if $status;
  }
#::logDebug("last_line transform returning last_line=$status");
  $last_line = $status;
#::logDebug("last_line transform returning status=" . ! $status);
  return ! $status;
},
first_line => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    if(s/^!\s*//) {
      $status = $status && ! $row->{$_};
    }
    else {
      $status = $status && $row->{$_};
    }
  }
  return $status;
},
inactive => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    if(s/^!\s*//) {
      $status = $status && $row->{$_};
    }
    else {
      $status = $status && ! $row->{$_};
    }
  }
  return $status;
},
active => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    if(s/^!\s*//) {
      $status = $status && ! $row->{$_};
    }
    else {
      $status = $status && $row->{$_};
    }
  }
  return $status;
},
ui_security => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    next if ! length($row->{$_});
    $status = $status && Vend::Tags->if_mm('advanced', $row->{$_});
  }
  return $status;
},
full_interpolate => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    next unless $row->{$_} =~ /\[|__[A-Z]\w+__/;
    $row->{$_} = Vend::Interpolate::interpolate_html($row->{$_});
  }
  return 1;
},
page_class => sub {
  my ($row, $fields) = @_;
  return 1 unless $row->{indicated};
  return 1 if $row->{mv_level};
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    my($f, $c) = split /[=~]+/, $_;
    $c ||= $f;
#::logDebug("setting scratch $f to row=$c=$row->{$c}");
    $::Scratch->{$f} = $row->{$c};
  }
  $$indicated = 0;
  return 1;
},
menu_group => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  eval {
    for(@$fields) {
      my($f, $c) = split /[=~]+/, $_;
      $c ||= $f;
      $status = $status && (
              !  $row->{$f}
              or $CGI::values{$c} =~ /$row->{$f}/i
              );
    }
  };
  return $status;
},
superuser => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    $status = $status && (! $row->{$_} or Vend::Tags->if_mm('super'));
  }
  return $status;
},
items  => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  my $nitems = scalar(@{$Vend::Items}) ? 1 : 0;
  for(@$fields) {
    next if ! length($row->{$_});
    $status = $status && (! $nitems ^ $row->{$_});
  }
  return $status;
},
logged_in => sub {
  my ($row, $fields) = @_;
#::logDebug("logged_in... doing:$_, fields=" . ref($fields) . ', ' . uneval($fields));
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    next if ! length($row->{$_});
    $status = $status && (! $::Vend::Session->{logged_in} ^ $row->{$_});
  }
#::logDebug("logged_in... got here. doing:$_, status=$status, row=$row->{$_}");
  return $status;
},
depends_on => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    next if ! $row->{$_};
    $status = $status && $CGI::values{$row->{$_}};
  }
  return $status;
},
exclude_on => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  my $status = 1;
  for(@$fields) {
    $status = $status && (! $CGI::values{$row->{$_}});
  }
  return $status;
},
indicator_class => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    my ($indicator,$rev, $last, $status);
    my($s,$r) = split /=/, $_;
    $rev = $indicator =~ s/^\s*!\s*// ? 1 : 0;
    $last = $indicator =~ s/\s*!\s*$// ? 1 : 0;
#::logDebug("checking scratch $s=$::Scratch->{$s} eq row=$r=$row->{$r}");
    $status = $::Scratch->{$s} eq $row->{$r};
    if($rev xor $status) {
      $row->{indicated} = 1;
    }
    last if $last;
  }
  if($row->{indicated}) {
    $indicated = \$row->{indicated};
  }
  return 1;
},
indicator_profile => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    my ($indicator,$rev, $last, $status);
    next unless $indicator = $row->{$_};
    $rev = $indicator =~ s/^\s*!\s*// ? 1 : 0;
    $last = $indicator =~ s/\s*!\s*$// ? 1 : 0;
    $status = Vend::Tags->run_profile($indicator);
    if($rev xor $status) {
      $row->{indicated} = 1;
      next unless $last;
    }
    last if $last;
  }
  return 1;
},
indicator_page => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    if ($::Scratch->{mv_logical_page} eq $row->{$_}) {
      unless(
          $::Scratch->{mv_logical_page_used}
          and $::Scratch->{mv_logical_page_used}
            ne
          $row->{$logical_field}
        )
    {
      $row->{indicated} = 1;
      $::Scratch->{mv_logical_page_used} = $row->{$logical_field};
      last;
    }
  }
  ($row->{indicated} = 1, last)
    if  $Global::Variable->{MV_PAGE} eq $row->{$_}
    and ! defined $row->{indicated};
}
return 1;
},
indicator => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    my ($indicator,$rev, $last, $status);
    next unless $indicator = $row->{$_};
    $rev = $indicator =~ s/^\s*!\s*// ? 1 : 0;
    $last = $indicator =~ s/\s*!\s*$// ? 1 : 0;
    if($indicator =~ /^\s*([-\w.:][-\w.:]+)\s*$/) {
      $status =  $CGI::values{$1};
    }
    elsif ($indicator =~ /^\s*`(.*)`\s*$/s) {
      $status = Vend::Interpolate::tag_calc($1);
    }
    elsif ($indicator =~ /\[/s) {
      $status = Vend::Interpolate::interpolate_html($indicator);
      $status =~ s/\s+//g;
    }
    if($rev xor $status) {
      $row->{indicated} = 1;
    }
    else {
      $row->{indicated} = '';
    }
    last if $last;
  }
  return 1;
},
expand_values_form => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    next unless $row->{$_} =~ /\%5b|\[/i;
    my @parms = split $Global::UrlSplittor, $row->{$_};
    my @out;
    for my $p (@parms) {
      my ($parm, $val) = split /=/, $p, 2;
      $val = unhexify($val);
      $val =~ s/\[cgi\s+([^\[]+)\]/$CGI::values{$1}/g;
      $val =~ s/\[var\s+([^\[]+)\]/$::Variable->{$1}/g;
      $val =~ s/\[value\s+([^\[]+)\]/$::Values->{$1}/g;
      push @out, join('=', $parm, hexify($val));
    }
    $row->{$_} = join $Global::UrlJoiner, @out;
  }
  return 1;
},
expand_values => sub {
  my ($row, $fields) = @_;
  return 1 if ref($fields) ne 'ARRAY';
  for(@$fields) {
    next unless $row->{$_} =~ /\[/;
    $row->{$_} =~ s/\[cgi\s+([^\[]+)\]/$CGI::values{$1}/g;
    $row->{$_} =~ s/\[var\s+([^\[]+)\]/$::Variable->{$1}/g;
    $row->{$_} =~ s/\[value\s+([^\[]+)\]/$::Values->{$1}/g;
  }
  return 1;
},
);

sub reset_transforms {
#::logDebug("resetting transforms");
my $opt = shift;
if($opt) {
  $logical_field = $opt->{logical_page_field} || 'name';
}
undef $last_line;
undef $first_line;
undef $indicated;
}

sub {
my($name, $opt, $template) = @_;

reset_transforms($opt);

my @transform;
my @ordered_transform = qw/full_interpolate indicator_page page_class \
 indicator_class localize entities nbsp/;
my %ordered;
@ordered{@ordered_transform} = @ordered_transform;

for(keys %transform) {
  next if $ordered{$_};
  next unless $opt->{$_};
  my @fields = grep /\S/, split /[\s,\0]+/, $opt->{$_};
  $opt->{$_} = \@fields;
#::logDebug("opt $_ = " . uneval(\@fields));
  push @transform, $_;
}
for(@ordered_transform) {
  next unless $opt->{$_};
  my @fields = grep /\S/, split /[\s,\0]+/, $opt->{$_};
  $opt->{$_} = \@fields;
  push @transform, $_;
}
$opt->{_transform} = \@transform;
#::logDebug("in menu sub main");

my @out;

$template = <<EOF if $template !~ /\S/;
  {INDICATOR?}<li class="{INDICATOR}">{/INDICATOR?}
{INDICATOR:}<li class="{BOOT_LI}">
  <a{PAGE?} href="{PAGE}"{/PAGE?} title="{DESCRIPTION}" class="{LINK_CLASS}" \
 \
 {BOOT_CONTENT}>{ICON?}{ICON} {/ICON?}{NAME}{CARET?} {CARET}{/CARET?}</a>
{/INDICATOR:}
EOF

my $top_timeout = $opt->{timeout} || 1000;

my %o = (
  start       => $opt->{tree_selector} || $opt->{name},
  file    => $opt->{file},
  table       => $opt->{table} || $::Variable->{MV_TREE_TABLE} || 'tree',
  master      => 'parent_fld',
  subordinate => 'code',
  autodetect  => '1',
  sort        => $opt->{sort} || 'code',
    full        => '1',
    timed    => $opt->{timed},
    spacing     => '4',
    _transform   => $opt->{_transform},
  );

for(@{$opt->{_transform} || []}) {
  $o{$_} = $opt->{$_};
}

my $main;
my $rows;
if($opt->{iterator}) {
  $o{iterator} = $opt->{iterator};
  $main =  Vend::Tags->tree(\%o);
  $rows = $o{object}{mv_results};
}
else {
  Vend::Tags->tree(\%o);
#::logDebug("bootmenu: " . uneval({ ref => \%o }) );
  my @o;
  for(@{$o{object}{mv_results}}) {
    next if $_->{deleted};

    for my $tr (@{$o{_transform}}) {
#::logDebug("running transform: $tr, on: " . uneval($_) . ", " . uneval($opt->{$tr}));
      my $status = $transform{$tr}->($_, $opt->{$tr});
#::logDebug("transform... status=$status, did: $tr, result: " . uneval($_));
      $opt->{next_level} = $_->{mv_level}
        if ! $status;
      $_->{deleted} = 1 unless $status;
    }

    if($_->{page} and $_->{page} !~ m{^(\w+:)?/}) {
      my $form = $_->{form};
      if($form and $form !~ /[\r\n]/) {
        $form = join "\n", split $Global::UrlSplittor, $form;
      }

      $_->{page} = "" if $_->{page} eq 'index';

      my $add = ($::Scratch->{mv_add_dot_html} && $_->{page} !~ /\.\w+$/) || 0;

      $_->{page} = Vend::Tags->area({
                  href => $_->{page},
                  form => $form,
                  no_count => $o{timed},
                  add_dot_html => $add,
                  no_session_id => $o{timed},
                  auto_format => 1,
                }) unless $_->{page} =~ /^#/;

    }
    
    push @o, $_ unless $_->{deleted};
  }
  $rows = \@o;
}

$rows->[-1]{mv_last_row} = 1 if @$rows;

#::logDebug("rows = " . ::uneval({ ref => $rows }) );

$name =~ s|/|_|g;
$opt->{ul_id} ||= $name;
$opt->{class} ||= 'nav navbar-nav';

my $id = $opt->{ul_id} ? q{ id="$opt->{ui_id}"} : '';
my $style = $opt->{style} ? q{ style="$opt->{style}"} : '';

push @out, <<EOF;
<ul$id class="$opt->{class}"$style $opt->{extra}>
EOF

#return Vend::Tags->uneval({ ref => $rows });

## Dropdown classes

my $boot_content = qq| data-toggle="dropdown" role="button" data-target="#"|;
my $boot_class = qq|dropdown-toggle|;
my $boot_li = qq|dropdown|;
my $caret = $opt->{caret} || qq|<b class="caret"></b>|;

my $class = $opt->{class};
my $link_class = $opt->{link_class};
my $li_class = $opt->{li_class};

my $z = 0;
my $last_level = 0;

for my $row (@$rows) {
#Debug("mvlevel:$row->{mv_level} last:$last_level lastrow:$row->{mv_last_row} z:$z");
  next if $row->{deleted};
  if($row->{mv_children} > 0){
    $row->{boot_content} = $boot_content;
    $row->{link_class} = "$boot_class $link_class";
    $row->{caret} = $caret;
    $row->{boot_li} = "$boot_li $li_class";
  }
  else{
    $row->{link_class} = $link_class;
    $row->{boot_li} = "$li_class";
  }

  ## Allow for bootstrap icon set

  unless ($row->{img_icon} =~ /\.(jpg|gif|png|jpeg)$/i){
    $row->{icon} = qq|<i class="$row->{img_icon}"></i>| if $row->{img_icon};
  }

  my ($in_template, $list_open, $list_close);
  if($row->{mv_level} > $last_level) {   # new nested list
    $list_open = <<EOF;
<ul class="dropdown dropdown-menu">
EOF

  }
  elsif($row->{mv_level} < $last_level) {   # end of nested list
    $list_close = <<EOF;
  <!-- level:$row->{mv_level} -->
  </li>
</ul>
  </li>
EOF
    my $add_close = <<EOF;
</ul>
EOF
    my $level_diff = $last_level - $row->{mv_level};
    for(2..$level_diff) {
      $list_close .= $add_close;
    }
  }
  elsif ($z) {
    $list_close = <<EOF;
  </li>
EOF
  }
  $in_template = $list_close . $list_open . $template;
  if($row->{mv_last_row}) {

    my $scl = <<EOF;
  </li>
EOF
    my $cl = <<EOF;
  </li>
</ul>
EOF
    if ($row->{mv_level} == 1){
      $in_template .= $cl;
    }
    elsif ($row->{mv_level} > 1) {
      while($last_level >= 0){
        $in_template .= $cl;
        $last_level--;
      }
    }
    $in_template .= $scl;
  }

  push @out, Vend::Tags->uc_attr_list($row, $in_template);
  $last_level = $row->{mv_level};
  $z++;
}

push @out, <<EOF;
</ul>
EOF

return join "", @out;
}

EOR

SEE ALSO


Name

breadcrumbs

ATTRIBUTES

AttributePos.Req.DefaultDescription
title
reset_on_product
template
joiner
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

breadcrumbs is available in Interchange versions:

4.6.0-5.6.0

SOURCE

Interchange 5.6.0:

Source: dist/standard/config/breadcrumbs.tag
Lines: 198


# Copyright 2004-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: breadcrumbs.tag,v 1.5 2007-08-09 13:40:53 pajamian Exp $

UserTag breadcrumbs Order number
UserTag breadcrumbs addAttr
UserTag breadcrumbs Routine <<EOR
sub {
my ($number, $opt) = @_;

use vars qw/$Tag $Scratch $CGI $Session $Variable/;
my $only_last = $::Variable->{BREADCRUMB_ONLY_LAST} || 'ord/basket login';
my $exclude   = $::Variable->{BREADCRUMB_EXCLUDE};
my $max   = $number || $::Variable->{BREADCRUMB_MAX} || 6;

my %exclude;
my %only_last;

my @exclude = split /[\s,\0]+/, $exclude;
my @only_last = split /[\s,\0]+/, $only_last;
@exclude{@exclude} = @exclude;
@only_last{@only_last} = @only_last;

my $curpage = $Global::Variable->{MV_PAGE};
my $titles = $Scratch->{bc_titles} ||= {};

my %special = (
scan => sub { 
    my $url = shift;
    my @items = split m{/}, $url;

    my $title;
    for(@items) {
      if(s/^se=//) {
        $title = $_;
      }
      elsif(s/^va=banner_text=//) {
        $title = $_;
      }
    }
    return ($title, $title);
  },
);

my $curhist   = $Session->{History}->[-1] || [];
my $curparams = $curhist->[1] || {};

my $keyname;

my $curfull = $curhist->[0];
$curfull =~ s/$Vend::Cfg->{HTMLsuffix}$//;
$curfull =~ s{^/}{};
my ($curaction,$curpath) = split m{/}, $curfull, 2;

my $ptitle = $opt->{title} || $curparams->{short_title};
$ptitle ||= $Scratch->{short_title};

my $db;

my @extra;

if($special{$curaction} and ! $ptitle) {
  ($ptitle, $keyname) = $special{$curaction}->($curpath);
}
elsif(
    $Vend::Flypart
      and
    $db = Vend::Data::product_code_exists_ref($Vend::Flypart)
  )
{
  my $tab = $db->name();
  my $record = tag_data($tab, undef, $Vend::Flypart, { hash => 1});
  $ptitle = $keyname = $record->{$Vend::Cfg->{DescriptionField}};

  if($record and $record->{prod_group}) {
    my @parms;
    push @parms, "fi=$tab";
    push @parms, "co=yes";
    push @parms, "st=db";
    push @parms, "sf=prod_group";
    push @parms, "se=$record->{prod_group}";
    push @parms, "op=eq";
    push @extra, {
      key => $record->{prod_group},
      title => $record->{prod_group},
      description => undef,
      url => $Tag->area({ search => join("\n", @parms) }),
    };
  }
  if($record and $record->{category}) {
    my @parms;
    push @parms, "fi=$tab";
    push @parms, "co=yes";
    push @parms, "st=db";
    if($record->{prod_group}) {
      push @parms, "sf=prod_group";
      push @parms, "se=$record->{prod_group}";
      push @parms, "op=eq";
    }
    push @parms, "sf=category";
    push @parms, "se=$record->{category}";
    push @parms, "op=eq";
    push @extra, {
    key => $record->{category},
    title => $record->{category},
    description => undef,
    url => $Tag->area({ search => join "\n", @parms }),
  };
}
}

if(! $ptitle) {
$ptitle = $Scratch->{page_title};
$ptitle =~ s/(\s*\W+\s*)?$Variable->{COMPANY}(\s*\W+\s*)?//;
}

$ptitle =~ s/^\s+//;
$ptitle =~ s/\s+$//;

$keyname ||= $curpage;

$titles->{$curpage} = $ptitle if $ptitle;

my %exclude_param = qw(
  mv_pc 1
  bread_reset 1
);

if($Scratch->{bread_reset} || $CGI->{bread_reset}) {
  delete $Session->{breadcrumbs};
}

my $crumbs = $Session->{breadcrumbs} ||= [];
my $crumb;

if($opt->{reset_on_product} and @extra) {
#::logDebug("Resetting based on product");
  @$crumbs = ();
}

if(! $exclude{$curpage}) {
  my $form = '';
  if(! $CGI->{bread_no_params}) {
    for(grep !$exclude_param{$_}, keys %$curparams) {
       $form .= "\n$_=";
       $form .= join("\n$_=", split /\0/, $curparams->{$_});
    }
  }
  $crumb = {
    key => $keyname,
    title => HTML::Entities::encode($ptitle),
    description => HTML::Entities::encode($Scratch->{page_description}),
    url => $Tag->area({ href => $curfull, form => $form, secure => $CGI->{secure} }),
  };
}

push @$crumbs, @extra if @extra;
push @$crumbs, $crumb if $crumb;

my %seen;
my @new = grep !$seen{$_->{key}}++, reverse @$crumbs;

my $did_one;
for(@new) {
  ## Kill ones that only are allowed in last position
  if( $did_one and $only_last{$_->{key}}) {
    $_ = undef;
  }
  $did_one = 1;
}

if(@new > $max) {
  splice @new, $max;
}

@$crumbs = grep $_, reverse @new;

my $tpl = $opt->{template} || <<EOF;
<a href="{url}"{description?} title="{description}"{/description?} class=breadlink>{title}</a>
EOF

my @out;
for(@$crumbs) {
  next unless ref($_) eq 'HASH' and $_->{url};
  my $link = tag_attr_list($tpl, $_);
#::logDebug("link=$link from:\ntpl=$tpl\ncrumb=" . ::uneval($_));
  push @out, $link;
}

$opt->{joiner} = '&nbsp;&gt;&nbsp;' unless defined $opt->{joiner};
return join $opt->{joiner}, @out;
}
EOR

SEE ALSO


Name

button — create HTML or JavaScript form submit button

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes mv_clickButton name.
src Yes   Image file to use. If the value starts with http, it is used as-is. Otherwise the tag makes sure the image file is reachable. Requires js.
text Yes   Button text. scratch variable of the same name is also created to hold the code associated with the button.
wait-text     Button text to show while the next page is being loaded. If defined, this is used for the scratch variable name instead of the text argument value. Requires js.
form   First form on the page (document.forms[0])Form name that this button will submit.
confirm     Text for the "Yes/No" confirmation window that will show up before the client's browser starts with form submission. Requires js.
getsize   0 Use Image::Size Perl module to determine image size and add width and height attributes to the image definition?
alt   Value of the text parameter.Alternate text for the browser status bar (window.status) and balloons.
anchor   Value of text HTML anchor name.
hidetext   0Hide button text?
extra   None. Extra HTML attributes. Passed verbatim.
name , id , class , style    The standard HTML attributes.
id | class | style    The usual CSS attributes.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag creates a mv_click HTML form submit button.

Standard, text-only submit button is output in the form of <input type='submit' ...>.

js submit button can contain an image in place of the standard button text and is output as a combination of <a href=...> and <img src=...> HTML tags. It can also produce other enhancements to the plain submit button, such as confirmation popup windows.

See the section called “EXAMPLES” for illustrative presentation.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: DOCROOT

EXAMPLES

Example: Submit button with an image and confirmation window

Notice the tags used in the button body:

[button text="Delete item" confirm="Are you sure?" src="delete.gif"]
  [comment]
    [button] element's body specifies the action code. It is what you would
    put inside [set Delete item][/set] if you were creating the button
    manually.
  [/comment]
  [mvtag] Use any Interchange tag here, i.e. ....[/mvtag]
  [perl] # code to delete item [/perl]
[/button]

We are here to discuss the usage of the button tag, but let's take a look at an example equivalent to the one above, except that we create the button manually:

[set Delete item]
  [comment]
    [button] element's body specifies the action code.
  [/comment]
  [mvtag] Use any Interchange tag here, i.e. ....[/mvtag]
  [perl] # code to delete item [/perl]
[/set]

<input type='submit' name='mv_click' value='Delete item'>

[button text="Click me"]
  [javascript]onClick="myOwnOnClickFunction(this);"[/javascript]
[/button]

NOTES

The button tag can work with unnamed forms.

AVAILABILITY

button is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/button.tag
Lines: 256


# Copyright 2002-2008 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: button.tag,v 1.25 2008-06-15 19:11:16 jure Exp $

UserTag button Order     name src text
UserTag button addAttr
UserTag button attrAlias value text
UserTag button hasEndTag
UserTag button Version   $Revision: 1.25 $
UserTag button Routine   <<EOR
sub {
my ($name, $src, $text, $opt, $action) = @_;

my $trigger_text;

if($opt->{wait_text}) {
  $trigger_text = $opt->{wait_text};
}
else {
  $trigger_text = $text;
}

my @js;
my $image;

my @from_html = qw/class id style/;

if($src) {
if( $opt->{srcliteral} || $src =~ m{^https?://}i ) {
  $image = $src;
}
else {
  my $dr = $::Variable->{DOCROOT};
  my $id = $Tag->image( { dir_only => 1 } );
  $id =~ s:/+$::;
  $id =~ s:/~[^/]+::;

    if( $dr and $id and $src =~ m{^[^/]} and -f "$dr$id/$src" ) {
      $image = $src;
    }
    elsif( $dr and $src =~ m{^/} and -f "$dr/$src" ) {
      $image = "$id/$src";
    }
    else {
      ::logError("No image file '$src' found or image file name is invalid.");
    }
  }
}
my $onclick = '';
my $onmouseover = '';
my $onmouseout = '';
while($action =~ s! \[
          (
            j (?:ava)? s (?:cript)?
          )
          \]
            (.*?)
          \[ / \1 \]
          !!xis
  )
{
  my $script = $2;
  $script =~ s/\s+$//;
  $script =~ s/^\s+//;
  if($script =~ s/\bonclick\s*=\s*"(.*?)"//is) {
    $onclick = $1;
    next;
  }
  if ($script =~ s/\bonmouse(\w+)\s*=\s*"(.*?)"//is) {
    if (lc($1) eq 'over') {
      $onmouseover .= ($onmouseover ? ';' : '') . $2;
    }
    elsif (lc($1) eq 'out') {
      $onmouseout .= ($onmouseout ? ';' : '') . $2;
    }
    else {
      logError(q{Skipping 'onmouse%s', invalid JavaScript event}, $1);
    }
    next;
  }
  push @js, $script;
}

if(! $name or $name eq 'mv_click') {
  $action =~ s/^\s+//;
  $action =~ s/\s+$//;
  my $set_text = HTML::Entities::decode($trigger_text);
  $::Scratch->{$set_text} = $action;
  $name = 'mv_click' if ! $name;
}

my $out = '';
my $confirm = '';
my $wait = '';
$opt->{extra} = $opt->{extra} ? " $opt->{extra}" : '';
if($opt->{confirm}) {
  $opt->{confirm} =~ s/'/\\'/g;
  $confirm = "confirm('$opt->{confirm}')";
}

if($onclick) {
  $confirm .= ' && ' if $confirm;
  $onclick = qq{ onClick="$confirm$onclick"};
}

# Constructing form button. Will be sent back in all cases,
# either as the primary button or as the <noscript> option
# for JavaScript-challenged browsers.
$text =~ s/"/&quot;/g;
$name =~ s/"/&quot;/g;
$out = qq{<input type="submit" name="$name" value="$text"$onclick$Vend::Xtrailer>};
if (@js) {
  $out =~ s/ /join "\n", '', @js, ''/e;
}

$opt->{extra} ||= '';
for(@from_html) {
  next unless $opt->{$_};
  $opt->{extra} .= qq{ $_="$opt->{$_}"};
}

# return submit button if not an image
if(! $image) {
  $text =~ s/"/&quot;/g;
  $name =~ s/"/&quot;/g;
  if(! $onclick and $confirm) {
    $onclick = qq{ onclick="return $confirm"};
  }
  elsif(! $onclick and $opt->{wait_text}) {
    $opt->{wait_text} = HTML::Entities::encode($trigger_text);
    $onclick  = qq{ onClick="};
    $onclick .= qq{var msg = 'Already submitted.';};
    $onclick .= qq{this.value = '$opt->{wait_text}';};
    $onclick .= qq{this.onclick = 'alert(msg)'; return true;};
    $onclick .= qq{"};
  }

  my $out = $opt->{bold} ? '<b>' : '';
  $out .= qq{<input$opt->{extra} type="submit" name="$name" value="$text"$onclick$Vend::Xtrailer>};
  $out .= '</b>' if $opt->{bold};
  if(@js) {
    $out =~ s/ /join "\n", '', @js, ''/e;
  }
  return $out;
}

# If we got here the button is an image
# Wrap form button code in <noscript>
my $no_script = qq{<noscript>$out</noscript>\n};
$out = '';

my $wstatus = $opt->{alt} || $text;
$wstatus =~ s/'/\\'/g;

my $clickname = $name;
my $clickvar = $name;
if($image and $name eq 'mv_click') {
  $clickvar = $text;
  $clickvar =~ s/\W/_/g;
  $clickname = "mv_click_$clickvar";
  $out = qq{<input type='hidden' name='mv_click_map' value='$clickvar'$Vend::Xtrailer>};
}

$out .= qq{<input type='hidden' name='$clickname' value=''$Vend::Xtrailer>} if $image; 

my $formname;
$opt->{form} = 'forms[0]'
  if ! $opt->{form};

$confirm .= ' && ' if $confirm;
$opt->{border} = 0 if ! $opt->{border};

if($opt->{getsize}) {
  eval {
    require Image::Size;
    ($opt->{width}, $opt->{height}) = Image::Size::imgsize($image);
  };
}

$opt->{align} = 'top' if ! $opt->{align};

my $position = '';
for(qw/height width vspace hspace align/) {
  $position .= " $_='$opt->{$_}'" if $opt->{$_};
}

my $anchor = '';
unless( $opt->{hidetext}) {
  $anchor = $opt->{anchor} || $text;
  $anchor =~ s/ /&nbsp;/g;
  $anchor = "<b>$anchor</b>";
}

my $a_before = '</a>';
my $a_after  = '';
if($opt->{link_text_too}) {
  $a_before = '';
  $a_after = '</a>';
}

$opt->{link_href} ||= 'javascript: void 0';
if ($onclick =~ /^\s*onclick\s*=\s*"(.*?)"/i) {
  $onclick = $1 . ' && ';
}
# QUOTING (fix here too?)
$out .= <<EOF;
<a href="$opt->{link_href}"$opt->{extra} onMouseOver="window.status='$wstatus';$onmouseover"
EOF
$out .= <<EOF if $onmouseout;
onMouseOut="$onmouseout"
EOF
$out .= <<EOF;
onClick="$confirm $onclick mv_click_map_unique(document.$opt->{form}, \
 '$clickname', '$text') && $opt->{form}.submit(); return(false);"
alt="$wstatus"><img alt="$wstatus" src="$src" border='$opt->{border}'$position>$a_before$anchor$a_after
EOF

my $function = '';
unless ($::Instance->{js_functions}{mv_do_click}++) {
  $function = "\n" . <<'EOJS';
function mv_click_map_unique(myform, clickname, clicktext) {
for (var i = 0; i < myform.length; i++) {
  var widget = myform.elements[i];
  if (
    (widget.type == 'hidden')
    && (widget.name != 'mv_click_map')
    && (widget.name.indexOf('mv_click_') == 0)
  )
    widget.value = (widget.name == clickname) ? clicktext : '';
}
return true;
}
EOJS
}

# Must escape backslashes and single quotes for JavaScript write function.
# Also must get rid of newlines and carriage returns.
$out =~ s/(['\\])/\\$1/g;
$out =~ s/[\n\r]+/ /g;
$out = <<EOV;
<script language="javascript1.2" type="text/javascript">
<!--$function
document.write('$out');
// -->
</script>
$no_script
EOV

return $out;
}

EOR


Name

calc — evaluate the enclosed arithmetic expression or Perl block

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   1interpolate input?
reparse   1interpolate output?

DESCRIPTION

The tag evaluates the enclosed arithmetic expression or a Perl block. The last expression evaluated (return value) is returned to the client page.

Note that Perl blocks can be of arbitrary content and complexity, and there really are no typical examples to show.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Simple Perl code, a random arithmetic expression

Current magic number is: [calc]2+rand[/calc]

Example: Retrieving an Interchange session value

Welcome, your user name is [calc]$Tag->data(qw/session username/)[/calc]

Example: Setting and displaying a value

Order number is:
  [calc] $Session->{mv_order_number} = $Values->{mv_order_number} [/calc]

Example: Clearing the return value

You can clear the return value (that is, return nothing) by simply calling return with no arguments:

[calc] my $a = 5; return [/calc]

NOTES

The calc tag is lower-overhead variant of perl, because it does not accept arguments, does not try to interpolate tag body (well, calcn tag only) , does not pre-open any database tables, and it doesn't do any extra wrapping.

The calc tag will remember variable values inside the page, so you can do the equivalent of a memory store and memory recall for a loop. In other words, variables you initialize or set in one calc block are also visible in all further calc blocks on the same page.

There is no reason to ever use this tag inside perl or mvasp.

calc and perl are the two tags that play major role in any Perl programming within Interchange.

AVAILABILITY

calc is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/calc.coretag
Lines: 13


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: calc.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag calc                hasEndTag
UserTag calc                Interpolate
UserTag calc                Version      $Revision: 1.4 $
UserTag calc                MapRoutine   Vend::Interpolate::tag_calc

Source: lib/Vend/Interpolate.pm
Lines: 2823

sub tag_calc {
my($body) = @_;
my $result;
if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
}

$Items = $Vend::Items;

if($MVSAFE::Safe) {
  $result = eval($body);
}
else {
  init_calc() if ! $Vend::Calc_initialized;
  $result = $ready_safe->reval($body);
}

if ($@) {
  my $msg = $@;
  $Vend::Session->{try}{$Vend::Try} = $msg if $Vend::Try;
  logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body);
  logError("Safe: %s\n%s\n" , $msg, $body);
  return $MVSAFE::Safe ? '' : 0;
}
return $result;
}

Source: lib/Vend/Interpolate.pm
Lines: 2823

sub tag_calc {
my($body) = @_;
my $result;
if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
}

$Items = $Vend::Items;

if($MVSAFE::Safe) {
  $result = eval($body);
}
else {
  init_calc() if ! $Vend::Calc_initialized;
  $result = $ready_safe->reval($body);
}

if ($@) {
  my $msg = $@;
  $Vend::Session->{try}{$Vend::Try} = $msg if $Vend::Try;
  logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body);
  logError("Safe: %s\n%s\n" , $msg, $body);
  return $MVSAFE::Safe ? '' : 0;
}
return $result;
}


Name

calcn — evaluate the enclosed arithmetic expression or Perl block

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

The tag evaluates the enclosed arithmetic expression or a Perl block. The last expression evaluated (return value) is returned back to the client page.

The tag is only a convenience and otherwise identical to calc, except that it does not interpolate tag body by default.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Simple non-interpolating block

The example will, since calcn is used, directly return the quoted content unmodified, instead of evaluating to "TEST":

[cgi name=test set=TEST hide=1]

[calcn reparse=0] "[cgi test]" [/calcn]

NOTES

See calc for the complete documentation.

AVAILABILITY

calcn is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/calcn.coretag
Lines: 12


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: calcn.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag calcn               hasEndTag
UserTag calcn               Version      $Revision: 1.4 $
UserTag calcn               MapRoutine   Vend::Interpolate::tag_calc

Source: lib/Vend/Interpolate.pm
Lines: 2823

sub tag_calc {
my($body) = @_;
my $result;
if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
}

$Items = $Vend::Items;

if($MVSAFE::Safe) {
  $result = eval($body);
}
else {
  init_calc() if ! $Vend::Calc_initialized;
  $result = $ready_safe->reval($body);
}

if ($@) {
  my $msg = $@;
  $Vend::Session->{try}{$Vend::Try} = $msg if $Vend::Try;
  logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body);
  logError("Safe: %s\n%s\n" , $msg, $body);
  return $MVSAFE::Safe ? '' : 0;
}
return $result;
}


Name

captcha — handle captcha images used for authentication

ATTRIBUTES

AttributePos.Req.DefaultDescription
function | func Yes Yes captcha function
length 4 length of the captcha code
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag generates and/or checks "captcha" images to authenticate user input. If called for the first time in a page, it generates a code/image pair and sets the code in the session (at $Vend::Session->{captcha}).

The captcha tag provides the following functions:

check

Checks the captcha source code (presumably from the previous page) against the guess. If it matches, returns 1. If not, returns 0 and puts error in $Tag->error.

code

Returns the generated code. Generates one if not done previously in session.

The image, relative_image and image_tag functions are undocumented.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: CAPTCHA_IMAGE_SUBDIR, CAPTCHA_IMAGE_LOCATION, DOCROOT, CAPTCHA_IMAGE_PATH, IMAGE_DIR, CAPTCHA_UMASK

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

captcha uses the Authen::Captcha module from CPAN.

AVAILABILITY

captcha is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/captcha.coretag
Lines: 294


# Copyright 2006-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: captcha.coretag,v 1.4 2007-03-30 23:55:57 pajamian Exp $

UserTag captcha Order    function
UserTag captcha attrAlias  func function
UserTag captcha addAttr
UserTag captcha Description  Generate captcha codes for authentication check
UserTag captcha Version    $Revision: 1.4 $

UserTag captcha Routine    <<EOR
my $Have_Captcha;
eval {
 require Authen::Captcha;
 $Have_Captcha = 1;
};

sub {
 my ($func, $opt) = @_;

 use vars qw/$Tag/;

 if(! $Have_Captcha) {
   ::logError("Use of captcha tag without Authen::Captcha, skipping");
   return '';
 }
 
 $func = lc($func);
$func =~ s/[^a-z]+//g;
my $result = '';
if($func eq 'code') {
 $result = $Vend::Session->{captcha};
}

$opt->{length} ||= 4;
my $en = $opt->{error_name} || 'captcha';

my $subdir = $opt->{image_subdir}
|| $::Variable->{CAPTCHA_IMAGE_SUBDIR}
|| 'captcha';
my $tmpdir = "$Vend::Cfg->{ScratchDir}/$subdir";

mkdir($tmpdir) unless -d $tmpdir;

my $imgdir = $opt->{image_location} || $::Variable->{CAPTCHA_IMAGE_LOCATION};

unless ($imgdir ) {
if(! $Global::NoAbsolute and $::Variable->{DOCROOT}) {
$imgdir = "$::Variable->{DOCROOT}$::Variable->{IMAGE_DIR}/$subdir";
}
else {
$imgdir = "images/$subdir";
}
}

my $imgpath = $opt->{image_path}
      || $::Variable->{CAPTCHA_IMAGE_PATH}
      || "$::Variable->{IMAGE_DIR}/$subdir";


my $captcha = Authen::Captcha->new(
        data_folder => $tmpdir,
         output_folder => $imgdir,
       );

 my $guess   = $opt->{guess} || $CGI::values{mv_captcha_guess};
 my $code    = $opt->{source};

 if($func eq 'check') {

   my $check_against = $code || $Vend::Session->{captcha};
   my $status = $captcha->check_code($guess, $check_against);
   if($status > 0) {
     return $status;
   }
   elsif($status == 0) {
     $Tag->error( { name => $en, set => "Code not checked: error" });
     return 0;
   }
   elsif($status == -1) {
     $Tag->error( { name => $en, set => "Code expired" });
     return 0;
   }
   elsif($status == -2) {
     $Tag->error( { name => $en, set => "Code never generated" });
     return 0;
 }
 elsif($status == -3) {
   $Tag->error( { name => $en, set => "Code doesn't match" });
   return 0;
 }
}
else {
 # Used for [captcha-refresh] if requested
 $::Instance->{last_captcha_build_opt} = { %$opt };

   my $save_u = umask($::Variable->{CAPTCHA_UMASK} || 2);

 if($opt->{reset}) {
   undef $Vend::Captcha;
   delete $Vend::Session->{captcha};
   }

   if($Vend::Captcha) {
     $code ||= $Vend::Session->{captcha};
   }

   if($func eq 'code' and $code) {
     return $code;
   }

    eval {

   unless( Vend::File::allowed_file($imgdir, 1) ) {
     my $msg = errmsg("No permission to write directory '%s'", $imgdir);
     $Tag->error( { name => $en, set => $msg });
     return 0;
   }

   mkdir($imgdir) unless -d $imgdir;

   if(! $code) {
     $code = $Vend::Session->{captcha} = $captcha->generate_code($opt->{length});
     $Vend::Captcha = $code;
   }
   umask $save_u;
    };

   if($@) {
     $Tag->error( { name => $en, set => "Error: $@" });
     return '';
   }

   if($func eq 'code') {
     return $code;
   }
 
   # Now probably an image function.

   unless ($func =~ /ima?ge?/)  {
     $Tag->error({
             name => $en,
             set => errmsg("Unknown function %s", $func),
           });
     return undef;
   }

   my $path = $opt->{relative} ? "$subdir/$code.png" : "$imgpath/$code.png";

   if(! $opt->{name_only}) {
     return   $Tag->image($path);
   }
   else {
     return $path;
   }
 }

}
EOR

UserTag captcha Documentation <<EOD
=head1 NAME

Interchange [captcha] tag

=head1 SYNOPSIS

 [captcha  function="check|code|image|relative_image|image_tag"
           length="4"
           image-subdir="captcha"
           image-location="images/captcha"
           image-path="/standard/images/captcha"
           source="[cgi mv_captcha_source]"
           error-name="captcha"
           guess="[cgi mv_captcha_guess]"
       ]

=head1 DESCRIPTION

This tag generates and/or checks "captcha" images to authenticate user input.
If called for the first time in a page, it generates a code/image pair and
sets the code in the session (at $Vend::Session->{captcha}).

There are several functions.

=over 4

=item check

Checks the captcha source code (presumably from the previous page) against
the guess. If it matches, returns 1. If not, returns 0 and puts error
in $Tag->error.

=item code

Returns the generated code. Generates one if not done previously in session.

=item image

Returns an IMG tag as generated by Interchange's [image] tag. If the
name-only=1 option is passed, no surrounding IMG tag will be generated,
only the image name. If the C<relative=1> option is passed, that name
will not be prefaced with the ImageDir.

=back

The additional options are:

=over 4

=item guess 

The input from the user when the function is C<check>. Default is the
contents of [cgi mv_captcha_guess].

=item image-subdir

The image subdirectory (based in images directory) which will
be used.

=item image-path

The base path for URL generation. Default is the Interchange IMAGE_DIR
variable.

=item image-location

The directory where image files will be generated. Default is the
Interchange IMAGE_DIR variable based in the Interchange DOCROOT
variable, with the subdirectory above, i.e. C<[var DOCROOT][var IMAGE_DIR]/captcha>.

=item length

Length of the input for the captcha. Default is 4 characters.

=item name-only 

When set, tells the image function to not generate an HTML IMG tag.

=item relative 

When set, tells the image function (when in name-only mode) to
return relative path.

=item reset 

Normally only one captcha code / image will be generated per page
transaction. If this is set, you can generate another one -- though
you would have to take care of saving the generated code yourself,
as $Session->{captcha} is overwritten.

=item source 

The captcha base to guess against for the C<check> function. Default is the
contents of the last-generated captcha, or [cgi mv_captcha_source].

=back

=head1 EXAMPLE

 [if cgi mv_captcha_guess]
   [tmp good][captcha check][/tmp]
   [if scratch good]
     You guessed right!
   [else]
     Sorry, try again.
   [/else]
   [/if]
   <br>
 [/if]

 [captcha function=image]

 <form action="[process href="@@MV_PAGE@@"]">
 <input type=text name=mv_captcha_guess size value="">
 <input type=submit value="Guess">
 </form>

 [error auto=1]

=head1 PREREQUISITES

Authen::Captcha

=head1 AUTHOR

Mike Heins, <mike AT THE DOMAIN perusion.com>.

EOD

SEE ALSO


Name

capture_page — process page and save output to file and/or scratch variable

ATTRIBUTES

AttributePos.Req.DefaultDescription
page YesYes Name of the Interchange page to process (as if the user visited it with the browser).
file YesYes  File to dump contents to.
scratch     Store contents in this scratch variable.
scan    Specifies the search string and reproduces a search results page.
auto_create_dir   0Create directory path to the dump file?
expiry    See if file Modification time is newer than expiry deadline.
touch   0If the file is expired, touch it?
umask    File creation umask.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag processes the page (as if the user visited it with the browser), and writes contents to disk. This is usually called from jobs but of course, nothing enforces this.

The tag is able to reproduce both standard and search results pages.

This is similar to the output you could get from lynx -source or w3m -dump_source commands.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic static page example

Create page named make-static.html with the following content:

[capture-page page=index file=static/index.html umask=022 auto_create_dir=1]

This would create the static/ directory in your catalog root, and a snapshot of index.html in it.


Create page named make-static2.html with the following content:

[loop list="Levels,Rulers,Squares"]
  [capture-page page="[loop-code]" file="static/cats/[loop-code].html"
    scan="fi=products/st=db/co=yes/sf=category/se=[loop-code]"
    auto_create_dir=1]
[/loop]

NOTES

See the umask glossary entry.

AVAILABILITY

capture_page is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/capture_page.tag
Lines: 86


# Copyright 2003-2008 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: capture_page.tag,v 1.12 2008-10-01 09:21:45 racke Exp $

UserTag capture_page Order   page file
UserTag capture_page addAttr
UserTag capture_page Version $Revision: 1.12 $
UserTag capture_page Routine <<EOR
sub {
my ($page, $file, $opt) = @_;

# check if we are using a file
if ($file) {
  # check if we are allowed to write the file
  unless (Vend::File::allowed_file($file, 1)) {
    Vend::File::log_file_violation($file, 'capture_page');
    return 0;
  }

  if ($opt->{expiry}) {
    my $stat = (stat($file))[9];

    if ($stat > $opt->{expiry}) {
      if ($opt->{touch}) {
        my $now = time();
        unless (utime ($now, $now, $file)) {
          ::logError ("Error on touching file $file: $!\n");
        }
      }
      return;
    }
  }
}

if ($opt->{scan}) {
  Vend::Page::do_scan($opt->{scan});
}

$::Scratch->{mv_no_count} = 1;

# save mapped output
my (@output, %outptr, %outfilter, %outextended, $multiout, $content, $retval);

@output = @Vend::Output;
%outptr = %Vend::OutPtr;
%outfilter = %Vend::OutFilter;
%outextended = %Vend::OutExtended;
$multiout = $Vend::MultiOutput;

# clear mapped output
@Vend::Output = %Vend::OutPtr = %Vend::OutFilter = %Vend::OutExtended = ();
$Vend::MultiOutput = 0;
  
Vend::Page::display_page($page, {return => 1});

for my $part (@Vend::Output) {
   Vend::Interpolate::substitute_image($part);
  $content .= $$part;
 }

# restore mapped output
@Vend::Output = @output;
%Vend::OutPtr = %outptr;
%Vend::OutFilter = %outfilter;
%Vend::OutExtended = %outextended;
$Vend::MultiOutput = $multiout;

if ($opt->{scratch}) {
  $::Scratch->{$opt->{scratch}} = $content;
  $retval = 1;
}

if ($file) {
   $retval = Vend::File::writefile (">$file", \$content,
         {auto_create_dir => $opt->{auto_create_dir},
         umask => $opt->{umask}});
}

return $retval;
}
EOR

SEE ALSO


Name

cart — set the current shopping cart

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ nickname | name ] YesYes Cart name to switch to.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This simple tag sets the default cart name for tags that operate on it (such as shipping, price, total, subtotal or nitems).

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Set new default cart name

Place the following on an Interchange page:

[cart NEW]

NOTES

See the cart glossary entry.

AVAILABILITY

cart is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/cart.coretag
Lines: 13


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: cart.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag cart                Order        name
UserTag cart                PosNumber    1
UserTag cart                Version      $Revision: 1.6 $
UserTag cart                MapRoutine   Vend::Interpolate::tag_cart

Source: lib/Vend/Interpolate.pm
Lines: 2756

sub tag_cart {
$Vend::CurrentCart = shift;
return '';
}

Source: lib/Vend/Interpolate.pm
Lines: 2756

sub tag_cart {
$Vend::CurrentCart = shift;
return '';
}


Name

catch — handle failed 'try' blocks

ATTRIBUTES

AttributePos.Req.DefaultDescription
label 1 1 default Name to assign to the try block. The name is later used by catch (or some custom code) to refer to the proper try block.
exact
joiner
error_set
error_scratch
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The page content contained within [catch label_name] ... [/catch] block will be executed if the correspondingly labeled try block fails. This kind of error handling is common in some general-purpose programming languages, such as Java, SML or even Perl.

Except providing just a general error handling mechanism, Interchange implementation can take different code paths, depending on the specific error that occurred. That is achieved by matching the error message using regexps.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Raising and handling "division by zero" Perl error

In Perl, division by zero might result with the following error reported in the error log: 127.0.0.1 4cU3Pgsh:127.0.0.1 - [24/May/2001:14:45:07 -0400] tag /cgi-bin/tag72/tag Safe: Illegal division by zero at (eval 526) line 2 . Or it may be something like 127.0.0.1 G5vRfC9B:127.0.0.1 - [08/March/2005:18:25:17 +0100] tutorial /cgi-bin/ic/tutorial/catch Safe: 'eval "string"' trapped by operation mask at (tag 'perl') line 2.

The proper way to provide error handling is something like this:

[set divisor]0[/set]

[try label=div]
  [calc] eval(1 / [scratch divisor]) [/calc]
[/try]

[catch div]
  [/Illegal division by zero/]
    0
  [/Illegal division by zero/]
  
  [/trapped by operation mask/]
    Perl Safe error
  [/trapped by operation mask/]
  
  Other division error
[/catch]

NOTES

Note that the catch block executes at place of occurrence in place the page (if it is triggered), and not in place of the failed try block. This gives great flexibility but must be taken into account.

catch block must always follow try, that is — be executed after the $Session->{try}{label} structure has been initialized.

You might wonder, what will the actual error messages be, and how will you know which regexps to use in matching them? The error messages "raised" will usually be those that are also placed in the error logs. See the section called “EXAMPLES” for clarification.

AVAILABILITY

catch is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/catch.coretag
Lines: 80


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: catch.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $

UserTag catch               Order        label
UserTag catch               addAttr
UserTag catch               hasEndTag
UserTag catch               Version      $Revision: 1.7 $
UserTag catch               Routine      <<EOR
sub {
my ($label, $opt, $body) = @_;
$label = 'default' unless $label;
my $patt;
my $error;
return pull_else($body) 
  unless $error = $Vend::Session->{try}{$label};

$body = pull_if($body);

if ( $opt->{exact} ) {
  #----------------------------------------------------------------
  # Convert multiple errors to 'or' list and compile it.
  # Note also the " at (eval ...)" kludge to strip the line numbers
  $patt = $error;
  $patt =~ s/(?: +at +\(eval .+\).+)?\n\s*/|/g;
  $patt =~ s/^\s*//;
  $patt =~ s/\|$//;
  $patt = qr($patt);
  #----------------------------------------------------------------
}

my @found;
while ($body =~ s{
          \[/
            (.+?)
          /\]
          (.*?)
          \[/
          (?:\1)?/?
          \]}{}sx ) {
  my $re;
  my $emsg = $2;
  eval {
    $re = qr{$1}
  };
  next if $@;
  if($emsg =~ $patt) {
    push @found, $emsg;
  }
  next unless $error =~ $re;
  push @found, $emsg;
  last;
}

if(@found) {
  $body = join $opt->{joiner} || "\n", @found;
}
else {
  $body =~ s/\$ERROR\$/$error/g;
}

$body =~ s/\s+$//;
$body =~ s/^\s+//;

if($opt->{error_set}) {
  set_error($body, $opt->{error_set});
}
if($opt->{error_scratch}) {
  $::Scratch->{$opt->{error_scratch}} = 1;
}

return '' if $opt->{hide};
return $body;
}
EOR

SEE ALSO

try(7ic)


Name

cgi — expand to value of the CGI variable specified in body

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

The filter expands to the value of a CGI variable. Name of the variable is specified in filter body.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Filter example

[cgi name=online_cgi_test set="TEST VALUE" hide=1]

My test value is [filter cgi]online_cgi_test[/filter]

NOTES

In Interchange version 4.6.0, this symbol changed type from Filter to System Tag.

AVAILABILITY

cgi is available in Interchange versions:

4.6.0, 4.6.0, 4.8.0, 5.0.0, 5.2.0, 5.4.0, 5.6.0, 5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/cgi.coretag
Lines: 37


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: cgi.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag cgi                 Order        name
UserTag cgi                 addAttr
UserTag cgi                 PosNumber    1
UserTag cgi                 Version      $Revision: 1.6 $
UserTag cgi                 Routine      <<EOR
sub {
my($var, $opt) = @_;
my($value);

local($^W) = 0;
$CGI::values{$var} = $opt->{set} if defined $opt->{set};
$value = defined $CGI::values{$var} ? ($CGI::values{$var}) : '';
if ($value) {
  # Eliminate any Interchange tags
  $value =~ s~<([A-Za-z]*[^>]*\s+[Mm][Vv]\s*=\s*)~&lt;$1~g;
  $value =~ s/\[/&#91;/g;
}
if($opt->{filter}) {
  $value = filter_value($opt->{filter}, $value, $var);
  $CGI::values{$var} = $value unless $opt->{keep};
}

return '' if $opt->{hide};

$value =~ s/</&lt;/g unless $opt->{enable_html};
return $value;
}
EOR

SEE ALSO


Name

charge — perform a transaction with a payment gateway

ATTRIBUTES

AttributePos.Req.DefaultDescription
route Yes
gateway payment gateways
transaction transaction type
amount amount of money to charge
cyber_mode
log_to_error
hash No Return complete result hash as a reference?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

Returns transaction identifier.

The transaction identifier returned from the payment gateway will be stored in the session as payment_id.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

charge is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/charge.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: charge.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag charge              Order        route
UserTag charge              addAttr
UserTag charge              PosNumber    1
UserTag charge              Version      $Revision: 1.5 $
UserTag charge              MapRoutine   Vend::Payment::charge

Source: lib/Vend/Payment.pm
Lines: 559

sub charge {
my ($charge_type, $opt) = @_;

my $pay_route;

### We get the payment base information from a route with the
### same name as $charge_type if it is there
if($Vend::Cfg->{Route}) {
  $pay_route = $Vend::Cfg->{Route_repository}{$charge_type} || {};
}
else {
  $pay_route = {};
}

### Then we take any payment options set in &charge, [charge ...],
### or $Tag->charge

# $pay_opt is package-scoped but lexical
$pay_opt = { %$pay_route };
for(keys %$opt) {
  $pay_opt->{$_} = $opt->{$_};
}

# We relocate these to subroutines to standardize

### Maps the form variable names to the names needed by the routine
### Standard names are defined ala Interchange or MV4.0x, b_name, lname,
### etc. with b_varname taking precedence for these. Falls back to lname
### if the b_lname is not set
my (%actual) = map_actual();
$pay_opt->{actual} = \%actual;

# We relocate this to a subroutine to standardize. Uses the payment
# counter if there
my $orderID = gen_order_id($pay_opt);

### Set up the amounts. The {amount} key will have the currency prepended,
### e.g. "usd 19.95". {total_cost} has just the cost.

# Uses the {currency} -> MV_PAYMENT_CURRENCY options if set
my $currency =  charge_param('currency')
        || ($Vend::Cfg->{Locale} && $Vend::Cfg->{Locale}{currency_code})
        || 'usd';

# Uses the {precision} -> MV_PAYMENT_PRECISION options if set
my $precision = charge_param('precision') || 2;
my $penny     = charge_param('penny_pricing') || 0;

my $amount = $pay_opt->{amount} || Vend::Interpolate::total_cost();
$amount = round_to_frac_digits($amount, $precision);
$amount = sprintf "%.${precision}f", $amount;
$amount *= 100 if $penny;

$pay_opt->{total_cost} = $amount;
$pay_opt->{amount} = "$currency $amount";

### 
### Finish setting amounts and currency

# If we have a previous payment amount, delete it but push it on a stack
# 
my $stack = $Vend::Session->{payment_stack} || [];
delete $Vend::Session->{payment_result}; 
delete $Vend::Session->{cybercash_result}; ### Deprecated

#::logDebug("Called charge at " . scalar(localtime));
#::logDebug("Charge caller is " . join(':', caller));

#::logDebug("mode=$pay_opt->{gateway}");
#::logDebug("pay_opt=" . ::uneval($pay_opt));
# Default to the gateway same as charge type if no gateway specified,
# and set the gateway in the session for logging on completion
if(! $opt->{gateway}) {
  $pay_opt->{gateway} = charge_param('gateway') || $charge_type;
}
#$charge_type ||= $pay_opt->{gateway};
$Vend::Session->{payment_mode} = $pay_opt->{gateway};

# See if we are in test mode
$pay_opt->{test} = charge_param('test');

# just convenience
my $gw = $pay_opt->{gateway};

# See if we are calling a defined GlobalSub payment mode
my $sub = $Global::GlobalSub->{$gw};

# Try our predefined modes
if (! $sub and defined &{"Vend::Payment::$gw"} ) {
  $sub = \&{"Vend::Payment::$gw"};
}

# This is the return from all routines
my %result;

if($sub) {
#::logDebug("Charge sub");
  # Calling a defined GlobalSub payment mode
  # Arguments are the passed option hash (if any) and the route hash

      my $pid;
      my $timeout = $pay_opt->{global_timeout} || charge_param('global_timeout');

      %result = eval {
          if ($timeout > 0) {

              my $pipe = IO::Pipe->new;

              unless ($pid = fork) {
                  Vend::Server::child_process_dbi_prep();
                  $pipe->writer;
                  my %rv = $sub->($pay_opt);
                  $pipe->print( ::uneval(\%rv) );
                  exit;
              }

              $pipe->reader;

              my $to_msg = $pay_opt->{global_timeout_msg}
                  || charge_param('global_timeout_msg')
                  || 'Due to technical difficulties, your order could not be processed.';
              local $SIG{ALRM} = sub { die "$to_msg\n" };

              alarm $timeout;
              wait;
              alarm 0;

              $pid = undef;

              my $rv = eval join ('', $pipe->getlines);

              return %$rv;
          }

          return $sub->($pay_opt);
      };

  if($@) {
    my $msg = errmsg(
          "payment routine '%s' returned error: %s",
          $charge_type,
          $@,
    );
          kill (KILL => $pid)
              if $pid && kill (0 => $pid);
    ::logError($msg);
    $result{MStatus} = 'died';
    $result{MErrMsg} = $msg;
  }
}
elsif($charge_type =~ /^\s*custom\s+(\w+)(?:\s+(.*))?/si) {
#::logDebug("Charge custom");
  # MV4 and IC4.6.x methods
  my (@args);
  @args = Text::ParseWords::shellwords($2) if $2;
  if(! defined ($sub = $Global::GlobalSub->{$1}) ) {
    ::logError("bad custom payment GlobalSub: %s", $1);
    return undef;
  }
  eval {
    %result = $sub->(@args);
  };
  if($@) {
    my $msg = errmsg(
          "payment routine '%s' returned error: %s",
          $charge_type,
          $@,
    );
    ::logError($msg);
    $result{MStatus} = $msg;
  }
}
elsif (
    $actual{cyber_mode} =~ /^minivend_test(?:_(.*))?/
      or 
    $charge_type =~ /^internal_test(?:[ _]+(.*))?/
    )
{
#::logDebug("Internal test");

  # Test mode....

  my $status = $1 || charge_param('result') || undef;
  # Interchange test mode
  my %payment = ( %$pay_opt );
  &testSetServer ( %payment );
  %result = testsendmserver(
    $actual{cyber_mode},
    'Order-ID'     => $orderID,
    'Amount'       => $amount,
    'Card-Number'  => $actual{mv_credit_card_number},
    'Card-Name'    => $actual{b_name},
    'Card-Address' => $actual{b_address},
    'Card-City'    => $actual{b_city},
    'Card-State'   => $actual{b_state},
    'Card-Zip'     => $actual{b_zip},
    'Card-Country' => $actual{b_country},
    'Card-Exp'     => $actual{mv_credit_card_exp_all}, 
  );
  $result{MStatus} = $status if defined $status;
}
else {
#::logDebug("Unknown charge type");
  my $msg = errmsg("Unknown charge type: %s", $charge_type);
  ::logError($msg);
  $result{MStatus} = $msg;
}

push @$stack, \%result;
$Vend::Session->{payment_result} = \%result;
$Vend::Session->{payment_stack}  = $stack;

my $svar = charge_param('success_variable') || 'MStatus';
my $evar = charge_param('error_variable')   || 'MErrMsg';

if($result{$svar} !~ /^success/) {
  $Vend::Session->{payment_error} = $result{$evar};
  if ($result{$evar} =~ /\S/) {
    $Vend::Session->{errors}{mv_credit_card_valid} = $result{$evar};
  }
  $result{'invalid-order-id'} = delete $result{'order-id'}
    if $result{'order-id'};
}
elsif($result{$svar} =~ /success-duplicate/) {
  $Vend::Session->{payment_error} = $result{$evar};
  $result{'invalid-order-id'} = delete $result{'order-id'}
    if $result{'order-id'};
}
else {
  delete $Vend::Session->{payment_error};
}

$Vend::Session->{payment_id} = $result{'order-id'};

my $encrypt = charge_param('encrypt');

if($encrypt and $CGI::values{mv_credit_card_number} and $Vend::Cfg->{EncryptKey}) {
  my $prog = charge_param('encrypt_program') || $Vend::Cfg->{EncryptProgram};
  if($prog =~ /pgp|gpg/) {
    $CGI::values{mv_credit_card_force} = 1;
    (
      undef,
      $::Values->{mv_credit_card_info},
      $::Values->{mv_credit_card_exp_month},
      $::Values->{mv_credit_card_exp_year},
      $::Values->{mv_credit_card_exp_all},
      $::Values->{mv_credit_card_type},
      $::Values->{mv_credit_card_error}
    )  = encrypt_standard_cc(\%CGI::values);
  }
}
::logError(
      "Order id for charge type %s: %s",
      $charge_type,
      $Vend::Session->{cybercash_id},
    )
  if $pay_opt->{log_to_error};

# deprecated
for(qw/ id error result /) {
  $Vend::Session->{"cybercash_$_"} = $Vend::Session->{"payment_$_"};
}

return \%result if $pay_opt->{hash};
return $result{'order-id'};
}


Name

check-upload

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes Yes
same Yes
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

check-upload is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/check_upload.coretag
Lines: 27


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: check_upload.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag check-upload Order     file same
UserTag check-upload PosNumber 2
UserTag check-upload Version   $Revision: 1.4 $
UserTag check-upload Routine   <<EOR
sub {
use File::Copy;
my $file = shift;
my $same = shift;
my $dir = $Vend::Cfg->{ProductDir};
$same = $same ? '' : '+';
if (-s "upload/$file") {
  File::Copy::copy "upload/$file", "$dir/$file$same"
    or return "Couldn't copy uploaded file!";
  unlink "upload/$file";
}
return '';
}
EOR

SEE ALSO


Name

checked — indicate checked status of checkboxes

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes variable name
value Yes on
cgi Whether to use CGI namespace instead of Value namespace.
default None
case No Preserve case for field names and values?
multiple
delimiter \0 This option implies multiple=1.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag provides "memory" for HTML checkboxes and radio buttons.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: "Memory" for checkboxes

<pre>

<form action="[process href="@@MV_PAGE@@"]" method="post">
  [form-session-id]
  <input type=hidden name=mv_todo value=refresh>
  
  <input type=checkbox name=checkbox1 [checked name=checkbox1 cgi=1]> Option1
  <input type=checkbox name=checkbox2 [checked name=checkbox2 cgi=1]> Option2
  <input type=checkbox name=checkbox3 [checked name=checkbox3 cgi=1]> Option3
  <input type=checkbox name=checkbox4 [checked name=checkbox4 cgi=1]> Option4
  <input type=checkbox name=checkbox5 [checked name=checkbox5 cgi=1]> Option5
  
  <input type=submit>
</form>

</pre>

Example: Radio Button

Displays a radio button and selects the second choice by default:

<input type="radio" name="factory_sealed" value="1"[checked factory_sealed 1]>&nbsp;[L]Yes[/L]<br>
<input type="radio" name="factory_sealed" value="0"[checked factory_sealed value=0 default=1]>&nbsp;[L]No[/L]

NOTES

AVAILABILITY

checked is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/checked.coretag
Lines: 57


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: checked.coretag,v 1.9 2007-03-30 23:40:49 pajamian Exp $

UserTag checked             Order        name value
UserTag checked             addAttr
UserTag checked             Implicit     multiple multiple
UserTag checked             Implicit     default default
UserTag checked             PosNumber    2
UserTag checked             Version      $Revision: 1.9 $
UserTag checked             Routine      <<EOR
sub {
my ($field,$value,$opt) = @_;

$value = 'on' unless defined $value;

my $ref = $opt->{cgi} ? $CGI::values{$field} : $::Values->{$field};
return ' checked="checked"' if ! length($ref) and $opt->{default};

if(! $opt->{case}) {
  $ref = lc($ref);
  $value = lc($value);
}

return ' checked="checked"' if $ref eq $value;

if ($opt->{delimiter}) {
  $opt->{multiple} = 1;
}

if ($opt->{multiple}) {
    
    my $be;
    my $ee;
    $opt->{delimiter} = "\0" unless defined $opt->{delimiter};

    if (length $opt->{delimiter}) {
  my $del = Vend::Interpolate::get_joiner($opt->{delimiter}, "\0");
  $be = '(?:^|' . $del . ')'; ;
  $ee = '(?:$|' . $del . ')'; ;
    }
    else {
  $be = '';
  $ee = '';
    }

    my $regex = qr/$be\Q$value\E$ee/;
    return ' checked="checked"' if $ref =~ $regex;
}
return '';
}
EOR


Name

child-process

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

child-process is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/child-process.tag
Lines: 133


# Copyright 2008 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: child-process.tag,v 1.3 2009-01-08 12:05:16 markj Exp $

UserTag child-process addAttr
UserTag child-process HasEndTag
UserTag child-process NoReparse 0
UserTag child-process Interpolate 0
UserTag child-process Version $Revision: 1.3 $
UserTag child-process Documentation <<EOD

=head1 NAME

child_process - Execute ITL code in a forked child process

=head1 SYNOPSIS

[child-process] ... ITL ... [/child-process]

=head1 DESCRIPTION

Runs Interchange markup code in a forked child process.
Useful for off-loading processes that take a relatively long time to complete.

Has no effect if the body is empty or contains only whitespace.

Options are:

=over 4

=item filename

File name relative to catalog directory to file where output from forked
process should be stored.

=item label

Optional descriptive label for this process that will be put in the operating
system process list. Default is "child-process tag".

=item notifyname

File name relative to catalog directory where a file of zero length will
be created if the file in option 'filename' is created successfully.

This empty file could be used for notification purposes, e.g. as an
indicator that the child process has delivered its output. When placed
in web docroot space one could poll for the existence of this file and
when it exists bounce to a page that will display the results.

=back

=head1 EXAMPLES

This is the parent process.

Child process starts here.
[child-process filename="tmp/report_[time]%Y%m%d%H%M%S[/time].txt"]
[query
    list=1
    sql="
        ... some long-running SQL query ...
    "
][sql-line]
[/query]
[/child-process]
Child process ends here.

Some more parent stuff....

=head1 AUTHORS

Ton Verhagen <tverhagen@alamerce.nl>

Jon Jensen <jon@endpoint.com>


=cut

EOD
UserTag child-process Routine <<EOR

use POSIX ();

sub {
   my ($opt, $body) = @_;
   use vars qw/ $Tag /;

   return unless defined($body) and $body =~ /\S/;

   defined(my $kid = fork) or die "Cannot fork: $!\n";
   if ($kid) {
       waitpid($kid, 0);
       return;
   }
   else {

       Vend::Server::sever_database();

       defined (my $grandkid = fork) or die "Kid cannot fork: $!\n";
       exit if $grandkid;

       Vend::Server::cleanup_for_exec();

       # Disconnect from parent's terminal
       POSIX::setsid() or die "Can't start a new session: $!\n";

       defined $opt->{label} or $opt->{label} = 'child-process tag';
       Vend::Server::set_process_name($opt->{label});

       my $output = interpolate_html($body, 1);

       my $filename = $opt->{filename};
       if (defined($filename) and length($filename)) {
           $filename = $Tag->filter('filesafe', $filename);
           my $status = $Tag->write_relative_file($filename, $$output);

           my $notifyname = $opt->{notifyname};
           if ($status and defined($notifyname) and length($notifyname)) {
               $notifyname = $Tag->filter('filesafe', $notifyname);
               $Tag->write_relative_file($notifyname, $opt, '');
           }
       }

       exit;
   }
}
EOR

SEE ALSO


Name

comment — comment (disable) parts of Interchange or HTML code

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag comments parts of ITL or HTML code. Content enclosed in the comment block will not be processed in any way, and will be stripped out of the final data sent to the clients.

You can use comment sections to provide code commentary, or effectively disable parts of code.

Interchange's comment tag is often preferred over HTML comments (<!--...--> blocks), because unlike comment blocks, HTML comments do get passed through to the clients.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Using comment

[comment]
  Have no fear, for this is just one comment area!
[/comment]

Example: Disabling ITL code

This nitems tag below will never execute:

[comment]
  You have [nitems] items in your cart.
[/comment]

NOTES

comment blocks can be nested.

AVAILABILITY

comment is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/comment.coretag
Lines: 18


# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: comment.coretag,v 1.2 2007-03-30 23:40:49 pajamian Exp $

# This tag exists to strip out any [comment]...[/comment] blocks
# that weren't caught by &Vend::Interpolate::vars_and_comments,
# e.g. in reparsed output from [perl] blocks

UserTag comment Version $Revision: 1.2 $
UserTag comment hasEndTag
UserTag comment Routine <<EOR
sub { '' }
EOR

SEE ALSO

debug(7ic)


Name

component — display component

ATTRIBUTES

AttributePos.Req.DefaultDescription
component Yes component name
default
comp_table MV_COMPONENT_TABLE, component
comp_dir MV_COMPONENT_DIR, templates/components
no_image_substitute
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: MV_COMPONENT_TABLE, MV_COMPONENT_CACHE, MV_COMPONENT_DIR

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

component is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/component.tag
Lines: 135


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: component.tag,v 1.10 2009-05-01 13:50:00 pajamian Exp $

UserTag component Order     component
UserTag component addAttr
UserTag component NoReparse 1
UserTag component Version   $Revision: 1.10 $
UserTag component Routine   <<EOR
sub {
my ($name, $opt) = @_;

my %ignore = (
  qw/
    component    1
    comp_table   1
    comp_field   1
    comp_cache   1
    reparse      1
    interpolate  1
  /
);
my @override = grep ! $ignore{$_}, keys %$opt;

my $control = $::Control->[$::Scratch->{control_index}];
for(grep $_ !~ /^comp(?:onent)?_?/, keys %$opt) {
  $control->{$_} = $opt->{$_};
}

$name ||= $control->{component};
$name ||= $opt->{default};

if (! $name or $name eq 'none') {
# Increment control_index so empty component has no side effect
$::Scratch->{control_index}++;
return;
}

my $t = $opt->{comp_table} || $::Variable->{MV_COMPONENT_TABLE} || 'component';
my $ctab = $::Variable->{MV_COMPONENT_CACHE} || 'component_cache';

my $record;
my $db = database_exists_ref($t);
my $nocache;

if($db) {
  if(my $when = $Vend::Session->{teleport}) {
    $nocache = 1;
    my $q = qq{
      SELECT code from $t
      WHERE  base_code = '$name'
      AND    expiration_date < $when
      AND    show_date >= $when
      ORDER BY show_date DESC
    };
    my $ary = $db->query($q);
    if($ary and $ary->[0]) {
      $name = $ary->[0][0];
    }
}
$record = $db->row_hash($name);
}

$record ||= $opt;

my $body = $record->{comptext};

if(! length($body)) {
my $dir = $opt->{comp_dir}
    || $::Variable->{MV_COMPONENT_DIR}
    || 'templates/components';
$body = readfile("$dir/$name",undef,1);
}

# Increment control_index so empty component has no side effect
if (! length $body) {
  $::Scratch->{control_index}++;
  return;
}

my $cache_it;
my $cdb;
my $now;
my $crecord;
if (
  ! $nocache
  and $record->{cache_interval}
  and $cdb = database_exists_ref($ctab)
  )
{
  $cache_it = $name;

  # Cache based not only on name, but control values specified
  if($record->{cache_options}) {
    my @opts = split /[\s,\0]+/, $record->{cache_options};
    $cache_it .= '.';
    $cache_it .= generate_key( join "\0", @{$control}{@opts});
  }

  $crecord = $cdb->row_hash($cache_it) || {};
  $now = time;
  
  my $exp = adjust_time($record->{cache_interval}, $crecord->{cache_time});
  
  if ($exp > $now) {
    # Increment control_index as not done below
    $::Scratch->{control_index}++;
    return $crecord->{compcache};
  }
}

my $result = interpolate_html($body);
$::Scratch->{control_index}++;
if($cache_it) {
  my $thing = {
          compcache => $result,
          cache_time => $now,
        };
  $cdb->set_slice($cache_it, $thing);
}

if($record->{output}) {
  Vend::Interpolate::substitute_image(\$result)
    unless $opt->{no_image_substitute};
  $Tag->output_to($record->{output}, undef, $result);
  return;
}
return $result;
}
EOR


Name

content-editor

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

content-editor is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/content_editor.coretag
Lines: 19


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: content_editor.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag content-editor Order      name
UserTag content-editor addAttr
UserTag content-editor hasEndTag
UserTag content-editor Version    $Revision: 1.6 $
UserTag content-editor Routine    <<EOR
use UI::ContentEditor;
sub {
return UI::ContentEditor::editor(@_);
}
EOR

SEE ALSO


Name

content-info

ATTRIBUTES

AttributePos.Req.DefaultDescription
dir 0    
templates 0    
components    
delimiter ,  
code     
label     
no_none    
structure-none    
show_class    
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

content-info is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/content_info.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: content_info.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag content-info Order     dir
UserTag content-info addAttr
UserTag content-info Version   $Revision: 1.5 $
UserTag content-info Routine   <<EOR
use UI::ContentEditor;
sub {
UI::ContentEditor::content_info(@_);
}
EOR

SEE ALSO


Name

content-modify

ATTRIBUTES

AttributePos.Req.DefaultDescription
opYes   
nameYes   
typeYes   
values_ref0   
templates0   
components    
delimiter  , 
code    
label    
no_none    
structure    
show_class    
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

content-modify is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/content_modify.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: content_modify.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag content-modify Order    op name type
UserTag content-modify addAttr
UserTag content-modify Version  $Revision: 1.4 $
UserTag content-modify Routine  <<EOR
use UI::ContentEditor;
sub {
return UI::ContentEditor::content_modify(@_);
}
EOR

SEE ALSO


Name

control — Retrieve component attributes

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes attribute name
default Yes attribute default value
space
reset
set
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

control is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/control.coretag
Lines: 45


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: control.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag control             Order        name default
UserTag control             addAttr
UserTag control             PosNumber    2
UserTag control             Version      $Revision: 1.4 $
UserTag control             Routine      <<EOR
sub {
my ($name, $default, $opt) = @_;

use vars qw/$Tmp/;

if(! $name) {
  # Here we either reset the index or increment it
  # Done this way for speed, no blocks to enter other than top one
  if($opt->{space}) {
    $::Control = $Tmp->{$opt->{space}} ||= [];
    return set_tmp('control_index', 0);
  }
  else {
    ($::Scratch->{control_index} = 0, return) if $opt->{reset};
    return set_tmp('control_index', ++$::Scratch->{control_index});
  }
}

$name = lc $name;
$name =~ s/-/_/g;
$opt ||= {};
if (! defined $default and $opt->{set}) {
  $::Control->[$::Scratch->{control_index}]{$name} = $::Scratch->{$name};
  return;
}

return defined $::Control->[$::Scratch->{control_index}]{$name} 
    ?  ( $::Control->[$::Scratch->{control_index}]{$name} || $default )
    :  ( length($::Scratch->{$name}) ? ($::Scratch->{$name}) : $default )
}
EOR


Name

control-set — Retrieve component attributes

ATTRIBUTES

AttributePos.Req.DefaultDescription
index Yes
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

control-set is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/control_set.coretag
Lines: 36


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: control_set.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag control-set         Order        index
UserTag control-set         addAttr
UserTag control-set         hasEndTag
UserTag control-set         PosNumber    1
UserTag control-set         Version      $Revision: 1.4 $
UserTag control-set         Routine      <<EOR
# Batch sets a set of controls without affecting Scratch
# Increments the index afterwards unless index is defined
sub {
my ($index, $opt, $body) = @_;

my $inc;
unless($index) {
  $index = $::Scratch->{control_index} || 0;
  $inc = 1;
}

while($body =~ m{\[([-\w]+)\](.*)\[/\1\]}sg) {
  my $name = lc $1;
  my $val = $2;
  $name =~ s/-/_/g;
  $::Control->[$index]{$name} = $val;
}
$::Scratch->{control_index}++;
return;
}
EOR

SEE ALSO

control(7ic)


Name

convert-date — convert date to a specified format

ATTRIBUTES

AttributePos.Req.DefaultDescription
adjust | days Yes
raw
[ format | fmt ] %d-%b-%Y POSIX strftime format specifier; see time glossary entry.
locale
zerofix
empty Current date Text to display if the date value to convert is empty
compensate_dst 0 Compensate the adjusted time for daylight savings time changes.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The format string is documented in time.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: MV_UTF8
Global Variables: MV_UTF8

EXAMPLES

Example:

[convert-date format="%B %e, %Y"]20080701[/convert-date]

yields July 1, 2008.


NOTES

AVAILABILITY

convert-date is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/convert_date.tag
Lines: 94


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: convert_date.tag,v 1.9 2009-05-01 13:50:00 pajamian Exp $

UserTag convert-date Order       adjust
UserTag convert-date PosNumber   1
UserTag convert-date addAttr
UserTag convert-date AttrAlias   fmt format
UserTag convert-date AttrAlias   days adjust
UserTag convert-date HasEndTag
UserTag convert-date Interpolate
UserTag convert-date Version     $Revision: 1.9 $
UserTag convert-date Routine     <<EOR
sub {
  my ($adjust, $opt, $text) = @_;
  my @t;
  my $now;

if(! ref $opt) {
  my $raw = $opt ? 1 : 0;
  $opt = {};
  $opt->{raw} = 1 if $raw;
}

my $fmt = $opt->{format} || '';
if($text =~ /^(\d\d\d\d)-(\d?\d)-(\d?\d)$/) {
  $t[5] = $1 - 1900;
  $t[4] = $2 - 1;
  $t[3] = $3;
} 
elsif($text =~ /\d/) {
        $text =~ s/\D//g;
        $text =~ /(\d\d\d\d)(\d\d)(\d\d)(?:(\d\d)(\d\d))?/;
        $t[2] = $4 || undef;
        $t[1] = $5 || undef;
        $t[3] = $3;
        $t[4] = $2 - 1;
        $t[5] = $1;
        $t[5] -= 1900;
}
elsif (exists $opt->{empty}) {
  return $opt->{empty};
}
else {
        $now = time();
        @t = localtime($now) unless $adjust;
}

if ($adjust) {
  if ($#t < 8) {
    $t[8] = -1;
  }
  $now ||= POSIX::mktime(@t);
  $adjust .= ' days' if $adjust =~ /^[-\s\d]+$/;
  @t = localtime(adjust_time($adjust, $now, $opt->{compensate_dst}));
}

if (defined $opt->{raw} and Vend::Util::is_yes($opt->{raw})) {
        $fmt = $t[2] && $text ?  '%Y%m%d%H%M' : '%Y%m%d';
}

if (! $fmt) {
  if ($t[1] || $t[2]) {
$fmt = '%d-%b-%Y %I:%M%p';
} else {
$fmt = '%d-%b-%Y';
}
}

my ($current, $out);
my $locale = $opt->{locale} || $Scratch->{mv_locale};
if ($locale) {
$current = POSIX::setlocale(&POSIX::LC_TIME);
  if (($::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8})
      && $locale !~ /\.utf-?8$/i) {
      POSIX::setlocale(&POSIX::LC_TIME, "$locale.utf8");
  }
  else {
          POSIX::setlocale(&POSIX::LC_TIME, $locale);
      }
  $out = POSIX::strftime($fmt, @t);
  POSIX::setlocale(&POSIX::LC_TIME, $current);
} else {
  $out = POSIX::strftime($fmt, @t);
}
$out =~ s/\b0(\d)\b/$1/g if $opt->{zerofix};
return $out;
}
EOR

SEE ALSO


Name

counter — manipulate a persistent, named counter

ATTRIBUTES

AttributePos.Req.DefaultDescription
name | file Yes CATROOT/etc/counter Counter file to use. Taken relatively to CATROOT unless absolute pathname is specified.
start Counter start value
sql A table:field specification, if counter is to increment a field in an SQL database.
inc_routine Routine to use to increase the counter. The routine should be an existing Perl function, catalog subroutine, or global subroutine
bypass 0 Bypass the existing database connection, and instead connect to the database anew, if sql attribute is used.
dsn DBI_DSN DSN information to connect to the SQL database, if sql attribute is used
user User to connect to the database as, if sql attribute is used
pass Password to provide during connection to the database, if sql attribute is used
attr Extra content for the DBI->connect call
date Date-based counter? Set to any true value, or gmt to also signify GMT date
dec_routine Routine to use to decrease the counter The routine should be an existing Perl function, catalog subroutine, or global subroutine
value Only show the counter value, without incrementing or decrementing it? (This option is not applicable to SQL counters).
decrement 0 Decrement instead of incrementing the counter?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag provides an interface to the counter functionality within Interchange. The counters are usually kept as text files, but can also be sequences in SQL tables.

counter can increase and decrease counters, or set them to specific values. In addition, custom increment or decrement functions can be used.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic counter file

The following creates a counter file, counter.basic in your catalog root directory. The counter starts at 10.

[counter file=counter.basic start=10]

Example: Basic date-based counter file

The following creates two date-based counter files, counter.loc and counter.gmt in your catalog root directory.

[counter file=counter.loc date=1]
[counter file=counter.gmt date=gmt]

Example: Counter using steps of +2 and -2, with in-place subroutine specification

The following creates two counter files, counter.p2 and counter.m2 in your catalog root directory. Counters initially start at 20; one adds 2 and one subtracts 2 each time they're called.

[counter
  file=counter.p2
  start=20
  inc-routine=`sub { shift(@_) + 2 }`
]
[counter
  file=counter.m2
  start=20
  decrement=1
  dec-routine=`sub { shift(@_) - 2 }`
]

Example: Counter using steps of +3 and -3, with Sub or GlobalSub routine specification

The following creates two counter files, counter.p3g and counter.m3g in your catalog root directory. Counters initially start at 20; one adds 3 and one subtracts 3 each time they're called.

You need the following in catalog.cfg or interchange.cfg:

Sub three_steps_forward <<EOR
sub {
  my $val = shift; $val += 3; return $val;
}
EOR

Sub three_steps_back <<EOR
sub {
  my $val = shift; $val -= 3; return $val;
}
EOR

And the following on an Interchange page:

[counter file=counter.p3 start=20 inc-routine=three_steps_forward ]
[counter file=counter.m3 start=20 decrement=1 dec-routine=three_steps_back]

Example: PostgreSQL database counter

Create sequence counter1 in the database:

CREATE SEQUENCE "counter1" start 1 increment 1 maxvalue 2147483647 minvalue 1 cache 1;

And use the counter on your pages:

[counter sql="table1:counter1"]

Example: MySQL database counter

Create table table2 and a sequence counter2 in that database:

create table table2(counter2 int NOT NULL AUTO_INCREMENT PRIMARY KEY);

And use the counter on your pages:

[counter sql="table2:counter2"]

Example: Oracle database counter

Create a sequence counter3 in the database:

CREATE SEQUENCE counter3 START WITH 1 INCREMENT BY 1 MAXVALUE 2147483647 MINVALUE 1 CACHE 2;

And use the counter on your pages:

[counter sql="table3:counter3"]

NOTES

The SQL field-updating routine is database-dependent; please see the tag source for exact behavior.

Date-based counters cannot be decremented.

AVAILABILITY

counter is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/counter.coretag
Lines: 17


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: counter.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag counter             Order        file
UserTag counter             addAttr
UserTag counter             attrAlias    name file
UserTag counter             PosNumber    1
UserTag counter             Version      $Revision: 1.6 $
UserTag counter             MapRoutine   Vend::Interpolate::tag_counter

UserTag fcounter            Alias        counter

Source: lib/Vend/Interpolate.pm
Lines: 2250

sub tag_counter {
  my $file = shift || 'etc/counter';
my $opt = shift;
#::logDebug("counter: file=$file start=$opt->{start} sql=$opt->{sql} routine=$opt->{inc_routine} \
 caller=" . scalar(caller()) );
if($opt->{sql}) {
  my ($tab, $seq) = split /:+/, $opt->{sql}, 2;
  my $db = database_exists_ref($tab);
  my $dbh;
  my $dsn;
  if($opt->{bypass}) {
    $dsn = $opt->{dsn} || $ENV{DBI_DSN};
    $dbh = DBI->connect(
          $dsn,
          $opt->{user},
          $opt->{pass},
          $opt->{attr},
        );
  }
  elsif($db) {
    $dbh = $db->dbh();
    $dsn = $db->config('DSN');
  }

  my $val;

  eval {
    my $diemsg = errmsg(
            "Counter sequence '%s' failed, using file.\n",
            $opt->{sql},
          );
    if(! $dbh) {
      die errmsg(
          "No database handle for counter sequence '%s', using file.",
          $opt->{sql},
        );
    } 
    elsif($seq =~ /^\s*SELECT\W/i) {
#::logDebug("found custom SQL SELECT for sequence: $seq");
      my $sth = $dbh->prepare($seq) or die $diemsg;
      $sth->execute or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:mysql:/i) {
      $seq ||= $tab;
      $dbh->do("INSERT INTO $seq VALUES (0)")    or die $diemsg;
      my $sth = $dbh->prepare("select LAST_INSERT_ID()")
        or die $diemsg;
      $sth->execute()                or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:Pg:/i) {
      my $sth = $dbh->prepare("select nextval('$seq')")
        or die $diemsg;
      $sth->execute()
        or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:Oracle:/i) {
      my $sth = $dbh->prepare("select $seq.nextval from dual")
        or die $diemsg;
      $sth->execute()
        or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }

  };

  logOnce('error', $@) if $@;

  return $val if defined $val;
}

unless (allowed_file($file)) {
  log_file_violation ($file, 'counter');
  return undef;
}

  $file = $Vend::Cfg->{VendRoot} . "/$file"
      unless Vend::Util::file_name_is_absolute($file);

for(qw/inc_routine dec_routine/) {
  my $routine = $opt->{$_}
    or next;

  if( ! ref($routine) ) {
    $opt->{$_}   = $Vend::Cfg->{Sub}{$routine};
    $opt->{$_} ||= $Global::GlobalSub->{$routine};
  }
}

  my $ctr = new Vend::CounterFile
        $file,
        $opt->{start} || undef,
        $opt->{date},
        $opt->{inc_routine},
        $opt->{dec_routine};
  return $ctr->value() if $opt->{value};
  return $ctr->dec() if $opt->{decrement};
  return $ctr->inc();
}

Source: lib/Vend/Interpolate.pm
Lines: 2250

sub tag_counter {
  my $file = shift || 'etc/counter';
my $opt = shift;
#::logDebug("counter: file=$file start=$opt->{start} sql=$opt->{sql} routine=$opt->{inc_routine} \
 caller=" . scalar(caller()) );
if($opt->{sql}) {
  my ($tab, $seq) = split /:+/, $opt->{sql}, 2;
  my $db = database_exists_ref($tab);
  my $dbh;
  my $dsn;
  if($opt->{bypass}) {
    $dsn = $opt->{dsn} || $ENV{DBI_DSN};
    $dbh = DBI->connect(
          $dsn,
          $opt->{user},
          $opt->{pass},
          $opt->{attr},
        );
  }
  elsif($db) {
    $dbh = $db->dbh();
    $dsn = $db->config('DSN');
  }

  my $val;

  eval {
    my $diemsg = errmsg(
            "Counter sequence '%s' failed, using file.\n",
            $opt->{sql},
          );
    if(! $dbh) {
      die errmsg(
          "No database handle for counter sequence '%s', using file.",
          $opt->{sql},
        );
    } 
    elsif($seq =~ /^\s*SELECT\W/i) {
#::logDebug("found custom SQL SELECT for sequence: $seq");
      my $sth = $dbh->prepare($seq) or die $diemsg;
      $sth->execute or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:mysql:/i) {
      $seq ||= $tab;
      $dbh->do("INSERT INTO $seq VALUES (0)")    or die $diemsg;
      my $sth = $dbh->prepare("select LAST_INSERT_ID()")
        or die $diemsg;
      $sth->execute()                or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:Pg:/i) {
      my $sth = $dbh->prepare("select nextval('$seq')")
        or die $diemsg;
      $sth->execute()
        or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }
    elsif($dsn =~ /^dbi:Oracle:/i) {
      my $sth = $dbh->prepare("select $seq.nextval from dual")
        or die $diemsg;
      $sth->execute()
        or die $diemsg;
      ($val) = $sth->fetchrow_array;
    }

  };

  logOnce('error', $@) if $@;

  return $val if defined $val;
}

unless (allowed_file($file)) {
  log_file_violation ($file, 'counter');
  return undef;
}

  $file = $Vend::Cfg->{VendRoot} . "/$file"
      unless Vend::Util::file_name_is_absolute($file);

for(qw/inc_routine dec_routine/) {
  my $routine = $opt->{$_}
    or next;

  if( ! ref($routine) ) {
    $opt->{$_}   = $Vend::Cfg->{Sub}{$routine};
    $opt->{$_} ||= $Global::GlobalSub->{$routine};
  }
}

  my $ctr = new Vend::CounterFile
        $file,
        $opt->{start} || undef,
        $opt->{date},
        $opt->{inc_routine},
        $opt->{dec_routine};
  return $ctr->value() if $opt->{value};
  return $ctr->dec() if $opt->{decrement};
  return $ctr->inc();
}

SEE ALSO


Name

cp — copy a file

ATTRIBUTES

AttributePos.Req.DefaultDescription
from Yes Yes Source file to copy.
to Yes Yes Destination directory or file to copy to.
umask Interchange process default File umask.
preserve_times 0 Whether to preserve file access and modification times.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag simply copies source file to the destination.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic example

[either]
  [cp from=pages/index.html to=/tmp/ hide=1]
[or]
  Copy failed. See error logs for details.
[/either]

NOTES

AVAILABILITY

cp is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/cp.coretag
Lines: 42


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: cp.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag cp Order      from to
UserTag cp addAttr
UserTag cp Version    $Revision: 1.5 $
UserTag cp Routine    <<EOR
require File::Copy;
sub {
my ($from, $to, $opt) = @_;
#Debug("cp from=$from to=$to umask=$opt->{umask}");
my $save_mask;
if($opt->{umask}) {
  $opt->{umask} = oct($opt->{umask});
  $save_mask = umask($opt->{umask});
}
my $status = File::Copy::copy($from, $to);

if ($opt->{preserve_times}) {
  my ($atime, $mtime);

  ($atime, $mtime) = (stat $from)[8,9];

  if ($atime) {
    $status = utime($atime, $mtime, $from);
  }
  else {
    $status = 0;
  }
}

umask($save_mask) if defined $save_mask;
return '' if $opt->{hide};
return $status;
}
EOR


Name

crypt — run Unix crypt() function on input data

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

The filter calls Perl crypt function to encrypt input data.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Filter example with random salt

The encrypted string should be different each time you run the code because the salt is random.
Encrypted string TEST with random salt is: 
[filter crypt]TEST[/filter].

Example: Filter example with hand-specified salt

The encrypted string should be the same each time you run the code because the salt does not change.
Encrypted string TEST with salt of AB is: 
[filter crypt.AB]TEST[/filter].

NOTES

In Interchange version 4.6.0, this symbol changed type from Filter to User Interface Tag.

AVAILABILITY

crypt is available in Interchange versions:

4.6.0, 4.6.0, 4.8.0, 5.0.0, 5.2.0, 5.4.0, 5.6.0, 5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/crypt.coretag
Lines: 19


# Copyright 2003-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: crypt.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag crypt Order     value salt
UserTag crypt attrAlias password value
UserTag crypt attrAlias crypted salt
UserTag crypt Version   $Revision: 1.6 $
UserTag crypt Routine   <<EOR
sub {
my ($string, $salt) = @_;
return crypt($string, $salt ? $salt : Vend::Util::random_string(2))
}
EOR


Name

css — generate CSS file and create a link to it

ATTRIBUTES

AttributePos.Req.DefaultDescription
name YesYes  Name of the CSS file. The name will be forced to lowercase, and the ".css" extension will be added unconditionally.
basefile     If the Variable is being used dynamically via DirConfig, this should be the filename the CSS is contained in. The file will be checked for modification time, and the CSS will be rebuilt if it's older than the source file.
imagedir   Value of the ImageDir directive Image prefix to use.
no_imagedir   0 Don't prepend value of the imagedir option to the generated link URL?
literal     Literal, in-place CSS definition. See the section called “EXAMPLES”.
media     The media attribute for the link HTML tag. For example, PRINT.
mode   0644 File creation mode.
output_dir   images Directory to place generated files to. It makes sense to match this with the ImageDir value.
relative   0 Copy the directory hierarchy in the output directory. Say, the css tag on the info/index.html page would produce output in images/info/theme_css.css.
timed     Regenerate the file on a timed basis? Default unit are minutes, but you can pass any standard interval.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag builds a CSS file (from a Variable or other sources) and generates a link to it.

Note that if you're providing the literal argument, the CSS file won't be rebuilt when you change the literal, in-place definition changes. To cause rebuild, you must explicitly delete the generated .css file.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: MV_PAGE

EXAMPLES

Example: Simplest tag example

[css THEME_CSS]

In the example above, the css will look for the images/theme_css.css, and generate an HTML link to it (<link rel="stylesheet" href="/images/theme_css.css">).


You can either save your CSS in a scratch variable, or provide it directly in-place. Here are both variants:

[set my_css]
.title { background-color: #336699; }
[/set]

[css name="test_css1" literal="[scratch my_css]"]
[css name="test_css2" literal="body { background-color: yellow; }"]

NOTES

When Interchange is ran in RPC ic run mode, the <pragma>dynamic_variables_file_only</pragma> pragma must be enabled to activate the standard THEME_CSS update mechanism. Namely, that will force Interchange to always read the latest copy of THEME_CSS, instead of using cached data.

AVAILABILITY

css is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/css.tag
Lines: 126


# Copyright 2003-2009 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag css Order   name
UserTag css addAttr
UserTag css Version $Revision: 1.9 $
UserTag css Routine <<EOR
sub {
my ($name, $opt) = @_;

use vars qw/$Tag/;

return unless $name;

my $bn = lc $name;
$bn .= '.css';

my $dir = $opt->{output_dir} ||= 'images';

my $id = "";

if (! $opt->{no_imagedir} ) {
$id = $opt->{imagedir} || $Vend::Cfg->{ImageDir};
$id =~ s:/*$:/:;
}

$dir =~ s:/+$::;

if($opt->{relative}) {
my @dirs = split m{/}, $Global::Variable->{MV_PAGE};
pop @dirs;
if(@dirs) {
  $id .= join "/", @dirs, '';
  $dir = join "/", $dir, @dirs;
  }
}

my $sourcetime;
if($opt->{basefile}) {
  $sourcetime = (stat($opt->{basefile}))[9];
#::logDebug("basefile=$opt->{basefile} sourcetime=$sourcetime");
}

my $url = "$id$bn";
my $fn  = "$dir/$bn";


my $write;
my $success;

my @stat = stat($fn);
my $writable;

if(@stat) {
  $writable = -w _;
  if($opt->{basefile}) {
    if($sourcetime > $stat[9]) {
#::logDebug("Found a basefile, out of date at modtime=$stat[9]");
      $write = 1;
    }
    else {
#::logDebug("Found a basefile, in date at modtime=$stat[9]");
      $success = 1;
    }
  }
  elsif($opt->{timed}) {
    my $now = time();
    $opt->{timed} .= ' min' if $opt->{timed} =~ /^\d+$/;
    my $fliptime = adjust_time($opt->{timed}, $stat[9]);
#::logDebug("fliptime=$fliptime now=$now");
    if ($fliptime <= $now) {
      $write = 1;
    }
    else {
      $success = 1;
    }
  }
  else {
    $success = 1;
  }
}
else {
  $writable = -w $dir;
  $write = 1;
}


my $extra = '';
$extra .= qq{ media="$opt->{media}"} if $opt->{media};

my $css;
$css = length($opt->{literal})
      ? $opt->{literal}
      : interpolate_html($Tag->var($name));
$css =~ s/^\s*<style.*?>\s*//si;
$css =~ s:\s*</style>\s*$:\n:i;

WRITE: {
  last WRITE unless $write;
  if(! $writable) {
    if(@stat) {
      logError("CSS file %s has no write permission.", $fn);
    }
    else {
      if ( -d $dir ) {
        logError("CSS dir %s has no write permission.", $dir);
      }
      else {
        logError("CSS dir %s does not exist.", $dir);
      }
    }
    last WRITE;
  }
  my $mode = $opt->{mode} ? oct($opt->{mode}) : 0644;
  $success = $Tag->write_relative_file($fn, $css) && chmod($mode, $fn)
    or logError("Error writing CSS file %s, returning in page", $fn);
}

return qq{<link rel="stylesheet" href="$url"$extra>} if $success;
return qq{<style type="text/css">\n$css</style>};
}
EOR

AUTHORS

Mike Heins, Interchange Development Group

SEE ALSO


Name

currency — format number as currency, honoring default or specified locale

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

The filter formats input number as a currency. All currency-related options and default locale are honored, and a specific locale can also be set as well.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Displaying a value formatted as a currency

[filter currency]40.2[/filter]

Example: Displaying a value in specific locale formatted as a currency

[filter currency.fr_FR]40.2[/filter]

NOTES

In Interchange version 4.6.0, this symbol changed type from Filter to System Tag.

AVAILABILITY

currency is available in Interchange versions:

4.6.0, 4.6.0, 4.8.0, 5.0.0, 5.2.0, 5.4.0, 5.6.0, 5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/currency.coretag
Lines: 21


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: currency.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag currency            Order        convert noformat
UserTag currency            hasEndTag
UserTag currency            Interpolate
UserTag currency            addAttr
UserTag currency            PosNumber    2
UserTag currency            Version      $Revision: 1.5 $
UserTag currency            Routine      <<EOR
sub {
my($convert,$noformat,$opt,$amount) = @_;
return Vend::Util::currency($amount, $noformat, $convert, $opt);
}
EOR


Name

data — get or set value of a named field or row from a database table or user session

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ table | base | database ] Yes Yes The name of the table to fetch from.
[ field | col | column | name ] Yes Yes The name of the field whose value you want to fetch. Required unless returning the entire row in combination with the hash= option.
[ key | code | row ] Yes The key that identifies the row to fetch.
safe_data 0 Is data safe?
value Set field to specified value. If increment= is true, increment the field by the specified value (negative increments can be used for decreasing).
filter If reading a field, apply specified filter to the value before displaying. It setting a field, apply specified filter to the value before updating the database.
increment 0 Increment or decrement field content by value=? Unless value= is specified, increment by 1.
append 0 Append the field instead of "truncating" before write?
alter change, add or delete.
serial 0
foreign Select data element based on a specified foreign key. This allows selection of a field or row based on a column that is not the primary key in the database table. If the key is unique, first selected is returned. Foreign key can also be specified as a hash, see the section called “EXAMPLES”.
hash Return the result as a reference to a hash? Hash keys will correspond to column names.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag is primarily used for reading fields from database tables or user's session namespace. However, with appropriate options, whole rows can be returned, and the fields can be set, incremented, appended and filtered.

If a database with WRITE_CONTROL enabled is to be written (such as a DBM-based database, which has it by default), it must be flagged writable on the page wishing to perform the update; use [tag flag write]DATABASE_NAME[/tag] to mark a database writable, and do this before any access to that table.

In addition, the data tag can access values in users' session namespace, using the special session keyword. Do not call your own database "session" because it would mask accesses to the actual sessions database.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic example

Display price for the item SKU 4595:

[data products price 4595]

Example: Dumping user session

To dump user session, see dump_session. Once you do it, you can learn the names of all the session keys you can use in the following example.


Example: Retrieving session values

In this example we produce a simple "report" about the user. We take the data from the user's session record.

[if session logged_in]
  User is logged in as [data session username].
[else]
  User is not logged in.
[/else]
[/if]                                              <br />
[data session host] is user's IP.                  <br />
Browser used is [data session browser].            <br />

Example: Retrieving fields from a table using a foreign key

If we wrote [data products price 4595], we would retrieve the price of the item SKU 4595. The SKU column is the primary key in the products database, and that's why Interchange implicitly searches it for the specified key=.

To retrieve price of an item based on say, it's description field (which is not a primary key), we need to use the foreign key functionality:

[data
  table=products
  column=price
  foreign=description
  key="Nice Bio Test"
]

Example: Retrieving fields from a table using foreign key hash

To retrieve SKU of an item based on say, both it's description and price fields, we need to use the foreign key functionality with the hash argument:

[data
  table=products
  column=price
  foreign.description='Nice Bio Test'
  foreign.price=275.45
]

TODO not working


Example: Retrieving fields from a table using foreign key array

Sometimes you want a query that is optimized in a particular order. To achieve that, use either your custom code, or an array-type foreign key:

[data
  table=products
  column=price
  foreign.0="price=275.45"
  foreign.1="description='Nice Bio Test'"
]

TODO not working


Example: Retrieving rows from a database

Here's a Perl example of retrieving complete table rows.

[perl tables=products]
  my $row_hash = $Tag->data({
    table   => 'products',
    key     => '4595',
    hash    => 1
  });

  my $out = "Item SKU " . $row_hash->{sku} . " has";

  $out .= " price " . $row_hash->{price} . " and" .
          " description " . $row_hash->{description} . ". Cheers!";

  $out
[/perl]

NOTES

AVAILABILITY

data is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/data.coretag
Lines: 22


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: data.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag data                Order        table field key
UserTag data                addAttr
UserTag data                attrAlias    column field
UserTag data                attrAlias    code key
UserTag data                attrAlias    base table
UserTag data                attrAlias    database table
UserTag data                attrAlias    col field
UserTag data                attrAlias    row key
UserTag data                attrAlias    name field
UserTag data                Implicit     increment increment
UserTag data                PosNumber    3
UserTag data                Version      $Revision: 1.4 $
UserTag data                MapRoutine   Vend::Interpolate::tag_data

Source: lib/Vend/Interpolate.pm
Lines: 887

sub tag_data {
my($selector,$field,$key,$opt,$flag) = @_;

local($Safe_data);
$Safe_data = 1 if $opt->{safe_data};

my $db;

if ( not $db = database_exists_ref($selector) ) {
  if($selector eq 'session') {
    if(defined $opt->{value}) {
      $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
        if $opt->{filter};
      if ($opt->{increment}) {
        $Vend::Session->{$field} += (+ $opt->{value} || 1);
      }
      elsif ($opt->{append}) {
        $Vend::Session->{$field} .= $opt->{value};
      }
      else  {
        $Vend::Session->{$field} = $opt->{value};
      }
      return '';
    }
    else {
      my $value = $Vend::Session->{$field} || '';
      $value = filter_value($opt->{filter}, $value, $field)
        if $opt->{filter};
      return $value;
    }
  }
  else {
    logError( "Bad data selector='%s' field='%s' key='%s'",
          $selector,
          $field,
          $key,
    );
    return '';
  }
}
elsif($opt->{increment}) {
#::logDebug("increment_field: key=$key field=$field value=$opt->{value}");
  return increment_field($Vend::Database{$selector},$key,$field,$opt->{value} || 1);
}
elsif (defined $opt->{value}) {
#::logDebug("alter table: table=$selector alter=$opt->{alter} field=$field value=$opt->{value}");
  if ($opt->{alter}) {
    $opt->{alter} =~ s/\W+//g;
    $opt->{alter} = lc($opt->{alter});
    if ($opt->{alter} eq 'change') {
      return $db->change_column($field, $opt->{value});
    }
    elsif($opt->{alter} eq 'add') {
      return $db->add_column($field, $opt->{value});
    }
    elsif ($opt->{alter} eq 'delete') {
      return $db->delete_column($field, $opt->{value});
    }
    else {
      logError("alter function '%s' not found", $opt->{alter});
      return undef;
    }
  }
  else {
    $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
      if $opt->{filter};
#::logDebug("set_field: table=$selector key=$key field=$field foreign=$opt->{foreign} \
 value=$opt->{value}");
    my $orig = $opt->{value};
    if($opt->{serial}) {
      $field =~ s/\.(.*)//;
      my $hk = $1;
      my $current = database_field($selector,$key,$field,$opt->{foreign});
      $opt->{value} = dotted_hash($current, $hk, $orig);
    }
    my $result = set_field(
            $selector,
            $key,
            $field,
            $opt->{value},
            $opt->{append},
            $opt->{foreign},
          );
    return $orig if $opt->{serial};
    return $result
  }
}
elsif ($opt->{serial}) {
  $field =~ s/\.(.*)//;
  my $hk = $1;
  return ed(
        dotted_hash(
          database_field($selector,$key,$field,$opt->{foreign}),
          $hk,
        )
      );
}
elsif ($opt->{hash}) {
  return undef unless $db->record_exists($key);
  return $db->row_hash($key);
}
elsif ($opt->{filter}) {
  return filter_value(
    $opt->{filter},
    ed(database_field($selector,$key,$field,$opt->{foreign})),
    $field,
  );
}

#The most common , don't enter a block, no accoutrements
return ed(database_field($selector,$key,$field,$opt->{foreign}));
}

Source: lib/Vend/Interpolate.pm
Lines: 887

sub tag_data {
my($selector,$field,$key,$opt,$flag) = @_;

local($Safe_data);
$Safe_data = 1 if $opt->{safe_data};

my $db;

if ( not $db = database_exists_ref($selector) ) {
  if($selector eq 'session') {
    if(defined $opt->{value}) {
      $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
        if $opt->{filter};
      if ($opt->{increment}) {
        $Vend::Session->{$field} += (+ $opt->{value} || 1);
      }
      elsif ($opt->{append}) {
        $Vend::Session->{$field} .= $opt->{value};
      }
      else  {
        $Vend::Session->{$field} = $opt->{value};
      }
      return '';
    }
    else {
      my $value = $Vend::Session->{$field} || '';
      $value = filter_value($opt->{filter}, $value, $field)
        if $opt->{filter};
      return $value;
    }
  }
  else {
    logError( "Bad data selector='%s' field='%s' key='%s'",
          $selector,
          $field,
          $key,
    );
    return '';
  }
}
elsif($opt->{increment}) {
#::logDebug("increment_field: key=$key field=$field value=$opt->{value}");
  return increment_field($Vend::Database{$selector},$key,$field,$opt->{value} || 1);
}
elsif (defined $opt->{value}) {
#::logDebug("alter table: table=$selector alter=$opt->{alter} field=$field value=$opt->{value}");
  if ($opt->{alter}) {
    $opt->{alter} =~ s/\W+//g;
    $opt->{alter} = lc($opt->{alter});
    if ($opt->{alter} eq 'change') {
      return $db->change_column($field, $opt->{value});
    }
    elsif($opt->{alter} eq 'add') {
      return $db->add_column($field, $opt->{value});
    }
    elsif ($opt->{alter} eq 'delete') {
      return $db->delete_column($field, $opt->{value});
    }
    else {
      logError("alter function '%s' not found", $opt->{alter});
      return undef;
    }
  }
  else {
    $opt->{value} = filter_value($opt->{filter}, $opt->{value}, $field)
      if $opt->{filter};
#::logDebug("set_field: table=$selector key=$key field=$field foreign=$opt->{foreign} \
 value=$opt->{value}");
    my $orig = $opt->{value};
    if($opt->{serial}) {
      $field =~ s/\.(.*)//;
      my $hk = $1;
      my $current = database_field($selector,$key,$field,$opt->{foreign});
      $opt->{value} = dotted_hash($current, $hk, $orig);
    }
    my $result = set_field(
            $selector,
            $key,
            $field,
            $opt->{value},
            $opt->{append},
            $opt->{foreign},
          );
    return $orig if $opt->{serial};
    return $result
  }
}
elsif ($opt->{serial}) {
  $field =~ s/\.(.*)//;
  my $hk = $1;
  return ed(
        dotted_hash(
          database_field($selector,$key,$field,$opt->{foreign}),
          $hk,
        )
      );
}
elsif ($opt->{hash}) {
  return undef unless $db->record_exists($key);
  return $db->row_hash($key);
}
elsif ($opt->{filter}) {
  return filter_value(
    $opt->{filter},
    ed(database_field($selector,$key,$field,$opt->{foreign})),
    $field,
  );
}

#The most common , don't enter a block, no accoutrements
return ed(database_field($selector,$key,$field,$opt->{foreign}));
}


Name

db-date — report last-modified time of the named database source file

ATTRIBUTES

AttributePos.Req.DefaultDescription
table YesYesproductsInterchange database name.
format YesYes%A %d %b %YPOSIX strftime format specifier.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag displays the last-modified time of the database source text file. Output format can be specified using format=.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Displaying products database last-modified time

Provided that you use file-based databases in your catalog (*DB* variants), you can run this example:

[db-date]

NOTES

This tag will be of use for you only if you use source file based databases. If you use SQL databases, the logical connection with text source files will probably not be maintained so the output of this tag will be worthless.

AVAILABILITY

db-date is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/db_date.tag
Lines: 41


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: db_date.tag,v 1.4 2007-03-30 23:40:56 pajamian Exp $

# [db-date table format]
#
# This tag returns the last-modified time of a database table,
# 'products' by default. Accepts a POSIX strftime value for
# date format; uses '%A %d %b %Y' by default.
#
UserTag  db-date  Order     table format
UserTag  db-date  PosNumber 2
UserTag  db-date  Version   $Revision: 1.4 $
UserTag  db-date  Routine   <<EOF
sub {
  my ($db, $format) = @_;
my ($dbfile, $mtime);

# use defaults if necessary
$db = 'products' unless $db;
  $format = '%A %d %b %Y' unless $format;

# build database file name
$dbfile = $Vend::Cfg->{ProductDir} . '/' 
  . $Vend::Cfg->{Database}{$db}{'file'};

# get last modified time
$mtime = (stat ($dbfile))[9];

if (defined ($mtime)) {
  return POSIX::strftime($format, localtime($mtime));
} else {
  logError ("Couldn't stat $dbfile: $!\n");
}
}
EOF

SEE ALSO


Name

db-hash

ATTRIBUTES

AttributePos.Req.DefaultDescription
table Yes
column Yes
key Yes
value
show_error
keys
joiner
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

db-hash is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/db_hash.coretag
Lines: 62


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: db_hash.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag db-hash Order      table column key
UserTag db-hash PosNumber  3
UserTag db-hash addAttr
UserTag db-hash Version    $Revision: 1.5 $
UserTag db-hash Routine    <<EOR
sub {
my($table, $col, $key, $opt) = @_;
$col =~ s/:+(.*)//s;
my $out;
my $rest = $1;
my $val = ::tag_data($table,$col,$key);

my $ref;
if ($val !~ /\S/) {
  $ref = {};
}
else {
  $ref = $Vend::Interpolate::ready_safe->reval($val);
  if (! ref $ref) {
    $ref = {};
  }
}
if (! $rest) {
  return $val unless defined $opt->{value};
}
my @extra;
@extra = split /:+/, $rest;
my $final = pop @extra;
my $curr = $ref;
$out .= "Original key request: $rest\n";
$out .= "\nFinal key: $final\n";
for(@extra) {
  $out .= "key --> $_\n";
  $curr = $curr->{$_};
  if (! ref $curr) {
    return "BAD HASH: $out" if $opt->{show_error};
    return;
  }
}

if($opt->{keys}) {
  return join get_joiner($opt->{joiner}), sort keys %$curr;
}
elsif(! defined $opt->{value}) {
  return $curr->{$final};
}
else {
  $curr->{$final} = $opt->{value};
  tag_data($table, $col, $key, { value => uneval_it($ref) });
  return $curr->{$final};
}
}
EOR

SEE ALSO


Name

db_columns — retrieve column names from a database table

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ name | table ] Yes Name of the database table.
[ fields | columns ] Yes Manually specify columns to be returned.
joiner Yes \n String joiner to use if column list is requested in Perl scalar context.
passed_order 0 With columns=, return columns in the passed order instead of table order?
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

db_columns returns the list of columns in a database table.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: looping over column list from the products table

<pre>
[loop list="[db-columns products]"]
  Column: [loop-code]
[/loop]
</pre>

Example: looping over column list, without using db_columns

It is possible to list table columns manually without the use of db_columns. The output will be satisfactory as long as you don't need db_column's columns= attribute.

[perl tables=products]
  $Scratch->{columns} = join ' ', $Db{products}->columns;
  return;
[/perl]

<pre>
[loop list="[scratch columns]"]
  Column: [loop-code]
[/loop]
</pre>

NOTES

A side effect of specifying passed_order=1 is the removal of invalid column names from the columns= list; column names not present in the database table are filtered out, instead of being returned regardless.

AVAILABILITY

db_columns is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/db_columns.coretag
Lines: 63


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: db_columns.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag db_columns  Order       name columns joiner passed_order
UserTag db_columns  AttrAlias   table name
UserTag db_columns  AttrAlias   fields columns
UserTag db_columns  Version     $Revision: 1.5 $
UserTag db_columns  Routine     <<EOR
sub {
my ($table,$columns, $joiner, $passed_order) = @_;
$table = $Values->{mv_data_table}
  unless $table;
my $db = Vend::Data::database_exists_ref($table)
  or return undef;
my $acl = UI::Primitive::get_ui_table_acl($table);
$db = $db->ref() unless $Vend::Interpolate::Db{$table};
my $key = $db->config('KEY');

$joiner = "\n" unless defined $joiner;

my @cols;
if(! $columns || $columns =~ /^[\s,\0]*$/) {
  @cols = $db->columns();
}
else {
  @cols = grep /\S/, split /[\s,\0]+/, $columns;
  my (@allcols) =  $db->columns();

  my %col;
  if($passed_order) {
    @col{@allcols} = @allcols;
    @allcols = @cols;
    my $found;
    for(@cols) {
      next unless $_ eq $key;
      $found = 1;
      last;
    }
    unshift (@allcols, $key) if ! $found;
  }
  else {
    @col{@cols} = @cols;
  }

  $col{$key} = $key if ! defined $col{$key};

  @cols = grep defined $col{$_}, @cols;
}

if($acl) {
  @cols = UI::Primitive::ui_acl_grep( $acl, 'fields', @cols);
}

return @cols if wantarray;
return join $joiner, @cols;
}
EOR

SEE ALSO


Name

debug — send messages to debug log

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag sends a message to Interchange debug log.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Sending a message to debug log

[debug] There are [nitems] items in session [data session id] [/debug]

NOTES

Debugging must be enabled for the tag to produce any noticeable effect; see debug glossary entry.

AVAILABILITY

debug is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/debug.coretag
Lines: 13


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: debug.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag debug  hasEndTag
UserTag debug  Interpolate
UserTag debug  Version      $Revision: 1.4 $
UserTag debug  MapRoutine   Vend::Util::logDebug

Source: lib/Vend/Util.pm
Lines: 1766

sub logDebug {
return unless $Global::DebugFile;

if(my $re = $Vend::Cfg->{DebugHost}) {
  return unless
     Net::IP::Match::Regexp::match_ip($CGI::remote_addr, $re);
}

if(my $sub = $Vend::Cfg->{SpecialSub}{debug_qualify}) {
  return unless $sub->();
}

my $msg;

if (my $tpl = $Global::DebugTemplate) {
  my %debug;
  $tpl = POSIX::strftime($tpl, localtime());
  $tpl =~ s/\s*$//;
  $debug{page} = $Global::Variable->{MV_PAGE};
  $debug{tag} = $Vend::CurrentTag;
  $debug{host} = $CGI::host || $CGI::remote_addr;
  $debug{remote_addr} = $CGI::remote_addr;
  $debug{request_method} = $CGI::request_method;
  $debug{request_uri} = $CGI::request_uri;
  $debug{catalog} = $Vend::Cat;
      if($tpl =~ /\{caller\d+\}/i) {
          my @caller = caller();
          for(my $i = 0; $i < @caller; $i++) {
              $debug{"caller$i"} = $caller[$i];
          }
      }
      $tpl =~ s/\{session\.([^}|]+)(.*?)\}/
              $debug{"session_\L$1"} = $Vend::Session->{$1};
              "{SESSION_\U$1$2}"
          /iegx;
  $debug{message} = errmsg(@_);

  $msg = Vend::Interpolate::tag_attr_list($tpl, \%debug, 1);
}

SEE ALSO

comment(7ic)


Name

default — (deprecated) return content of the named form input field, defaulting to value 'default'

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Name of the form variable.
default Yes Yes default Default value to return if the specified variable is missing or evaluates to a false value.
values_space Specify "values space" in which to perform the operation.
set Set form field variable value to the specified content.
filter Apply specified filter to the variable content. The application of a filter actually modifies the variable value in-place (in addition to, of course, displaying the filtered content).
keep 0 Only apply filter for display, and do not modify actual variable value?
scratch 0 Along with setting a form field value, also create the variable/content pair in the scratch space?
enable_itl 0 Allow ITL tags to appear in the output? By default, all "[" characters are encoded as "&#91;".
enable_html 0 Allow HTML tags to appear in the output? By default, all "<" characters are encoded as "&lt;".
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag returns the named form input field value. Any Interchange tags in the output are HTML- and ITL-escaped by default for security reasons.

This tag is very similar to value, except that it provides the default value for the default= parameter.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: displaying user's first name

Hello, [default fname Anonymous]!

Example: displaying user's first name in a modifiable field

<form action="[process]">
  Hello, <input type="text" name="fname" value="[default fname Anonymous]" />!
</form>

TODO: Add a submit button


Example: displaying user's first name, or falling back to the default

Hello, [default fname Anonymous]!

NOTES

AVAILABILITY

default is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/default.coretag
Lines: 23


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: default.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag default             Order        name default
UserTag default             addAttr
UserTag default             PosNumber    2
UserTag default             Version      $Revision: 1.5 $
UserTag default             Routine      <<EOR
# Returns the text of a user entered field named VAR.
# Same as tag [value name=name default="string"] except
# returns 'default' if not present
sub {
  my($var, $default, $opt) = @_;
$opt->{default} = !(length $default) ? 'default' : $default;
  return tag_value($var, $opt);
}
EOR

SEE ALSO


Name

delete_cart — delete shopping cart from UserDB

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ nickname | name ] YesYes Cart name to delete.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag deletes a shopping cart from the UserDB. This is basically the same as [userdb function=delete_cart nickname=CART_NAME].

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Delete cart "test"

Put the following on your page:

[seti cartname]test[/seti]

[delete_cart nickname="[scratch cartname]"]

NOTES

AVAILABILITY

delete_cart is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/delete_cart.tag
Lines: 21


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: delete_cart.tag,v 1.6 2007-03-30 23:40:56 pajamian Exp $

UserTag delete_cart Order     nickname
UserTag delete_cart AttrAlias name nickname
UserTag delete_cart Version   $Revision: 1.6 $
UserTag delete_cart Routine   <<EOR
sub {
my($nickname) = @_;

$Tag->userdb({function => 'delete_cart', nickname => $nickname});

return '';
}
EOR


Name

deliver — deliver arbritary content verbatim, without Interchange processing

ATTRIBUTES

AttributePos.Req.DefaultDescription
type yes no application/octet-stream Content MIME type
file File to be delivered
location URL for redirection
status HTTP status code and message
get_encrypted
extra_headers Any additional HTTP headers
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The deliver tag delivers possibly binary content to the user or redirects the user to another URL.

The content is read from a file specified by the file parameter or passed in the tag body.

Alternatively, you may use the tag to redirect the user to any URL passed in the location parameter.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Pragmas: <pragma>download</pragma>

EXAMPLES

[deliver type="application/csv" file="tmp/stats.csv"]

NOTES

AVAILABILITY

deliver is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/deliver.coretag
Lines: 100


# Copyright 2002-2016 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag deliver Order     type
UserTag deliver HasEndTag
UserTag deliver addAttr
UserTag deliver Version   1.9
UserTag deliver Routine   <<EOR
sub {
my ($type, $opt, $body) = @_;
my $out;
use vars qw/$Tag/;
$Tag ||= new Vend::Tags;
if($opt->{file}) {
  return undef unless -f $opt->{file};

  my ($tmp, %rfopt);

  # determine mime type devoid of explicit value
  $type ||= Vend::Util::mime_type($opt->{file});

  # avoid encoding of binary files
  if ($type !~ m{^text/}i) {
    $rfopt{encoding} = 'raw';
  }

  $tmp = readfile($opt->{file}, undef, undef, \%rfopt);
  $out = \$tmp;
}
elsif(ref $body) {
  $out = $body;
}
elsif(length $body) {
  $out = \$body;
}

if($opt->{extra_headers}) {
  my @lines = grep /\S/, split /[\r\n]+/, $opt->{extra_headers};
  for(@lines) {
    my ($header, $val) = split /:/, $_;
    $Tag->tag( {  op => 'header',
          name => $header,
          content => $val,
        } );
  }
}

## This is a bounce, returns
if($opt->{location}) {
  $type = Vend::Util::header_data_scrub($type);
  $opt->{status} = Vend::Util::header_data_scrub($opt->{status});
  $opt->{location} = Vend::Util::header_data_scrub($opt->{location});

  $type and $Tag->tag( {
          op => 'header',
          name => 'Content-Type',
          content => $type,
        } );
  $Tag->tag( {  op => 'header',
            name => 'Status',
            content => $opt->{status} || '302 moved',
          } );
  $Tag->tag( {  op => 'header',
            name => 'Location',
            content => $opt->{location},
          } );
  if(! $body) {
    $body = qq{Redirecting to <A href="%s">%s</a>.};
    $body = errmsg($body, $opt->{location}, $opt->{location});
  }
  ::response($body);
  $Vend::Sent = 1;
  return 1;
}

$type ||= 'application/octet-stream';

$Tag->tag( { op => 'header', name => 'Status', content => $opt->{status} } )
  if $opt->{status};
$Tag->tag( { op => 'header', name => 'Content-Type', content => $type } );

if($opt->{get_encrypted}) {
$opt->{get_encrypted} = 1 unless $opt->{get_encrypted} =~ /^\d+$/;
my $idx = $opt->{get_encrypted};
while ($idx--) {
  $$out =~ s/.*?(---+BEGIN PGP MESSAGE--+)/$1/s;
}
$$out =~ s/(---+END PGP MESSAGE---+).*/$1\n/s;
}

$::Pragma->{download} = 1;
::response($out);
$Vend::Sent = 1;
return 1;
}
EOR


Name

description — return description for a specific product from the products database

ATTRIBUTES

AttributePos.Req.DefaultDescription
code YesYes Product SKU.
base Yes All ProductFiles databasesDatabase to look up the product in.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag returns the description for a specified product. If no base= is specified, all ProductFiles are searched for the specified SKU.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Displaying description for item 1299

[description 1299]

NOTES

AVAILABILITY

description is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/description.coretag
Lines: 13


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: description.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag description         Order        code base
UserTag description         PosNumber    2
UserTag description         Version      $Revision: 1.4 $
UserTag description         MapRoutine   Vend::Data::product_description

Source: lib/Vend/Data.pm
Lines: 231

sub product_description {
my ($code, $base) = @_;
return "" unless $base = product_code_exists_ref($code, $base || undef);
return database_field($base, $code, $Vend::Cfg->{DescriptionField});
}


Name

diff

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ current | curr ] Yes
[ previous | prev ] Yes
flags
context
unified
safe_data
ascii
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

diff is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/diff.coretag
Lines: 62


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: diff.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag diff Order       current previous
UserTag diff attrAlias   curr current prev previous
UserTag diff addAttr
UserTag diff Version     $Revision: 1.4 $
UserTag diff Routine     <<EOR
sub {
  my ($curr, $prev, $opt) = @_;

$opt->{flags} .= ' -c' if $opt->{context};
$opt->{flags} .= ' -u' if $opt->{unified};

my $data_opt = {};
$data_opt->{safe_data} = 1 if $opt->{safe_data};

  unless($opt->{flags} =~ /^[-\s\w.]*$/) {
      Log("diff tag: Security violation with flags: $opt->{flags}");
      return "Security violation with flags: $opt->{flags}. Logged.";
  }

  my ($currfn, $prevfn);

  if($curr =~ /^(\w+)::(.*?)::(.*)/) {
      my ($table, $col, $key) = ($1, $2, $3);
      $currfn = "tmp/$Vend::SessionName.current";
  my $data = tag_data($table, $col, $key, $data_opt);
  if ($opt->{ascii}) {
    $data =~ s/\r\n?/\n/g;
    $data .= "\n" unless substr($data, -1, 1) eq "\n";
  }
      Vend::Util::writefile(">$currfn", $data);
  }
  else {
      $currfn = $curr;
  }

  if($prev =~ /^(\w+)::(.*?)::(.*)/) {
      my ($table, $col, $key) = ($1, $2, $3);
      $prevfn = "tmp/$Vend::SessionName.previous";
  my $data = tag_data($table, $col, $key, $data_opt);
  if ($opt->{ascii}) {
    $data =~ s/\r\n?/\n/g;
    $data .= "\n" unless substr($data, -1, 1) eq "\n";
  }
      Vend::Util::writefile(">$prevfn", $data);
  }
  else {
      $prevfn = $prev;
  }

#Debug("diff command: 'diff $opt->{flags} $prevfn $currfn'");
  return `diff $opt->{flags} $prevfn $currfn`;
}
EOR

SEE ALSO


Name

diffmerge

ATTRIBUTES

AttributePos.Req.DefaultDescription
flags
safe_data
ascii
result
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

diffmerge is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/diffmerge.coretag
Lines: 130


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: diffmerge.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

# This tag uses GNU diff3 to merge two texts blocks that were
# modified from the same ancestral text together, and marks
# conflicts that may appear. This is similar to CVS's merging
# and conflict marking. The names the diff3 manpage uses are:
#
#        older
#         / \
#        /   \
#       /     \
#    mine    yours
#
# You supply pointers to three text blocks, either as file names or
# database fields in the form Table::Column::Key. 'mine' can instead
# be provided in the body, between the opening and closing tags.
#
# The tag returns the merged text. You can find out whether a
# conflict was detected by providing the name of a scratch variable
# in the 'result' option where the return code from diff3 will be placed.
#
# Set the 'ascii' option to allow for different newline types and
# ignore whether the last line of the file has a newline.
#
# Set the 'safe_data' option to allow raw data to be pulled from the
# database without escaping left brackets (turning [ into &#91;).
#
# Examples:
#
# [diffmerge /tmp/abcd2 /tmp/abcd1 /tmp/abcd3]
#
# [diffmerge
#     yours="content::pagebody::00001"
#     older="backup::pagebody::00001"
#     ascii=1
#     result=diff_result
#     safe_data=1
# ][scratch new_pagebody][/diffmerge]

UserTag diffmerge Interpolate   1
UserTag diffmerge hasEndTag
UserTag diffmerge addAttr
UserTag diffmerge Version       $Revision: 1.4 $

# These designations come from the diff3 manpage.
# It seemed easier to use their names than to make up new ones.
UserTag diffmerge Order yours older mine

# But here I try to make up new ones anyway. :)
UserTag diffmerge attrAlias     <<EOA
current    mine
curr    mine
previous  yours
prev    yours
old      older
EOA

UserTag diffmerge Routine       <<EOR
sub {
  my ($yours, $older, $mine, $opt, $body) = @_;

  unless ($opt->{flags} =~ /^[-\s\w.]*$/) {
      Log("diffmerge tag: Security violation with flags: $opt->{flags}");
      return "Security violation with flags: $opt->{flags}. Logged.";
  }

my ($minefn, $yoursfn, $olderfn, $cmd, $merge);
my $tmpbasename = "tmp/$Vend::SessionName";

my $data_opt = {};
$data_opt->{safe_data} = 1 if $opt->{safe_data};

my $asciifix = sub {
  local $_ = shift;
  if ($opt->{ascii}) {
    s/\r\n?/\n/g;
    $_ .= "\n" unless substr($_, -1, 1) eq "\n";
  }
  return $_;
};

my $putfile = sub {
  my ($name, $passed, $fn) = @_;
    if ($$passed =~ /^(\w+)::(.*?)::(.*)/) {
        my ($table, $col, $key) = ($1, $2, $3);
    my $data = $asciifix->( tag_data($table, $col, $key, $data_opt) );
        $$fn = "$tmpbasename.$name";
        Vend::Util::writefile(">$$fn", $data);
    }
    else {
        $$fn = $$passed;
    }
};

if ($body) {
  $body = $asciifix->($body);
  $minefn = "tmp/$Vend::SessionName.mine";
  Vend::Util::writefile(">$minefn", $body);
}
elsif ($mine) {
  $putfile->('mine', \$mine, \$minefn);
}

$putfile->('yours', \$yours, \$yoursfn);
$putfile->('older', \$older, \$olderfn);

  $cmd = "diff3 -m $opt->{flags} $minefn $olderfn $yoursfn";
#Debug("diffmerge command: '$cmd'");
  $merge = `$cmd`;

if (defined $opt->{result}) {
  unless ($opt->{result} =~ /\W/) {
    $Scratch->{$opt->{result}} = $? >> 8;
#Debug("diffmerge put $Scratch->{$opt->{result}} into scratch $opt->{result}");
  }
  else {
    Log("diffmerge tag: Invalid 'result' option given; must be a valid \
 name for a scratch variable");
  }
}

return $merge;
}
EOR

SEE ALSO


Name

directive_value

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes
unparse Yes
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

directive_value is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/directive_value.coretag
Lines: 23


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: directive_value.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag directive_value order      name unparse
UserTag directive_value PosNumber  2
UserTag directive_value Version    $Revision: 1.4 $
UserTag directive_value Routine    <<EOR
sub {
my($name,$unparse) = @_;
my ($value, $parsed) = UI::Primitive::read_directive($name);
if($unparse) {
  $parsed =~ s/\@\@([A-Z]\w+?)\@\@/$Global::Variable->{$1}/g;
  $parsed =~ s/__([A-Z]\w+?)__/$Vend::Cfg->{Variable}{$1}/g;
}
return ($parsed || $value);
}
EOR

SEE ALSO


Name

discount — implement per-customer item or order discounts

ATTRIBUTES

AttributePos.Req.DefaultDescription
codeYes   
discount_space | space     
subtract    
level    
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag is used to implement per-customer discounts. Discounts can be applied to individual items, groups of items, or total orders.

The tag accepts Perl code in its body. Two special variables, $q and $s, are available and represent item quantity and base price.

Perl variables can be shared among calc blocks and the discount tag within the same page, allowing for greater flexibility. See the section called “EXAMPLES”.

For an introduction and theory behind item discounts, please see the discount glossary entry.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Straight 20% discount on all items

[discount ALL_ITEMS] $s * .8 [/discount]

Or the same as above, with named attributes:

[discount code=ALL_ITEMS] $s * .8 [/discount]

Example: Discount of 25% for an individual item

To take 25% off of item SKU 00-342, use:

[discount 00-342] $s * .75 [/discount]

Example: Discount of 25% for an individual item, only if quantity ordered is 1

[discount 00-342] $q == 1 ? $s * 0.75 : $s [/discount]

Example: A discount of 5 on entire order

[discount ENTIRE_ORDER] $s - 5 [/discount]

Example: Resetting discounts

To reset a discount, simply set it to the empty string:

[discount ALL_ITEMS][/discount]

Example: Dynamic discounts using Perl

Perl code can, of course, be used to apply the discounts. Sometimes, this needs to include some pre-processing which you need to do outside the discount tag. You can freely do this within the calc tag, as the values will be retained and visible inside discount. For each item ordered, this example gives a 10% discount for a minimum quantity of 2, with 5% more for each "extra quantity" (but up to a maximum discount of 30%):

[calc] 
  [item-list]
    $totalq{"[item-code]"} += [item-quantity];
  [/item-list]
  return '';
[/calc]

[item-list]
  [discount code="[item-code]"]
    return ($s)       if $totalq{"[item-code]"} == 1;
    return ($s * .70) if $totalq{"[item-code]"} > 6;
    return ($s * ( 1 - 0.05 * $totalq{"[item-code]"} ));
  [/discount]
[/item-list]

Example: Applying discount to a specific "instance" within ordered quantity

Here is an example of a special discount for item code 00-343 which sets the price of the second "instance" ordered to 0.01:

[discount 00-343]
  return $s if $q == 1;
  my $p = $s/$q;
  my $t = ($q - 1) * $p;
  $t .= 0.01;
  return $t;
[/discount]

Example: Displaying the discount amount received

If you want to display the discount amount to the user, simply use the item-discount tag:

[item-list]
  Discount for [item-code]: [item-discount]
[/item-list]

Example: Displaying the total discount

When you want to display the total discount for an item, you need to use calc:

[item-list]
Total discount applied to [item-code] is: [currency][calc]
                                       [item-discount noformat=1] * [item-quantity]
                                     [/calc][/currency]
[/item-list]

Example: Using wholesale price for special promotions

In the following example, items with modifier "promotion" receive the price defined in products:wholesale instead of products:price.

[perl tables='products']
my %seen = ();

foreach $item (@{$Items}) {
  next unless $item->{promotion};
  next if $seen{$item->{code}}++;

  my $promo_price = $Tag->data('products','wholesale',$item->{code});

  $Session->{discount}->{$item->{code}} = "$promo_price * \$q";
}
[/perl]


NOTES

AVAILABILITY

discount is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/discount.coretag
Lines: 66


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: discount.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $

UserTag discount            Order        code
UserTag discount            AddAttr
UserTag discount            attrAlias    space discount_space
UserTag discount            hasEndTag
UserTag discount            PosNumber    1
UserTag discount            Version      $Revision: 1.7 $
UserTag discount            Routine      <<EOR

# Sets the value of a discount field
sub {
my($code, $opt, $value) = @_;

# API compatibility
if(! ref $opt) {
  $value = $opt;
  $opt = {};
}

if (! ($::Discounts
    and $Vend::Session->{discount_space}
    and $Vend::Session->{discount}
    and $Vend::DiscountSpaceName)) {
  $::Discounts
     = $Vend::Session->{discount}
    = $Vend::Session->{discount_space}{ $Vend::DiscountSpaceName = 'main' }
    ||= ($Vend::Session->{discount} || {});
}

my $dspace;
if ($Vend::Cfg->{DiscountSpacesOn} and $dspace = $opt->{discount_space}) {
  $dspace = $Vend::Session->{discount_space}{$dspace} ||= {};
}
else {
  $dspace = $::Discounts;
}

if($opt->{subtract}) {
  $value = <<EOF;
my \$tmp = \$s - $opt->{subtract};
\$tmp = 0 if \$tmp < 0;
return \$tmp;
EOF
}
elsif ($opt->{level}) {
  $value = <<EOF;
return (\$s * \$q) if \$q < $opt->{level};
my \$tmp = \$s / \$q;
return \$s - \$tmp;
EOF
}

$dspace->{$code} = $value;
delete $dspace->{$code}
  unless defined $value and $value;
return '';
}
EOR


Name

discount_space

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

discount_space is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/discount_space.coretag
Lines: 65


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: discount_space.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag discount_space  Documentation <<EOF
The discount-space is rather equivalent to the values-space functionality.
Interchange keeps discount information in a single hash at $Vend::Session->{discount}.
This is fine except when you start using multiple shopping carts to represent different
portions of the store and fundamentally different transactions; any common item codes
will result in one cart's discounts leaking into that of the other cart...

Consequently, we can use a discount space to give a different namespace to various discounts.
This can be used in parallel with mv_cartname for different shopping carts.
Set up a master hash of different discount namespaces in the session. Treat the default one
as 'main' (like Interchange does with the cart). When discount space is called and a name
is given, point the $Vend::Session->{discount} to the appropriate hashref held in this master
hash.

Some options:
clear - this will empty the discounts for the space specified, after switching to that space.
current - this will not change the namespace; it simply returns the current space name.
EOF

UserTag discount_space  order      name
UserTag discount_space  AttrAlias  space   name
UserTag discount_space  AddAttr
UserTag discount_space  Version    $Revision: 1.6 $
UserTag discount_space  Routine    <<EOF
sub {
my ($namespace, $opt) = @_;
$namespace ||= 'main';
#::logDebug("Tag discount-space called for namespace '$namespace'! Clear: \
 '$opt->{clear}' Current: '$opt->{current}'");

unless ($Vend::Session->{discount} and $Vend::Session->{discount_space}) {
  # Initialize the discount space hash, and just assign whatever's in
  # the current discount hash to it as the 'main' entry.
  # Furthermore, instantiate the discount hash if it doesn't already exist, otherwise
  # the linkage between that hashref and the discount_space hashref might break...
#::logDebug('Tag discount-space: initializing discount_space hash; first \
 call to this tag for this session.');
  $::Discounts
    = $Vend::Session->{discount}
    = $Vend::Session->{discount_space}{$Vend::DiscountSpaceName = 'main'}
    ||= ($Vend::Session->{discount} || {});
  $Vend::Session->{discount_space}{main} = $Vend::Session->{discount} ||= {};
}

logError('Discount-space tag called but discount spaces are deactivated \
 in this catalog.'), return undef
  unless $Vend::Cfg->{DiscountSpacesOn};

return ($Vend::DiscountSpaceName ||= 'main') if $opt->{current};

$::Discounts = $Vend::Session->{discount} = $Vend::Session->{discount_space}{$namespace} ||= {};
$Vend::DiscountSpaceName = $namespace;
#::logDebug("Tag discount-space: set discount space to '$namespace'");

%$::Discounts = () if $opt->{clear};

return undef;
}
EOF

SEE ALSO


Name

dispatch

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

dispatch is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 4003

sub tag_dispatch {
my($tag, $count, $item, $hash, $chunk) = @_;
$tag = lc $tag;
$tag =~ tr/-/_/;
my $full = lc "$Orig_prefix-tag-$tag";
$full =~ tr/-/_/;
#::logDebug("tag_dispatch: tag=$tag count=$count chunk=$chunk");
my $attrseq = [];
my $attrhash = {};
my $eaten;
my $this_tag;

$eaten = Vend::Parse::_find_tag(\$chunk, $attrhash, $attrseq);
substr($chunk, 0, 1) = '';

$this_tag = Vend::Parse::find_matching_end($full, \$chunk);

$attrhash->{prefix} = $tag unless $attrhash->{prefix};

my $out;
if(defined $Dispatch_hash{$tag}) {
  $out = $Dispatch_hash{$tag}->($count, $item, $hash, $attrhash, $this_tag);
}
else {
  $attrhash->{body} = $this_tag unless defined $attrhash->{body};
#::logDebug("calling tag tag=$tag this_tag=$this_tag attrhash=" . uneval($attrhash));
  $Tag ||= new Vend::Tags;
  $out = $Tag->$tag($attrhash);
}
return $out . $chunk;
}

SEE ALSO


Name

display — display HTML form element

ATTRIBUTES

AttributePos.Req.DefaultDescription
table yes
column yes
key yes
type widget
template
override
value
default
already_got_data
ui_no_meta_display
meta
meta_table
view
arbitrary
specific
label
default_widget
restrict_allow
name name of form element
restrict_deny
cols
rows
return_hash
applylocale
meta_url
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Dropdown menus with country names

Display country dropdown menus looked up from the country table, using empty value for billing as default.

[display name="country" table="country" lookup=code field=name type="select" value="[value country]"]
[display name="b_country" table="country" lookup=code field=name type="select" value="[value b_country]" options="=-- [L]Please select[/L] --"]

NOTES

AVAILABILITY

display is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/display.coretag
Lines: 21


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: display.coretag,v 1.14 2007-03-30 23:40:54 pajamian Exp $

UserTag display Order       table column key
UserTag display attrAlias   base table
UserTag display attrAlias   database db
UserTag display attrAlias   col column
UserTag display attrAlias   row key
UserTag display attrAlias   code key
UserTag display addAttr     1
UserTag display Interpolate 1
UserTag display posNumber   3
Require Module  Vend::Table::Editor
UserTag display Version     $Revision: 1.14 $
UserTag display MapRoutine  Vend::Table::Editor::display

Source: lib/Vend/Table/Editor.pm
Lines: 1075

sub display {
my ($table,$column,$key,$opt) = @_;

if( ref($opt) ne 'HASH' ) {
  $opt = get_option_hash($opt);
}

my $template = $opt->{type} eq 'hidden' ? '' : $opt->{template};

if($opt->{override}) {
  $opt->{value} = defined $opt->{default} ? $opt->{default} : '';
}

if(! defined $opt->{value} and $table and $column and length($key)) {
  $opt->{value} = tag_data($table, $column, $key);
  $opt->{already_got_data} = 1;
}

my $mtab;
my $record;

my $no_meta = $opt->{ui_no_meta_display};

METALOOK: {
  ## No meta display wanted
  last METALOOK if $no_meta;
  ## No meta display possible
  $table and $column or $opt->{meta}
    or last METALOOK;

  ## We get a metarecord directly, though why it would be here
  ## and not in options I don't know
  if($opt->{meta} and ref($opt->{meta}) eq 'HASH') {
    $record = $opt->{meta};
    last METALOOK;
  }

  $mtab = $opt->{meta_table} || $::Variable->{UI_META_TABLE} || 'mv_metadata'
    or last METALOOK;
  my $meta = Vend::Data::database_exists_ref($mtab)
    or do {
      ::logError("non-existent meta table: %s", $mtab);
      undef $mtab;
      last METALOOK;
    };

  my $view = $opt->{view} || $opt->{arbitrary};

  ## This is intended to trigger on the first access
  if($table eq $mtab and $column eq $meta->config('KEY')) {
    if($view and $opt->{value} !~ /::.+::/) {
      $base_entry_value = ($opt->{value} =~ /^([^:]+)::(\w+)$/)
                ? $1
                : $opt->{value};
    }
    else {
      $base_entry_value = $opt->{value} =~ /(\w+)::/
                ? $1
                : $opt->{value};
    }
  }

  my (@tries) = "${table}::$column";
  unshift @tries, "${table}::${column}::$key"
    if length($key) and $opt->{specific};

  my $sess = $Vend::Session->{mv_metadata} || {};

  push @tries, { type => $opt->{type} }
    if $opt->{type} || $opt->{label};

  for my $metakey (@tries) {
    ## In case we were passed a meta record
    last if $record = $sess->{$metakey} and ref $record;
    $record = meta_record($metakey, $view, $meta)
      and last;
  }
}

my $w;

METAMAKE: {
  last METAMAKE if $no_meta;
  if( ! $record ) {
    $record = { %$opt };
  }
  else {
    ## Here we allow override with the display tag, even with views and
    ## extended
    my @override = qw/
              append
              attribute
              db
              callback_prescript
              callback_postscript
              class
              default
              extra
              disabled
              field
              form
              form_name
              filter
              height
              help
              help_url
              id
              label
              js_check
              lookup
              lookup_exclude
              lookup_query
              maxlength
              name
              options
              outboard
              passed
              pre_filter
              prepend
              table
              type
              type_empty
              width
              /;
    for(@override) {
      delete $record->{$_} if ! length($record->{$_});
      next unless defined $opt->{$_};
      $record->{$_} = $opt->{$_};
    }
  }

  if($record->{type_empty} and length($opt->{value}) == 0) {
    $record->{type} = $record->{type_empty};
  }
  else {
    $record->{type} ||= $opt->{default_widget};
  }

  $record->{name} ||= $column;
#::logDebug("record now=" . ::uneval($record));

  if($record->{options} and $record->{options} =~ /^[\w:,]+$/) {
#::logDebug("checking options");
    PASS: {
      my $passed = $record->{options};

      if($passed eq 'tables') {
        my @tables = $Tag->list_databases();
        $record->{passed} = join (',', "=--none--", @tables);
      }
      elsif($passed =~ /^(?:filters|\s*codedef:+(\w+)(:+(\w+))?\s*)$/i) {
        my $tag = $1 || 'filters';
        my $mod = $3;
        $record->{passed} = Vend::Util::codedef_options($tag, $mod);
      }
      elsif($passed =~ /^columns(::(\w*))?\s*$/) {
        my $total = $1;
        my $tname = $2 || $record->{db} || $table;
        if ($total eq '::' and $base_entry_value) {
          $tname = $base_entry_value;
        }
        $record->{passed} = join ",",
                    "=--none--",
                    $Tag->db_columns($tname),
                  ;
      }
      elsif($passed =~ /^keys(::(\w+))?\s*$/) {
        my $tname = $2 || $record->{db} || $table;
        $record->{passed} = join ",",
                    "=--none--",
                    $Tag->list_keys($tname),
                  ;
      }
    }
  }

#::logDebug("checking for custom widget");
  if ($record->{type} =~ s/^custom\s+//s) {
    my $wid = lc $record->{type};
    $wid =~ tr/-/_/;
    $record->{attribute} ||= $column;
    $record->{table}     ||= $mtab;
    $record->{rows}      ||= $record->{height};
    $record->{cols}      ||= $record->{width};
    $record->{field}     ||= 'options';
    $record->{name}      ||= $column;
    eval {
      $w = $Tag->$wid($record->{name}, $opt->{value}, $record, $opt);
    };
    if($@) {
      ::logError("error using custom widget %s: %s", $wid, $@);
    }
    last METAMAKE;
  }

  $opt->{restrict_allow} ||= $record->{restrict_allow};
#::logDebug("formatting prepend/append/lookup_query name=$opt->{name} restrict_allow=$opt->{restrict_allow}");
  for(qw/append prepend lookup_query/) {
    next unless $record->{$_};
    if($opt->{restrict_allow}) {
      $record->{$_} = $Tag->restrict({
                log => 'none',
                enable => $opt->{restrict_allow},
                disable => $opt->{restrict_deny},
                body => $record->{$_},
              });
    }
    else {
      $record->{$_} = expand_values($record->{$_});
    }
    $record->{$_} = Vend::Util::resolve_links($record->{$_});
    $record->{$_} =~ s/_UI_VALUE_/$opt->{value}/g;
    $record->{$_} =~ /_UI_URL_VALUE_/
      and do {
        my $tmp = $opt->{value};
        $tmp =~ s/(\W)/sprintf '%%%02x', ord($1)/eg;
        $record->{$_} =~ s/_UI_URL_VALUE_/$tmp/g;
      };
    $record->{$_} =~ s/_UI_TABLE_/$table/g;
    $record->{$_} =~ s/_UI_COLUMN_/$column/g;
    $record->{$_} =~ s/_UI_KEY_/$key/g;
  }

  if($opt->{opts}) {
    my $r = get_option_hash(delete $opt->{opts});
    for my $k (keys %$r) {
      $record->{$k} = $r->{$k};
    }
  }


#::logDebug("overriding defaults");
#::logDebug("passed=$record->{passed}") if $record->{debug};
  my %things = (
    attribute  => $column,
    cols     => $opt->{cols}   || $record->{width},
    passed     => $record->{options},
    rows     => $opt->{rows}  || $record->{height},
    value    => $opt->{value},
    applylocale => $opt->{applylocale},
  );

  while( my ($k, $v) = each %things) {
    next if length $record->{$k};
    next unless defined $v;
    $record->{$k} = $v;
  }

#::logDebug("calling Vend::Form with record=" . ::uneval($record));
  if($record->{save_defaults}) {
    my $sd = $Vend::Session->{meta_defaults} ||= {};
    $sd = $sd->{"${table}::$column"} ||= {}; 
    while (my ($k,$v) = each %$record) {
      next if ref($v) eq 'CODE';
      $sd->{$k} = $v;
    }
  }

  $w = Vend::Form::display($record);
  if($record->{filter}) {
    $w .= qq{<input type="hidden" name="ui_filter:$record->{name}" value="};
    $w .= $record->{filter};
    $w .= '">';
  }
}

if(! defined $w) {
  my $text = $opt->{value};
  my $iname = $opt->{name} || $column;

  # Count lines for textarea
  my $count;
  $count = $text =~ s/(\r\n|\r|\n)/$1/g;

  HTML::Entities::encode($text, $ESCAPE_CHARS::std);
  my $size;
  if ($count) {
    $count++;
    $count = 20 if $count > 20;
    $w = <<EOF;
<textarea name="$iname" cols="60" rows="$count">$text</textarea>
EOF
  }
  elsif ($text =~ /^\d+$/) {
    my $cur = length($text);
    $size = $cur > 8 ? $cur + 1 : 8;
  }
  else {
    $size = 60;
  }
    $w = <<EOF;
<input name="$iname" size="$size" value="$text">
EOF
}

my $array_return = wantarray;

#::logDebug("widget=$w");

# don't output label if widget is hidden form variable only
# and not an array type
undef $template if $w =~ /^\s*<input\s[^>]*type\s*=\W*hidden\b[^>]*>\s*$/i;

return $w unless $template || $opt->{return_hash} || $array_return;

if($template and $template !~ /\s/) {
  $template = <<EOF;
<tr>
<td>
<b>\$LABEL\$</b>
</td>
<td valign="top">
<table cellspacing="0" cellmargin="0"><tr><td>\$WIDGET\$</td><td>\$HELP\${HELP_URL} \
<br$Vend::Xtrailer><a href="\$HELP_URL\$">help</a>{/HELP_URL}</td></tr></table>
</td>
</tr>
EOF
}

$record->{label} ||= $column;

my %sub = (
  WIDGET    => $w,
  HELP    => $opt->{applylocale}
          ? errmsg($record->{help})
          : $record->{help},
      META_URL    => $opt->{meta_url},
  HELP_URL  => $record->{help_url},
  LABEL    => $opt->{applylocale}
          ? errmsg($record->{label})
          : $record->{label},
);
#::logDebug("passed meta_url=$opt->{meta_url}");
    $sub{HELP_EITHER} = $sub{HELP} || $sub{HELP_URL};

if($opt->{return_hash}) {
  $sub{OPT} = $opt;
  $sub{RECORD} = $record;
  return \%sub;
}
elsif($array_return) {
  return ($w, $sub{LABEL}, $sub{HELP}, $record->{help_url});
}
else {
  # Strip the {TAG} {/TAG} pairs if nothing there
  $template =~ s#{([A-Z_]+)}(.*?){/\1}#$sub{$1} ? $2: '' #ges;
  # Insert the TAG
            $sub{HELP_URL} ||= 'javascript:void(0)';
  $template =~ s/\$([A-Z_]+)\$/$sub{$1}/g;
#::logDebug("substituted template is: $template");
  return $template;
}
}

SEE ALSO


Name

div-organize

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

div-organize is available in Interchange versions:

5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: dist/strap/config/div_organize.tag
Lines: 339


UserTag div-organize Order         cols
UserTag div-organize attrAlias     columns cols
UserTag div-organize Interpolate
UserTag div-organize addAttr
UserTag div-organize hasEndTag
UserTag div-organize Documentation <<EOD

=head1 div-organize

[div-organize <options>]
  [loop ....] <div> [loop-tags] </div> [/loop]
[/div-organize]

Takes an unorganized set of div cells and organizes them into
rows based on the number of columns; it will also break them into
separate divs.
All of this assumes using bootstrap 3 and higher classes of: "row" for rows, 
and "col-xx-6" for two col for example, "col-xx-4" for 3 column combined with
option of cols=3.

If the number of cells are not on an even modulus of the number of columns,
then "filler" cells are pushed on.

Parameters:

=over 4

=item cols (or columns)

Number of columns. This argument defaults to 2 if not present.

=item rows

Optional number of rows. Implies "table" parameter.

=item table

If present, will cause a surrounding <div> </div> pair with the attributes
specified in this option. ie for bootstrap you might use table="class='container'"

=item caption

Table <CAPTION> container text, if any. Can be an array.

=item div

Attributes for div table cells. Can be an array. ie could be col-md-6 if using 2 col

=item row_attr

Attributes for div table rows. Can be an array. typically would be class="row"

=item columnize

Will display cells in (newspaper) column order, i.e. rotated.

=item pretty

Adds newline and tab characters to provide some reasonable indenting.

=item filler

Contents to place in empty cells put on as filler. Defaults to C<&nbsp;>.

=item filler_class

Class to place in empty cells put on as filler. Defaults to C<filler_class>.
With bootstrap you may want this to be the same as target divs to keep columns straight ie 
col-md-6 for 2 col display

=item min_rows

On small result sets, can be ugly to build more than necessary columns.
This will guarantee a minimum number of rows -- columns will change
as numbers change. Formula: $num_cells % $opt->{min_rows}.

=item limit

Maximum number of cells to use. Truncates extra cells silently.

=item embed

If you want to embed other divs inside, make sure they are called with
lower case <div> elements, then set the embed tag and make the cells you wish
to organize be <DIV> elements. To switch that sense, and make the upper-case
or mixed case be the ignored cells, set the embed parameter to C<lc>.

  [div-organize embed=lc]
  <div>
    <TABLE>
      <TR>
      <TD> something 
        <DIV> something </DIV>
      </TD>
      </TR>
    </table>
  </div>
  [/div-organize]

or

  [div-organize embed=uc]
  <DIV>
    <div>
      something
    </div>
  </DIV>
[/div-organize]

=back

Need to experiment with this stuff, for div only.
Also note, we should update current table organize with Bootstrap
class considerations

The C<row_attr>, C<td>, and C<caption> attributes can be specified with indexes;
if they are, then they will alternate according to the modulus.

The C<td> option array size should probably always equal the number of columns;
if it is bigger, then trailing elements are ignored. If it is smaller, no attribute
is used.

For example, to produce a table that 1) alternates rows with background
colors C<#EEEEEE> and C<#FFFFFF>, and 2) aligns the columns RIGHT CENTER
LEFT, do:

      [div-organize
          cols=3
          pretty=1
    filler_class='col-md-4'
          ]
          [loop list="1 2 3 1a 2a 3a 1b"] <div class="col-md-4"> [loop-code] </div> [/loop]
      [/div-organize]

which will produce:

      <div class="row">
              <div class="col-md-4">1</div>
              <div class="col-md-4">2</div>
              <div class="col-md-4">3</div>
      </div>
      <div class="row">
              <div class="col-md-4">1a</div>
              <div class="col-md-4">2a</div>
              <div class="col-md-4">3a</div>
      </div>
      <div class="row">
              <div class="col-md-4">1b</div>
              <div class="col-md-4">&nbsp;</div>
              <div class="col-md-4">&nbsp;</div>
      </div>

If the attribute columnize=1 is present, the result will look like:

      <div class="row">
              <div class="col-md-4">1</div>
              <div class="col-md-4">1a</div>
              <div class="col-md-4">1b</div>
      </div>
      <div class="row">
              <div class="col-md-4">2</div>
              <div class="col-md-4">2a</div>
              <div class="col-md-4">&nbsp;</div>
      </div>
      <div class="row">
              <div class="col-md-4">3</div>
              <div class="col-md-4">3a</div>
              <div class="col-md-4">&nbsp;</div>
      </div>

See the source for more ideas on how to extend this tag.

=cut

EOD
UserTag div-organize Routine <<EOR
sub {
my ($cols, $opt, $body) = @_;
$cols = int($cols) || 2;
$body =~ s/(.*?)(<div)\b/$2/is
  or return;
my $out = $1;
$body =~ s:(</div>)(?!.*</div>)(.*):$1:is;
my $postamble = $2;

my @cells;
if($opt->{cells} and ref($opt->{cells}) eq 'ARRAY') {
  @cells = @{$opt->{cells}};
}
elsif($opt->{embed}) {
  if($opt->{embed} eq 'lc') {
    push @cells, $1 while $body =~ s:(<div\b.*?</div>)::s;
  }
  else {
    push @cells, $1 while $body =~ s:(<DIV\b.*?</DIV>)::s;
  }
}
else {
  push @cells, $1 while $body =~ s:(<div\b.*?</div>)::is;
}

while ($opt->{min_rows} and ($opt->{min_rows} * ($cols - 1)) > scalar(@cells) ) {
  $cols--;
  last if $cols == 1;
}

if(int($opt->{limit}) and $opt->{limit} < scalar(@cells) ) {
  splice(@cells, $opt->{limit});
}

for(qw/ table/) {
  $opt->{$_} = defined $opt->{$_} ? " $opt->{$_}" : '';
}

##Left off here
my @div;

if(! $opt->{div}) {
  @div = '' x $cols;
}
elsif (ref $opt->{div} ) {
  @div = @{$opt->{div}};
  push @div, '' while scalar(@div) < $cols;
}
else {
  @div = (" $opt->{div}") x $cols;
}

##Have not touched

my %attr;
for(qw/caption row_attr pre post/) {
  if( ! $opt->{$_} ) {
    #do nothing
  }
  elsif (ref $opt->{$_}) {
    $attr{$_} = $opt->{$_};
  }
  else {
    $attr{$_} = [$opt->{$_}];
  }
}
##Have not touched

my $pretty = $opt->{pretty};

my @rest;
my $rows;

my $rmod;
my $tmod = 0;
my $total_mod;

$opt->{filler} = '&nbsp;' if ! defined $opt->{filler};

my $td_beg;
my $td_end;

if($rows = int($opt->{rows}) ) {
  $total_mod = $rows * $cols;
  @rest = splice(@cells, $total_mod)
    if $total_mod < @cells;
  $opt->{table} = ' ' if ! $opt->{table};
}

my $joiner = $opt->{joiner} || ($pretty ? "\n\t\t" : "");
while(@cells) {
  if ($opt->{columnize}) {
    my $cell_count = scalar @cells;
    my $row_count_ceil = POSIX::ceil($cell_count / $cols);
    my $row_count_floor = int($cell_count / $cols);
    my $remainder = $cell_count % $cols;
    my @tmp = splice(@cells, 0);
    my $index;
    for (my $r = 0; $r < $row_count_ceil; $r++) {
      for (my $c = 0; $c < $cols; $c++) {
        if ($c >= $remainder + 1) {
          $index = $r + $row_count_floor * $c + $remainder;
        }
        else {
          $index = $r + $row_count_ceil * $c;
        }
        push @cells, $tmp[$index];
        last if $r + 1 == $row_count_ceil and $c + 1 == $remainder;
      }
    }
  }

  my $fclass = $opt->{filler_class} || 'filler_class';
  while (scalar(@cells) % $cols) {
    push @cells, qq|<div class="$fclass">$opt->{filler}</div>|;
  }

  #$out .= "<!-- starting table tmod=$tmod -->";
  if($opt->{table}) {
    $out .= "<div$opt->{table}>";
    $out .= "\n" if $pretty;
  }
  $rmod = 0;
  while(@cells) {
    $out .= "\t" if $pretty;
    $out .= qq{<div};
    if($opt->{row_attr}) {
      my $idx = $rmod % scalar(@{$attr{row_attr}});
      $out .= " " . $attr{row_attr}[$idx];
    }
    else {
      $out .= ' class="row"';
    }
    $out .= ">";
    $out .= "\n\t\t" if $pretty;
    my @op =  splice (@cells, 0, $cols);
    if($opt->{div}) {
      for ( my $i = 0; $i < $cols; $i++) {
        $op[$i] =~ s/(<div)/$1 $div[$i]/i;
      }
    }
    @op = map { s/>/>$td_beg/; $_ }       @op  if $td_beg;
    @op = map { s/(<[^<]+)$/$td_end$1/; $_ } @op  if $td_end;

    $out .= join($joiner, @op);
    $out .= "\n\t" if $pretty;
    $out .= "</div>";
    $out .= "\n" if $pretty;
    $rmod++;
  }
  if($opt->{table}) {
    $out .= "</div>";
    $out .= "\n" if $pretty;
  }
  if(@rest) {
    my $num = $total_mod < scalar(@rest) ? $total_mod : scalar(@rest);
    @cells = splice(@rest, 0, $num);
  }
  $tmod++;
}
return $out . $postamble;
}
EOR

SEE ALSO


Name

dump — display dump of current session

ATTRIBUTES

AttributePos.Req.DefaultDescription
key Yes None (all keys) Display a specific subset of the session.
no_env  0Exclude HTTP environment variables.
no_cgi  0Exclude CGI variables.
show_all  0Show all CGI variables, including the "hidden" ones defined in @Global::HideCGI?
no_session  0Do not output session structure?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag dumps the complete session or parts of it, and HTTP environment variables in a human readable format, which is useful for debugging.

To display only a subset from the user's session, use parameter key=. The key can be any information from the user's session, but most often you will want to display carts, scratch or values. For a list of all possible keys, smply invoke [dump] and look under "SESSION".

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Displaying current user's full session dump

<pre>[dump]</pre>

Example: Displaying current user's cart structure

<pre>[dump key=carts]</pre>

Example: Session dump focusing on session values, without HTTP environment

<pre>[dump show_all=1 no_env=1]</pre>

NOTES

AVAILABILITY

dump is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/dump.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: dump.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag dump                Order        key
UserTag dump                addAttr
UserTag dump                PosNumber    1
UserTag dump                Version      $Revision: 1.5 $
UserTag dump                MapRoutine   ::full_dump


Name

dump_session — dump named user session partially or in whole

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes User session ID.
joiner A space
find
key Hash key to use as top-level value in session dump, instead of the complete session.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag dumps content of a named session.

If the key= argument is specified, that will become the top-level element for display.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: ACTIVE_SESSION_MINUTES

EXAMPLES

Example: Displaying current user's session dump

<pre> [dump-session name="[data session id]"] </pre>

Example: Displaying a specific part of current user's session

<pre> [dump-session name="[data session id]" key=browser] </pre>

NOTES

AVAILABILITY

dump_session is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/dump_session.coretag
Lines: 134


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: dump_session.coretag,v 1.8 2007-03-30 23:40:54 pajamian Exp $

UserTag dump_session Order    name
UserTag dump_session AddAttr
UserTag dump_session Version  $Revision: 1.8 $
UserTag dump_session Routine  <<EOR
sub show_part {
my ($ref, $key) = @_;
return $ref unless $key;
if ($key eq 'SCALAR') {
  my $newref = {};
  foreach my $k (keys %$ref) {
    next if ref $ref->{$k};
    $newref->{$k} = $ref->{$k};
  }
  return $newref;
}
else {
  return { $key, $ref->{$key} };
}
}

sub {
my ($name, $opt) = @_;
my $joiner = $opt->{joiner} || ' ';
return "Cannot dump or find sessions with session type $Vend::Cfg->{SessionType}."
if ($Vend::Cfg->{SessionType} ne 'File' && $Vend::Cfg->{SessionType} ne 'DBI');


if ($Vend::Cfg->{SessionType} eq 'File') {
if($opt->{find}) {
require File::Find;
my $expire = $Vend::Cfg->{SessionExpire};
if( int($::Variable->{ACTIVE_SESSION_MINUTES}) ) {
  $expire = $::Variable->{ACTIVE_SESSION_MINUTES} * 60;
}
my $now = time();
$expire = $now - $expire;
  my @files;
    my $wanted = sub {
      return unless -f $_;
      return if (stat(_))[9] < $expire;
      return if /\.lock$/;
      push @files, $_;
    };
    File::Find::find($wanted, $Vend::Cfg->{SessionDatabase});
    return join $joiner, @files;
  }
  elsif (! $name) {
    return "dump-session: Nothing to do.";
  }
  else {
    my $fn = Vend::Util::get_filename($name, 2, 1, $Vend::Cfg->{SessionDatabase});
    return '' unless -f $fn;
    my $ref = Vend::Util::eval_file($fn);

    $ref = show_part($ref, $opt->{key}) if $opt->{key};

    my $out = '';
    eval { 
    $out = Vend::Util::uneval($ref);
};
return uneval($ref) if $@;
return $out;
}
}

if ($Vend::Cfg->{SessionType} eq 'DBI') {
if($opt->{find}) {
my $expire = $Vend::Cfg->{SessionExpire};
if( int($::Variable->{ACTIVE_SESSION_MINUTES}) ) {
  $expire = $::Variable->{ACTIVE_SESSION_MINUTES} * 60;
}
my $now = time();
$expire = $now - $expire;
  my @sesscodes;

    my $db  = Vend::Data::database_exists_ref($Vend::Cfg->{SessionDB}) 
      or return errmsg("Table %s is not available", $Vend::Cfg->{SessionDB});
    my $dbh = $db->dbh();
    my $tname = $db->name();
    my $sql = "select code from $tname where UNIX_TIMESTAMP(last_accessed) >= ?";

    my $sth = $dbh->prepare($sql);
    $sth->execute($expire) || return $DBI::errstr;
    my $code;
    $sth->bind_columns( undef, \$code);

    while($sth->fetch) {
      push @sesscodes, $code;
    }  
    $sth->finish;
    return join $joiner, @sesscodes;
  }
  elsif (! $name) {
    return "dump-session: Nothing to do.";
  }
  else {
    my $db  = Vend::Data::database_exists_ref($Vend::Cfg->{SessionDB}) 
      or return errmsg("Table %s is not available", $Vend::Cfg->{SessionDB});
    my $dbh = $db->dbh();
    my $tname = $db->name();
    my $sql = "select session from $tname where code=?";

    my $sth = $dbh->prepare($sql);
    $sth->execute($name);
    my $session;
    $sth->bind_columns( undef, \$session);
    $sth->fetch;
    $sth->finish;

    my $out = '';
    my $ref = Vend::Util::evalr($session);

    ## Allow show of only part
    $ref = show_part($ref, $opt->{key}) if $opt->{key};

    eval { 
      $out = Vend::Util::uneval($ref);
    };
    return uneval($ref) if $@;
    return $out;
  }
}

}
EOR


Name

either

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

either is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/either.coretag
Lines: 27


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: either.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag either              hasEndTag
UserTag either              PosNumber    0
UserTag either              NoReparse    1
UserTag either              Version      $Revision: 1.6 $
UserTag either              Routine      <<EOR
sub {
my @ary = split /\[or\]/, shift;
my $result;

foreach (@ary) {
  $result = interpolate_html($_);
  $result =~ s/^\s+//;
  $result =~ s/\s+$//;
  return $result if $result;
}
return $result;
}
EOR

SEE ALSO


Name

email — send e-mail using SendMailProgram

ATTRIBUTES

AttributePos.Req.DefaultDescription
to YesYes E-mail address of the recipient.
subject Yes <no subject>Subject of the e-mail.
reply Yes  E-mail address for reply.
from Yes First address from the MailOrderTo configuration directive.E-mail address of the sender.
extra Yes NoneAdditional e-mail headers to include. For example, Errors-To: errors@mydomain.local.
cc    E-mail address for carbon copy.
bcc    E-mail address for blind carbon copy.
html    HTML part for the message
attach   File(s) to attach to the generated email.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag simply feeds SendMailProgram with the e-mail body that you provide.

You do not need to provide the headers yourself, because you can pass all relevant information using tag attributes. The to parameter must be supplied and contain a valid e-mail address, or the message surely won't be delivered.

Attaching Files

To add a single file as an attachment, you just do:

[email
    from=foo@bar.com
    to=bar@foo.com
    subject=test
    attach=foo.gif
] Here is the gif file I promised.  [/email]

It automatically picks up the MIME type, and handles many if you have the optional MIME::Types module installed.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: MV_UTF8
Global Variables: MV_UTF8

EXAMPLES

Example: Simple e-mail message

Put the following on a test page:

[email
  to="root@mydomain.local"
  subject="Greetings"
]
Hello, World!
[/email]

Example: HTML message

[email
   from=foo@bar.com
            to=bar@foo.com
            subject=test
            html="[scratch some_big_hairy_mess]"
            ]This is the plain text part.[/email]

NOTES

All outgoing e-mails can be intercepted for development purposes by setting MV_EMAIL_INTERCEPT.

AVAILABILITY

email is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/email.tag
Lines: 277


# Copyright 2002-2012 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag email Order to subject reply from extra
UserTag email hasEndTag
UserTag email addAttr
UserTag email Interpolate
UserTag email Routine <<EOR

my ($Have_mime_lite, $Have_encode);
BEGIN {
eval {
  require MIME::Lite;
  $Have_mime_lite = 1;
};
  unless ($ENV{MINIVEND_DISABLE_UTF8}) {
      $Have_encode = 1;
};
}

sub utf8_to_other {
my ($string, $encoding) = @_;
return $string unless $Have_encode; # nop if no Encode

unless(Encode::is_utf8($string)){
  $string = Encode::decode('utf-8', $string);
}
return Encode::encode($encoding, $string);
}

sub {
  my ($to, $subject, $reply, $from, $extra, $opt, $body) = @_;
  my $ok = 0;
  my ($cc, $bcc, @extra, $utf8);

use vars qw/ $Tag /;

  $subject = '<no subject>' unless defined $subject && $subject;

if (! $from) {
$from = $Vend::Cfg->{MailOrderTo};
$from =~ s/,.*//;
}

# Use local copy to avoid mangling with caller's data
$cc = $opt->{cc};
$bcc = $opt->{bcc};

# See if UTF-8 support is required
$utf8 = $::Variable->{MV_UTF8} || $Global::Variable->{MV_UTF8};

# Prevent header injections from spammers' hostile content
for ($to, $subject, $reply, $from, $cc, $bcc) {
# unfold valid RFC 2822 "2.2.3. Long Header Fields"
  s/\r?\n([ \t]+)/$1/g;
  # now remove any invalid extra lines left over
  s/[\r\n](.*)//s
    and ::logError("Header injection attempted in email tag: %s", $1);
}


for (grep /\S/, split /[\r\n]+/, $extra) {
  # require header conformance with RFC 2822 section 2.2
  push (@extra, $_), next if /^[\x21-\x39\x3b-\x7e]+:[\x00-\x09\x0b\x0c\x0e-\x7f]+$/;
  ::logError("Invalid header given to email tag: %s", $_);
}
unshift @extra, "From: $from" if $from;

# force utf8 email through MIME as attachment
unless (($opt->{attach} || $opt->{html}) && $utf8){
  $opt->{body_mime} = $opt->{mimetype};
  $body = utf8_to_other($body, 'utf-8');
}  

my $sent_with_attach = 0;

ATTACH: {
#::logDebug("Checking for attachment");
  last ATTACH unless $opt->{attach} || $opt->{html};

  unless ($Have_mime_lite) {
    ::logError("email tag: attachment without MIME::Lite installed.");
    last ATTACH;
  }

  my $att1_format;
  my $att = $opt->{attach};
  my @attach;
  my @extra_headers;

  # encode values if utf8 is supported
  if($utf8){
    $to = utf8_to_other($to, 'MIME-Header');
    $from = utf8_to_other($from, 'MIME-Header');
    $subject = utf8_to_other($subject, 'MIME-Header');
    $cc = utf8_to_other($cc, 'MIME-Header');
    $bcc = utf8_to_other($bcc, 'MIME-Header');
    $reply = utf8_to_other($reply, 'MIME-Header');
  }

      my %msg_args = (To => $to,
                      From => $from,
                      Subject => $subject,
                      Type => $opt->{mimetype},
                      Cc => $cc,
                      Bcc => $bcc,
                      'Reply-To' => $reply,
                         );


      if($opt->{html}) {
          if ($body =~ /\S/) {
              $msg_args{Type} ||= 'multipart/alternative';
          }
          else {
              $msg_args{Type} ||= 'text/html'  . ($utf8 ? '; charset=UTF-8' : '');
              $msg_args{Data} ||=  ($utf8 ? utf8_to_other($opt->{html}, 'utf-8') : $opt->{html});
          }

    $att1_format = 'flowed';
  }
  else {
    $msg_args{Type} ||= 'multipart/mixed';
  }

      my $msg = MIME::Lite->new(%msg_args);
      
  for(@extra) {
    m{(.*?):\s+(.*)};
    my $name = $1 or next;
    next if lc($name) eq 'from';
    my $content = $2 or next;
    $name =~ s/[-_]+/-/g;
    $name =~ s/\b(\w)/\U$1/g;
    $msg->add($name, ($utf8 ? utf8_to_other($content, 'UTF-8')
                : $content)) 
      if $name && $content;
  }

      if ($body =~ /\S/) {
          $opt->{body_mime} ||= 'text/plain' . ($utf8 ? '; charset=UTF-8' : '');
          $opt->{body_encoding} ||= 'quoted-printable';
          $msg->attach(
                       Type => $opt->{body_mime},
                       Encoding => $opt->{body_encoding},
                       Data => ($utf8 ? utf8_to_other($body, 'utf-8') : $body),
                       Disposition => $opt->{body_disposition} || 'inline',
                       Format => $opt->{body_format} || $att1_format,
                      );
      }

  if(! ref($att) ) {
    my $fn = $att;
    $att = [ { path => $fn } ];
  }
  elsif(ref($att) eq 'HASH') {
    $att = [ $att ];
  }
  elsif(ref($att) eq 'ARRAY') {
    # turn array of file names into array of hash references
    my $new_att = [];

    for (@$att) {
      if (ref($_)) {
        push (@$new_att, $_);
      }
      else {
        push (@$new_att, {path => $_});
      }
    }

    $att = $new_att;
  }

  $att ||= [];

  if($opt->{html} && $body =~ /\S/) {
    unshift @$att, {type => 'text/html' 
            .($utf8 ? '; charset=UTF-8': ''),
            data => ($utf8 ? utf8_to_other($opt->{html}, 'UTF-8') : $opt->{html}),
            disposition => 'inline',
            };
  }

  my %encoding_types = (
    'text/plain' => ($utf8 ? 'quoted-printable' : '8bit'),
    'text/html' => 'quoted-printable',
          'text/html; charset=UTF-8' => 'quoted-printable',
  );

  for my $ref (@$att) {
    next unless $ref;
    next unless $ref->{path} || $ref->{data};
    unless ($ref->{filename}) {
      my $fn = $ref->{path};
      $fn =~ s:.*[\\/]::;
      $ref->{filename} = $fn;
    }

    $ref->{type} ||= 'AUTO';
    $ref->{disposition} ||= 'attachment';

    if(! $ref->{encoding}) {
      $ref->{encoding} = $encoding_types{$ref->{type}};
    }
    eval {
      $msg->attach(
        Type => $ref->{type},
        Path => $ref->{path},
        ReadNow => 1,
        Data => $ref->{data},
        Filename => $ref->{filename},
        Encoding => $ref->{encoding},
        Disposition => $ref->{disposition},
      );
    };
    if($@) {
      ::logError("email tag: failed to attach %s: %s", $ref->{path}, $@);
      $Tag->error({name => 'email', 
        set => errmsg('Failed to attach %s', $ref->{path})});
      return;
    }
  }

  my $body = $msg->body_as_string;
  my $header = $msg->header_as_string;
#::logDebug("[email] Mail: \n$header\n$body");
  if($opt->{test}) {
    return "$header\n$body";
  }
  else {
    last ATTACH unless $header;
    my @head = split(/\r?\n/,$header);
    $ok = send_mail(\@head,$body);

    $sent_with_attach = 1;
  }
}

  $reply = '' unless defined $reply;
  $reply = "Reply-to: $reply\n" if $reply;

if ($cc) {
  push(@extra, "Cc: $cc");
}

if ($bcc) {
  push(@extra, "Bcc: $bcc");
}

if ($utf8 && ! $opt->{mimetype}) {
  push(@extra, 'MIME-Version: 1.0');
  push(@extra, 'Content-Type: text/plain; charset=UTF-8');
  push(@extra, 'Content-Transfer-Encoding: 8bit');
}

$ok = send_mail($to, $subject, $body, $reply, 0, @extra)
    unless $sent_with_attach;

  if (!$ok) {
      logError("Unable to send mail using $Vend::Cfg->{SendMailProgram}\n" .
          "To '$to'\n" .
          "From '$from'\n" .
          "With extra headers '$extra'\n" .
          "With reply-to '$reply'\n" .
          "With subject '$subject'\n" .
          "And body:\n$body");
  }

return $opt->{hide} ? '' : $ok;
}
EOR



Name

email-raw — send raw-formatted e-mail using SendMailProgram

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag simply feeds SendMailProgram with the raw-formatted e-mail data you provide.

This means you also need to provide all the e-mail headers. Header lines must be at the beginning of the line, and the header must have a valid To: field, or the message surely won't be delivered.

Also, as usual, there has to be one empty line between the last header line and beginning of e-mail body.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: MV_EMAIL_INTERCEPT
Global Variables: MV_EMAIL_INTERCEPT

EXAMPLES

Example: Simple raw e-mail message

Put the following on a test page:

[email-raw]
From: test@localhost
To: root@localhost
Subject: DEAR FRIEND

THROUGH THE COURTESY OF BUSINESS OPPORTUNITY, I TAKE LIBERTY ANCHORED ON A
STRONG DESIRE TO SOLICIT YOUR ASSISTANCE ON THIS MUTUALLY BENEFICIAL AND
RISKFREE TRANSACTION WHICH I HOPE YOU WILL GIVE YOUR URGENT ATTENTION.

I HAVE DEPOSITED THE SUM OF THIRTY MILLION,FIVE HUNDRED THOUSAND UNITED
STATES DOLLARS(US$30,500,000) WITH A SECURITY COMPANY FOR SAFEKEEPING.
THE FUNDS ARE SECURITY CODED TO PREVENT THEM FROM KNOWING THE ACTUAL
CONTENTS.

MAY I AT THIS POINT EMPHASIZE THE HIGH LEVEL OF CONFIDENTIALLITY WHICH THIS
BUSINESS DEMANDS AND HOPE YOU WILL NOT BETRAY THE TRUST AND CONFIDENCE WHICH
WE REPOSE IN YOU.
[/email-raw]

We hope you will recognize an attempt at humor in the example above, and won't use it as an idea for spamming activities.


NOTES

All outgoing e-mails can be intercepted for development purposes by setting MV_EMAIL_INTERCEPT.

AVAILABILITY

email-raw is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/email_raw.tag
Lines: 73


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: email_raw.tag,v 1.8 2007-03-30 23:40:56 pajamian Exp $

UserTag email-raw hasEndTag
UserTag email-raw addAttr
UserTag email-raw Interpolate
UserTag email-raw Version     $Revision: 1.8 $
UserTag email-raw Routine     <<EOR
sub {
my($opt, $body) = @_;
my($ok);
$body =~ s/^\s+//;

# If configured, intercept all outgoing email and re-route
if (
my $intercept = $::Variable->{MV_EMAIL_INTERCEPT}
              || $Global::Variable->{MV_EMAIL_INTERCEPT}
) {
$body =~ s/\A(.*?)\r?\n\r?\n//s;
my $header_block = $1;
# unfold valid RFC 2822 "2.2.3. Long Header Fields"
  $header_block =~ s/\r?\n([ \t]+)/$1/g;
  my @headers;
  for (split /\r?\n/, $header_block) {
    if (my ($header, $value) = /^(To|Cc|Bcc):\s*(.+)/si) {
      logError(
        "Intercepting outgoing email (%s: %s) and instead sending to '%s'",
        $header, $value, $intercept
      );
      $_ = "$header: $intercept";
      push @headers, "X-Intercepted-$header: $value";
    }
    push @headers, $_;
  }
  $body = join("\n", @headers) . "\n\n" . $body;
}

  SEND: {
my $using = $Vend::Cfg->{SendMailProgram};

if (lc $using eq 'none') {
  $ok = 1;
  last SEND;
} elsif (lc $using eq 'net::smtp') {
  $body =~ s/^(.+?)(?:\r?\n){2}//s;
  my $headers = $1;
  last SEND unless $headers;
  my @head = split(/\r?\n/,$headers);
  $ok = send_mail(\@head,$body);
} else {
  open(Vend::MAIL,"|$using -t") or last SEND;
  print Vend::MAIL $body
    or last SEND;
  close Vend::MAIL
    or last SEND;
  $ok = ($? == 0);
}
  }

  if (!$ok) {
      ::logError("Unable to send mail using $Vend::Cfg->{SendMailProgram}\n" .
          "Message follows:\n\n$body");
  }

  return $opt->{hide} ? '' : $ok;
}
EOR


Name

env — provides read-only access to the HTTP environment variables

ATTRIBUTES

AttributePos.Req.DefaultDescription
arg | name Yes  Name of the environment variable to display, if any.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The env tag provides read-only access to the HTTP environment variables. It can both display a specific variable as-is, or produce a complete list of variables and values in a simple HTML table.

List display is useful for simple debugging or diagnostics.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Display the client connection and browser information

The client's remote address and port are kept in REMOTE_ADDR and REMOTE_PORT variables. User's browser ID string is kept in HTTP_USER_AGENT.

Client connection: [env REMOTE_ADDR]:[env name="REMOTE_PORT"]<br/>
Client browser: [env arg="HTTP_USER_AGENT"]

Example: Display the simple HTML table with the complete HTTP environment

HTTP environment: <br/>
[env]

NOTES

AVAILABILITY

env is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/env.tag
Lines: 33


# Copyright 2004-2007 Interchange Development Group and others
# Copyright 2001 Ed LaFrance <edl@newmediaems.com>
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: env.tag,v 1.11 2007-03-30 23:40:57 pajamian Exp $

Usertag env Order      arg
Usertag env PosNumber  1
UserTag env attrAlias  name arg
UserTag env Version    $Revision: 1.11 $
Usertag env Routine    <<EOR
sub {
my $arg = shift;
my $env = ::http()->{env};
my $out;
if (! $arg) {
  $out = "<table cellpadding='2' cellspacing='1' border='1'>\n";
  foreach ((keys %$env)) {
    $out .= "<tr><td><b>$_</b></td><td>";
    $out .= "$env->{$_}</td>\n</tr><tr>\n";
  }
  $out .= "</table>\n";
}
else {
  $out = $env->{$arg};
}
return $out;
}
EOR

AUTHORS

Ed LaFrance, Interchange Development Group


Name

error — display and manipulate errors stored in session

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes default Name of the error, usually corresponds to the name of a input field in which the error ocurred.
overwrite No Overwrite existing error messages for the specified name? If this option is unset, the new error text will be appended with the word " AND ".
set Error text to set.
keep Yes Preserve the error after display? (The error is otherwise automatically deleted as soon as you retrieve its value.)
auto
all Yes if auto is enabled Display all error messages instead of just one pointed to by name?
show_error Yes if auto is enabled Show actual error messages instead of just reporting their count?
std_label
show_var Yes if auto is enabled Include error name in the display?
joiner <li> if auto is enabled, a newline (\n) otherwise Join element to use if multiple errors are to be displayed at once, such as when all is enabled.
text Optional string in which the actual error message should be embedded. If the literal %s is present in the string, it will be substituted for the message. Otherwise the error text is just appended.
header
footer
list_container ul Default list container HTML tag (applicable only if auto is enabled).
class None CSS class name (applicable only if auto is enabled).
style None CSS style value (applicable only if auto is enabled).
extra None Extra HTML attributes (applicable only if auto is enabled).
show_label No
filter
required No Used for display purposes, as a hint to std_label. Enabling this attribute allows the label to be printed differently for required form fields. In the default label template, this means bold text, but in your custom labels the behavior is, of course, arbitrary.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The error tag was designed to report meaningful error messages to the users, should an error occur in the processing action (such as missing or invalid field values entered).

It can work in conjunction with the definitions set in a profile, and can generate error messages in any format you desire.

Error conditions can also be tested with the [if] conditional:

[if errors fname]
Please enter your first name!
[/if]

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: MV_ERROR_STD_LABEL, CSS_CONTRAST

EXAMPLES

Example: Automatic error display

The following will simply display all accumulated session errors. (Note that after display, session errors will be cleared and will not show up on subsequent page accesses).

<ul>
[error auto=1]
</ul>

Example: Trigger an error

[error name="email" set="Invalid email address"]

Example: Show all errors

[error all=1 show_error=1]

Example: Clear all errors

[tmp clear_errors][error all=1 comment="Clear errors"][/tmp]

NOTES

AVAILABILITY

error is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/error.coretag
Lines: 162


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: error.coretag,v 1.11 2009-02-10 12:16:49 thunder Exp $

### This is in package Vend::Interpolate, and may make reference
### to variables in that module
UserTag error               Order        name
UserTag error               addAttr
UserTag error               PosNumber    1
UserTag error               Version      $Revision: 1.11 $
UserTag error               Routine      <<EOR
sub set_error {
my ($error, $var, $opt) = @_;
$var = 'default' unless $var;
$opt = { keep => 1 } if ! $opt;
my $ref = $Vend::Session->{errors};
if($ref->{$var} and ! $opt->{overwrite}) {
  $ref->{$var} .= errmsg(" AND ");
}
else {
  $ref->{$var} = '';
}

$ref->{$var} .= $error;
return tag_error($var, $opt);
}

sub tag_error {
my($var, $opt) = @_;
$Vend::Session->{errors} = {}
  unless defined $Vend::Session->{errors};
if($opt->{set}) {
  $opt->{keep} = 1 unless defined $opt->{keep};
  my $error = delete $opt->{set};
  if($opt->{param}) {
    $opt->{param} = [ $opt->{param} ] unless ref($opt->{param}) eq 'ARRAY';
    $error = sprintf($error, @{$opt->{param}});
  }
  return set_error($error, $var, $opt);
}
unless(defined $opt->{filter}) {
  $opt->{filter} = 'encode_entities';
}
my $err_ref = $Vend::Session->{errors};
my $text;
my @errors;
my $found_error = '';

if($opt->{auto}) {
  $opt->{all} = 1;
  $opt->{show_error} = 1;
  $opt->{std_label} = 0;
  $opt->{show_var} = 1
    unless defined $opt->{show_var};
  $opt->{joiner} = '<li>'
    unless length $opt->{joiner};
  $opt->{text} ||= '%s';
  $opt->{list_container} ||= 'ul';
  my $out = '';
  $out .= "<$opt->{list_container}";
  for(qw/ class style extra /) {
    next unless $opt->{$_};
    if($_ eq 'extra') {
      $out .= ' ' . $opt->{$_};
    }
    else {
      $out .= ' ' . qq{$_="$opt->{$_}"};
    }
  }
  $out .= '>';
  $out .= $opt->{joiner};
  $opt->{header} ||= $out;
  $opt->{footer} ||= "</$opt->{list_container}>";
}

$text = $opt->{text} if $opt->{text};

#::logDebug("tag_error: var=$var text=$text opt=" . ::uneval($opt));
#::logDebug("tag_error: var=$var text=$text");
if($opt->{all}) {
  $opt->{joiner} = "\n" unless defined $opt->{joiner};
  for(sort keys %$err_ref) {
    my $err = $err_ref->{$_};
    delete $err_ref->{$_} unless $opt->{keep};
    next unless $err;
    $found_error++;
    my $string = '';
    if ($opt->{show_label}) {
      if ($string = $Vend::Session->{errorlabels}{$_}) {
        $string =~ s/[:\s]+$//;
        $string .= " ($_)" if $opt->{show_var};
        $string .= ": ";
      } else {
        # Use the variable name unless Locale has a default label.
        my $label = errmsg("error_label_${_}");
        $label = $_ if $label eq "error_label_${_}";
        $string .= "($label): ";
      }
    } else {
      $string .= "$_: " if $opt->{show_var};
    }
    $string .= $err;
    push @errors, $string;
  }
#::logDebug("error all=1 found=$found_error contents='@errors'");
  return $found_error unless $text || $opt->{show_error};
  $text .= "%s" if $text !~ /\%s/;
  $text = pull_else($text, $found_error);

  return '' unless @errors;
  @errors = map { filter_value($opt->{filter}, $_) } @errors
    if $opt->{filter};
  my $etext = sprintf $text, join($opt->{joiner}, @errors);
  return join "", $opt->{header}, $etext, $opt->{footer};
}
$found_error = ! (not $err_ref->{$var});
my $err = $err_ref->{$var} || '';
delete $err_ref->{$var} unless $opt->{keep};
#::logDebug("error found=$found_error contents='$err'");
return !(not $found_error)
unless $opt->{std_label} || $text || $opt->{show_error};
$err = filter_value($opt->{filter}, $err)
if $opt->{filter};
if($opt->{std_label}) {
# store the error label in user's session for later
# possible use in [error show_label=1] calls
$Vend::Session->{errorlabels}{$var} = $opt->{std_label};
if($text) {
# do nothing
}
elsif(defined $::Variable->{MV_ERROR_STD_LABEL}) {
$text = $::Variable->{MV_ERROR_STD_LABEL};
}
else {
my $contrast = $::Variable->{CSS_CONTRAST} || 'mv_contrast';
$text = <<EOF;
<span class="$contrast">{LABEL} <small><i>(%s)</i></small></span>
[else]{REQUIRED <b>}{LABEL}{REQUIRED </b>}[/else]
EOF
}
$text =~ s/{LABEL}/$opt->{std_label}/g;
$text =~ s/{REQUIRED\s+([^}]*)}/$opt->{required} ? $1 : ''/ge;
$err =~ s/\s+$//;
}
$text = '' unless defined $text;
$text .= '%s' unless ($text =~ /\%s/ ||
                            length $::Variable->{MV_ERROR_STD_LABEL});

$text = pull_else($text, $found_error);
$text =~ s/\%s/$err/;
return $text;
}

sub {
return tag_error(@_);
}
EOR


Name

evalue — return encoded content of the named form input field

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

evalue behaves exactly the same as value, except that it automatically encodes entities found in the value.

For all other information, please see tag value.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: displaying user's first name

Hello, [evalue fname]!

NOTES

AVAILABILITY

evalue is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/value.coretag
Lines: 15


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: value.coretag,v 1.7 2008-07-04 15:52:35 mheins Exp $

UserTag value               Order        name
UserTag value               addAttr
UserTag value               PosNumber    1
UserTag value               Version      $Revision: 1.7 $
UserTag value               MapRoutine   Vend::Interpolate::tag_value
UserTag evalue              Alias        value keep=1 filter="encode_entities" name=


Name

export — export a database to a text file

ATTRIBUTES

AttributePos.Req.DefaultDescription
table | database | base Yes Yes Table name to export
field The column to add or delete
file Filename to export to. Note that NoAbsolute directive and other conditions may affect the range of possible locations
force false Force database export, even if NoExportExternal or NoExport is enabled?
sort Sorting option in format of sort_field:sort_option.
type Output format
delete Instead of adding, delete column specified by the field attribute? (In effect only if verify attribute is enabled)
verify
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag exports named database to a text file.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

export is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/export.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: export.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag export              Order        table
UserTag export              addAttr
UserTag export              attrAlias    base table
UserTag export              attrAlias    database table
UserTag export              PosNumber    1
UserTag export              Version      $Revision: 1.5 $
UserTag export              MapRoutine   Vend::Interpolate::export

Source: lib/Vend/Interpolate.pm
Lines: 1904

sub export {
my ($table, $opt, $text) = @_;
if($opt->{delete}) {
  undef $opt->{delete} unless $opt->{verify};
}
#::logDebug("exporting " . join (",", @{$opt}{ qw/table file type field delete/ }));
my $status = Vend::Data::export_database(
    @{$opt}{ qw/table file type/ }, $opt,
  );
return $status unless $opt->{hide};
return '';
}

Source: lib/Vend/Interpolate.pm
Lines: 1891

sub tag_export {
my ($args, $opt, $text) = @_;
$opt->{base} = $opt->{table} || $opt->{database} || undef
  unless defined $opt->{base};
unless (defined $opt->{base}) {
  @{$opt}{ qw/base file type/ } = split /\s+/, $args;
}
if($opt->{delete}) {
  undef $opt->{delete} unless $opt->{verify};
}
#::logDebug("exporting " . join (",", @{$opt}{ qw/base file type field delete/ }));
my $status = Vend::Data::export_database(
    @{$opt}{ qw/base file type/ }, $opt,
  );
return $status unless $opt->{hide};
return '';
}

SEE ALSO

import(7ic)


Name

export-database

ATTRIBUTES

AttributePos.Req.DefaultDescription
table Yes
file Yes
type Yes
delete
verify
field
sort
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

export-database is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/export_database.coretag
Lines: 46


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: export_database.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag export-database Order    table file type
UserTag export-database addAttr
UserTag export-database Version  $Revision: 1.4 $
UserTag export-database Routine  <<EOR
sub {
my($table, $file, $type, $opt) = @_;
delete $::Values->{ui_export_database}
  or return undef;
if($opt->{delete} and ! $opt->{verify}) {
  ::logError("attempt to delete field without verify, abort");
  return undef;
}

if(!$file and $type) {
  #::logError("exporting as default type, no file specified");
  undef $type;
}

$Vend::WriteDatabase{$table} = 1;

if(! $opt->{field}) {
  #::logError("exporting:\ntable=$table\nfile=$file\ntype=$type\nsort=$opt->{sort}");
}
elsif($opt->{field} and $opt->{delete}) {
  ::logError("delete field:\ntable=$table\nfield=$opt->{field}\nsort=$opt->{sort}\n");
}
elsif($opt->{field}) {
  ::logError("add field:\ntable=$table\nfield=$opt->{field}\nsort=$opt->{sort}\n");
}
return Vend::Data::export_database(
              $table,
              $file,
              $type,
              $opt,
          );
}
EOR

SEE ALSO


Name

fcounter

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes Counter file to use. Taken relatively to CATROOT unless absolute pathname is specified.
start
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

fcounter is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/counter.coretag
Lines: 17


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: counter.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag counter             Order        file
UserTag counter             addAttr
UserTag counter             attrAlias    name file
UserTag counter             PosNumber    1
UserTag counter             Version      $Revision: 1.6 $
UserTag counter             MapRoutine   Vend::Interpolate::tag_counter

UserTag fcounter            Alias        counter

SEE ALSO


Name

field — quickly retrieve field from Products database

ATTRIBUTES

AttributePos.Req.DefaultDescription
name | column | col | field Yes Yes
code | row Yes Yes
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag conveniently retrieves the field from the databases listed under ProductFiles. It will return the first entry found in the series of product databases, so if you are only looking for a specific table, better use the generic data tag.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

If you only have one ProductFiles database — products, then [field column key] is, of course, the same as [data products column key].

AVAILABILITY

field is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/field.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: field.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag field               Order        name code
UserTag field               attrAlias    column name
UserTag field               attrAlias    col name
UserTag field               attrAlias    row code
UserTag field               attrAlias    field name
UserTag field               attrAlias    key code
UserTag field               PosNumber    2
UserTag field               Version      $Revision: 1.4 $
UserTag field               MapRoutine   Vend::Data::product_field

Source: lib/Vend/Data.pm
Lines: 370

sub product_field {
  my ($field_name, $code, $base) = @_;
#::logDebug("product_field: name=$field_name code=$code base=$base");
return database_field($Vend::OnlyProducts, $code, $field_name)
  if $Vend::OnlyProducts;
#::logDebug("product_field: onlyproducts=$Vend::OnlyProducts");
my ($db);
  $db = product_code_exists_ref($code, $base || undef)
  or return '';
#::logDebug("product_field: exists db=$db");
  return "" unless defined $db->test_column($field_name);
  return $db->field($code, $field_name);
}


Name

file — include file into the current page verbatim

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Filename to include. Can't be arbitrary file if NoAbsolute is set.
type Yes File type: unix, mac or [dos|windows].
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag inserts the contents of the named file, which is searched relative to the catalog root directory or any directories specified by the TemplateDir directive.

The file should normally be relative to the catalog directory. File names beginning with / or .. are not allowed if the Interchange server administrator has enabled NoAbsolute.

File contents are inserted verbatim and not reparsed for tags.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Simple file include

[file /tmp/test]
<hr>
[file name=/tmp/test interpolate=1]

Our /tmp/test file could look like this:

Time is [time].

In the first line of the example, [time] will not be expanded to the actual time. In the third line it will, thanks to interpolate=1.


NOTES

To reparse file contents upon inclusion, use include or [file name=NAME interpolate=1].

AVAILABILITY

file is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/file.coretag
Lines: 37


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: file.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag file                Order        name type
UserTag file                PosNumber    2
UserTag file                Version      $Revision: 1.6 $
UserTag file                Routine      <<EOR
sub {
my ($file, $type) = @_;
  return readfile($file)
  unless $type;
return readfile($file, undef, 0)
  if $type eq 'raw';
my $text = readfile($file);
if($type =~ /mac/i) {
  $text =~ tr/\n/\r/;
}
elsif($type =~ /dos|window/i) {
  $text =~ s/\n/\r\n/g;
}
elsif($type =~ /unix/i) {
  if($text=~ /\n/) {
    $text =~ tr/\r/\n/;
  }
  else {
    $text =~ s/\r\n/\n/g;
  }
}
return $text;
}
EOR

SEE ALSO

include(7ic)


Name

file-info — retrieve file information

ATTRIBUTES

AttributePos.Req.DefaultDescription
server
conf
run
flags
size
time return time of last modification in seconds since epoch
date
gmt
fmt
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

file-info is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/file_info.coretag
Lines: 57


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: file_info.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag file-info Order       name
UserTag file-info attrAlias   file name
UserTag file-info addAttr
UserTag file-info Version     $Revision: 1.4 $
UserTag file-info Routine     <<EOR
sub {
my ($fn, $opt) = @_;
if($opt->{server}) {
  $fn = "$Global::VendRoot/$fn"
}
elsif($opt->{conf}) {
  $fn = "$Global::ConfDir/$fn"
}
elsif($opt->{run}) {
  $fn = "$Global::RunDir/$fn"
}
my @stat = stat($fn);
my %info;
my @ary;
my $size  = $stat[7] < 1024
         ? $stat[7]
         : ( $stat[7] < 1024 * 1024
          ? sprintf ("%.2fK", $stat[7] / 1024)
          : sprintf ("%.2fM", $stat[7] / 1024 / 1024)
          );
if($opt->{flags}) {
  $opt->{flags} =~ s/\W//g;
  my @flags = split //, $opt->{flags};
  for(@flags) {
    s/(.)/"-$1 _"/ee;
  }
  return join "\t", @flags;
}
if($opt->{size}) {
  return $stat[7];
}
if($opt->{time}) {
  return $stat[9];
}
if($opt->{date}) {
  return $Tag->time($Scratch->{mv_locale},{time => $stat[9], gmt => $opt->{gmt}},'%c');
}
$opt->{fmt} = '%f bytes, last modified %Y-%m-%d %H:%M:%S'
  if ! $opt->{fmt};
$opt->{fmt} =~ s/%f/$size/g;
  $Tag->time($Scratch->{mv_locale},{time => $stat[9], gmt => $opt->{gmt}},$opt->{fmt});
}
EOR

SEE ALSO


Name

file-navigator

ATTRIBUTES

AttributePos.Req.DefaultDescription
base_url
view_href
view_form
edit_page
edit_form
initial_dir
details
edit_only
edit_all
top_of_tree
no_up
parent_directory_message
no_new_file
no_dirs
template
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: UI_BASE
Global Variables: MV_PAGE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

file-navigator is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/file_navigator.coretag
Lines: 345


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: file_navigator.coretag,v 1.17 2007-12-21 03:32:43 mheins Exp $

UserTag file-navigator Order    mask
UserTag file-navigator addAttr
UserTag file-navigator Version  $Revision: 1.17 $
UserTag file-navigator Routine  <<EOR
use vars qw/$CGI $Session $Tag $Scratch/;
eval {
      require Fcntl;
  local($^W) = 0;
      import Fcntl qw/:mode/;
};
if ($@) {
      *S_ISUID = sub {return 2048};
    *S_ISGID = sub {return 1024};
    *S_ISVTX = sub {return 512};
}
sub {
my ($dir_mask, $opt) = @_;


#::logDebug("file-nav dir_mask: $dir_mask opt: " . ::uneval($opt));
$dir_mask = '*';

my $base_admin = ( $::Variable->{UI_BASE} || 'admin');
my $base_url = $Vend::Cfg->{VendURL}
    . '/'
    . ($opt->{base_url} || $base_admin);
my $view_href = $opt->{view_href} || "$base_admin/do_view";
my $view_form = $opt->{view_form} || 'mv_arg=~FN~';
my $full_path;
my $action = $CGI::values{action} || '';
my $already_found;

my $edit_page = $opt->{edit_page} || "content_editor";
my $edit_form = $opt->{edit_form} || "ui_name=~FN~&ui_type=page";

my @errors;
my @messages;

my $idir_re;
if ($opt->{initial_dir}) {
  $Vend::Session->{ui_cwd} = $opt->{initial_dir};
  $idir_re = qr{^$opt->{initial_dir}/};
}

if($action eq 'chdir') {
  my $newdir = $CGI::values{dir} || '.';
  unless( Vend::File::allowed_file($newdir) ) {
    $Scratch->{ui_error} = ::errmsg('Security violation');
    return interpolate_html("[bounce page='$base_admin/error']");
  }
  if(! -d $newdir) {
    $Scratch->{ui_error} = ::errmsg("%s not a directory", $newdir);
    return interpolate_html("[bounce page='$base_admin/error']");
  }
  $Vend::Session->{ui_cwd} = $newdir || '.';
}

my $curdir = $Vend::Session->{ui_cwd} || '.';
$curdir =~ s:/+$::;
my @files;

FINDNAV: {
  if($action eq 'find') {
    my $regex;
    my $string = $CGI::values{find};
    if($string !~ /\S/) {
      push @errors, ::errmsg("Refuse to find a blank or whitespace.");
      last FINDNAV;
    }
    elsif( $string =~ /\(\s*\?\s*\{/) {
      $Scratch->{ui_error} = ::errmsg('Security violation');
      return interpolate_html("[bounce page='$base_admin/error']");
    }
    else {
      eval {
        if($string =~ /\*/ and $string !~ /\.\*/) {
          $regex =~ s/\*/.*/g;
        }
        $regex = qr{$string};
      };
    }

    if($@ or ! $regex) {
      push @errors, ::errmsg("%s is not a good search.", $regex);
      last FINDNAV;
    }

    $full_path = 1;
    require File::Find;
    my $wanted;

    local($SIG{__WARN__}) = sub { push @errors, $_ };

    my %exclude;
    if($CGI::values{find_action} =~ /\bfilename\b/) {
      $wanted = sub {
        push @files, $File::Find::name
          if $_ =~ $regex;
      };
    }
    else {
      if($curdir eq '.' and ! $CGI::values{find_session}) {
        %exclude = (qw! ./session 1 session 1 tmp 1 ./tmp 1!);
      }
      $wanted = sub {
        local ($/) = undef;
        if( -d $_ and $exclude{$File::Find::dir}) {
          $File::Find::prune = 1;
          return;
        }
        return unless -f _;
        -s _ > 1_000_000
          and do {
            push(@errors,
              errmsg("%s: refuse to find in megabyte-sized files",
                  $File::Find::name)
              );
            return;
          };
        open(TMPFINDNAV, "< $_")
          or do {
            push(@errors,
              errmsg("%s: permission denied", $File::Find::name)
              );
            return;
          };
        my $str = <TMPFINDNAV>;
        $str =~ $regex
          and push (@files, $File::Find::name);
        return;
      };
    }
    File::Find::find($wanted, $curdir);

     s:^./:: for @files;

    if(@files) {
      push @messages, errmsg("Found %s files.", scalar @files);
      $already_found = 1;
    }
    else {
      undef $full_path;
      push @errors, errmsg("No files found.");
    }
  }
}

if($already_found) {
  # do nothing
}
elsif($curdir eq '.') {
  if($dir_mask eq '*') {
  @files = grep $_ ne 'CVS', glob('*');
}
else {
  @files = split /\s+/, $dir_mask;
}
}
else {
@files = grep $_ !~ m{/CVS$}, glob("$curdir/*");
}

my $this_page = $Global::Variable->{MV_PAGE};
my $this = Vend::Interpolate::tag_area($this_page);
$this =~ s/\?(.*)//;

my $up_img = qq{<img src="up.gif" align=center border=0 height=22 width=20 title="upload ~FN~">};
my $dn_img = qq{<img src="down.gif" align=center border=0 height=22 width=20 \
 title="download ~FN~">};
my $vw_img = qq{<img src="index.gif" align=center border=0 height=22 width=20 title="view ~FN~">};
my $ed_img = qq{<img src="layout.gif" align=center border=0 height=22 \
 width=20 title="edit ~FN~">};
my $dir_img = qq{<img src="folder.gif" align=center border=0 height=22 \
 width=20 title="change directory to ~FN~">};
my $del_img = qq{<img src="delete.gif" align=center border=0 height=20 \
 width=20 title="DELETE ~FN~">};
my $sp_img = qq{<img src="bg.gif" align=center border=0 height=20 width=20>};

my $do_perms;
$opt->{details} = $CGI->{details} unless defined $opt->{details};
if(defined $opt->{details}) {
  $do_perms = $opt->{details};
}
elsif (defined $CGI->{details}) {
  $do_perms = $Session->{ui_file_details} = $CGI->{details};
}
else {
  $do_perms = $Session->{ui_file_details};
}

my $del_string = '';
$Tag->if_mm('advanced', 'delete_files')
  and do {
    $del_string = qq{<A onClick="return confirm('Are you sure you want \
 to delete the file ~FN~?')" HREF="$Vend::Cfg->{VendURL}/$this_page \
?~ID~&mv_click=file_maintenance&ui_delete_file=~FN~&mv_action=back">$del_img</A>};
  };

my $ftmpl = <<EOF;
<A HREF="$Vend::Cfg->{VendURL}/ui_download/~FN~?~ID~">$dn_img</A>$del_string \
<A HREF="$base_url/upload_file?~ID~&mv_arg=~FN~&ui_return_to=$this_page">$up_img \
</A><A HREF="$base_url/do_view?~ID~&mv_arg=~FN~">$vw_img \
</A>&nbsp;%s&nbsp;<A HREF="$Vend::Cfg->{VendURL}/$view_href?~ID~&$view_form">%s</A><BR>
EOF

my $utmpl = <<EOF;
<A HREF="$base_url/upload_file?~ID~&mv_arg=~FN~&ui_return_to=$this_page">$up_img \
</A>&nbsp;%s&nbsp;<A HREF="$base_url/upload_file?~ID~&mv_arg=~FN~ \
&ui_return_to=$this_page">%s</A><BR>
EOF

my $ftmpl_ed;
if(! $do_perms and $opt->{edit_only}) {
  $ftmpl_ed = <<EOF;
<A HREF="$base_url/$edit_page?~ID~&$edit_form&ui_return_to=$this_page">$ed_img \
</A>&nbsp;%s&nbsp;<A HREF="$base_url/$edit_page?~ID~&$edit_form \
&ui_return_to=$this_page">%s</A><BR>
EOF
}
else {
  $ftmpl_ed = <<EOF;
<A HREF="$Vend::Cfg->{VendURL}/ui_download/~FN~?~ID~">$dn_img</A>$del_string \
<A HREF="$base_url/upload_file?~ID~&mv_arg=~FN~&ui_return_to=$this_page">$up_img \
</A><A HREF="$base_url/$edit_page?~ID~&$edit_form \
&ui_return_to=$this_page">$ed_img</A>&nbsp;%s&nbsp;<A HREF="$base_url/$edit_page \
?~ID~&$edit_form&ui_return_to=$this_page">%s</A><BR>
EOF
}

my $dtmpl = <<EOF;
<A HREF="$Vend::Cfg->{VendURL}/$this_page?~ID~&action=chdir&dir=~FN~">$dir_img \
</A>&nbsp;%s&nbsp;<A HREF="$Vend::Cfg->{VendURL}/$this_page \
?~ID~&action=chdir&dir=~FN~">%s</A><BR>
EOF

$dtmpl = "$sp_img$sp_img$sp_img$dtmpl" if $do_perms;

my @out;
my $out;

my @dir;
my @plain;


sub perm_line {
  my $fn = shift;

  my @perm = qw/
    ---
    --x
    -w-
    -wx
    r--
    r-x
    rw-
    rwx
  /;

  my @det;
  if (-l $fn) {
    @det = lstat($fn);
  }
  else {
    @det = stat(_);
  }
  my $time = POSIX::strftime("%d-%b-%Y %H:%M:%S", localtime($det[9]));
  my $permstring = sprintf('%04o', $det[2]);
  #push @messages, "$_ perms=$permstring\n";
  $permstring = substr($permstring, -3, 3);
  my $top;
  my (@ugo) = split //, $permstring;
  @ugo = map { $_ = $perm[$_] } @ugo;
  if    (-l _) { $top = 'l' }
  elsif (-d _) { $top = 'd' }
  elsif (-f _) { $top = '-' }
  else         { $top = '?' }
  $ugo[0] =~ s/.$/s/ if $det[2] & S_ISUID();
  $ugo[1] =~ s/.$/s/ if $det[2] & S_ISGID();
  $ugo[2] =~ s/.$/t/ if $det[2] & S_ISVTX();
  my $user = getpwuid($det[4]);
  my $grp  = getgrgid($det[5]);
  $grp = substr($grp, 0, 8) if length($grp) > 8;
  $user = substr($grp, 0, 8) if length($user) > 8;
  my $perm = join "", $top, @ugo;
  my $ret = sprintf(" <TT><SMALL>%s %-8s %-8s %s</SMALL></TT>", $perm, $user, $grp, $time);
  $ret =~ s/ /&nbsp;/g;
  return $ret;
}

my $perms = '';
for(@files) {
  my $fn = $_;
  $fn =~ s:.*/::
    unless $full_path;
  my $fe = $_;
  $fe =~ s!([^-\w./:,])!sprintf('%%%02x', ord($1) )!eg;
  my $perms;
  $perms = perm_line($_) if($do_perms);
  
  if(-d $_) {
    push @dir, [$fe, $fn, $dtmpl, $perms];
  }
  elsif ($opt->{edit_all} || ($opt->{edit_only} && /\.html?$/) ) {
    my $rn = $curdir . "/$fn";
    $rn =~ s{$idir_re}{} if $idir_re;
    push @plain, [$fe, $fn, $ftmpl_ed, $perms, $rn];
  }
  else {
    push @plain, [$fe, $fn, $ftmpl, $perms];
  }
}

$opt->{top_of_tree} ||= '.';
my $nd = $curdir;
if($nd ne $opt->{top_of_tree} and ! $opt->{no_up}) {
  $nd =~ s:/[^/]*$::
    or $nd = $opt->{top_of_tree};
  my $msg = '<large><b>..</b></large> &#91;'
    . errmsg ($opt->{parent_directory_message} || 'parent directory')
    . '&#93;';
  unshift @dir, [ $nd, $msg, $dtmpl ];
}

my $pc = \$Vend::Session->{pageCount};
unshift @dir, [ "$curdir/", errmsg('(new file)'), $utmpl ]
  unless $opt->{no_new_file};

@dir = () if $opt->{no_dirs};

for(@errors) {
  $out .= "<span class=cerror>$_</span><br>";
}
for(@messages) {
  $out .= "<span class=cmessage>$_</span><br>";
}
my $template = $opt->{template} || '';
for (@dir, @plain) {
  $$pc++;
  $_->[2] = sprintf($_->[2], $_->[3], $_->[1]);
  $_->[2] =~ s/~FN~/$_->[0]/g;
  $_->[2] =~ s/~RN~/$_->[4]/g;
  $_->[2] =~ s/~ID~/mv_session_id=$Session->{id}&mv_pc=$$pc/g;
  if($template) {
    my $t = $template;
    $t =~ s/%s/$_->[2]/;
    $out .= $t;
  }
  else {
    $out .= $_->[2];
  }
}

return $out;
}
EOR

SEE ALSO


Name

filter — apply one or multiple filters

ATTRIBUTES

AttributePos.Req.DefaultDescription
op Yes  List of filters to apply.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag applies one or multiple filters to the enclosed text.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

filter is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/filter.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: filter.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag filter              Order        op
UserTag filter              hasEndTag
UserTag filter              PosNumber    1
UserTag filter              Version      $Revision: 1.4 $
UserTag filter              MapRoutine   Vend::Interpolate::filter_value

Source: lib/Vend/Interpolate.pm
Lines: 742

sub filter_value {
my($filter, $value, $tag, @passed_args) = @_;
#::logDebug("filter_value: filter='$filter' value='$value' tag='$tag'");
my @filters = Text::ParseWords::shellwords($filter); 
my @args;

if(! $Vend::Filters_initted++ and my $ref = $Vend::Cfg->{CodeDef}{Filter}) {
  while (my($k, $v) = each %{$ref->{Routine}}) {
    $Filter{$k} = $v;
  }
}

for (@filters) {
  next unless length($_);
  @args = @passed_args;
  if(/^[^.]*%/) {
    $value = sprintf($_, $value);
    next;
  }
  if (/^(\d+)([\.\$]?)$/) {
    my $len;
    return $value unless ($len = length($value)) > $1;
    my ($limit, $mod) = ($1, $2);
    unless($mod) {
      substr($value, $limit) = '';
    }
    elsif($mod eq '.') {
      substr($value, $1) = '...';
    }
    elsif($mod eq '$') {
      substr($value, 0, $len - $limit) = '...';
    }
    return $value;
    next;
  }
  while( s/\.([^.]+)$//) {
    unshift @args, $1;
  }
  if(/^\d+$/) {
    substr($value , $_) = ''
      if length($value) > $_;
    next;
  }
  if ( /^words(\d+)(\.?)$/ ) {
    my @str = (split /\s+/, $value);
    if (scalar @str > $1) {
      my $num = $1;
      $value = join(' ', @str[0..--$num]);
      $value .= $2 ? '...' : '';
    }
    next;
  }
  my $sub;
  unless ($sub = $Filter{$_} ||  Vend::Util::codedef_routine('Filter', $_) ) {
    logError ("Unknown filter '%s'", $_);
    next;
  }
  unshift @args, $value, $tag;
  $value = $sub->(@args);
}
#::logDebug("filter_value returns: value='$value'");
return $value;
}

SEE ALSO

Filter(7ic)


Name

flag

ATTRIBUTES

AttributePos.Req.DefaultDescription
value
status
table
show
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

flag is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/flag.coretag
Lines: 17


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: flag.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag flag                Order        type
UserTag flag                addAttr
UserTag flag                attrAlias    tables table
UserTag flag                attrAlias    flag type
UserTag flag                attrAlias    name type
UserTag flag                PosNumber    1
UserTag flag                Version      $Revision: 1.5 $
UserTag flag                MapRoutine   Vend::Interpolate::flag

Source: lib/Vend/Interpolate.pm
Lines: 1873

sub flag {
my($flag, $opt, $text) = @_;
$flag = lc $flag;

if(! $text) {
  ($flag, $text) = split /\s+/, $flag;
}
my $value = defined $opt->{value} ? $opt->{value} : 1;
my $fmt = $opt->{status} || '';
my @status;

#::logDebug("tag flag=$flag text=$text value=$value opt=". uneval_it($opt));
if($flag eq 'write' || $flag eq 'read') {
  my $arg = $opt->{table} || $text;
  $value = 0 if $flag eq 'read';
  my (@args) = Text::ParseWords::shellwords($arg);
  my $dbname;
  foreach $dbname (@args) {
    # Handle table:column:key
    $dbname =~ s/:.*//;
#::logDebug("tag flag write $dbname=$value");
    $Vend::WriteDatabase{$dbname} = $value;
  }
}
elsif($flag =~ /^transactions?/i) {
  my $arg = $opt->{table} || $text;
  my (@args) = Text::ParseWords::shellwords($arg);
  my $dbname;
  foreach $dbname (@args) {
    # Handle table:column:key
    $dbname =~ s/:.*//;
    $Vend::TransactionDatabase{$dbname} = $value;
    $Vend::WriteDatabase{$dbname} = $value;

    # we can't do anything else if in Safe
    next if $MVSAFE::Safe;

    # Now we close and reopen
    my $db = database_exists_ref($dbname)
      or next;
    if($db->isopen()) {
      # need to reopen in transactions mode. 
      $db->close_table();
      $db->suicide();
      $db = database_exists_ref($dbname);
      $db = $db->ref();
    }
    $Db{$dbname} = $db;
    $Sql{$dbname} = $db->dbh()
      if $db->can('dbh');
  }
}
elsif($flag eq 'commit' || $flag eq 'rollback') {
  my $arg = $opt->{table} || $text;
  $value = 0 if $flag eq 'rollback';
  my $method = $value ? 'commit' : 'rollback';
  my (@args) = Text::ParseWords::shellwords($arg);
  my $dbname;
  foreach $dbname (@args) {
    # Handle table:column:key
    $dbname =~ s/:.*//;
#::logDebug("tag commit $dbname=$value");
    my $db = database_exists_ref($dbname);
    next unless $db->isopen();
    next unless $db->config('Transactions');
    if( ! $db ) {
      logError("attempt to $method on unknown database: %s", $dbname);
      return undef;
    }
    if( ! $db->$method() ) {
      logError("problem doing $method for table: %s", $dbname);
      return undef;
    }
  }
}
elsif($flag eq 'checkhtml') {
  $Vend::CheckHTML = $value;
  @status = ("Set CheckHTML flag: %s", $value);
}
else {
  @status = ("Unknown flag operation '%s', ignored.", $flag);
  $status[0] = $opt->{status} if $opt->{status};
  logError( @status );
}
return '' unless $opt->{show};
$status[0] = $opt->{status} if $opt->{status};
return errmsg(@status);
}

SEE ALSO


Name

flag_job

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

flag_job is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/flag_job.coretag
Lines: 19


# Copyright 2006-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: flag_job.coretag,v 1.2 2007-03-30 23:40:49 pajamian Exp $

UserTag flag_job Order   action token
UserTag flag_job Version $Revision: 1.2 $
UserTag flag_job Routine <<EOR
sub {
my ($action, $token) = @_;

return Vend::Server::flag_job($$, $Vend::Cat, $action, $token);
}
EOR


SEE ALSO


Name

flex-select — tabular overview for a database table

ATTRIBUTES

AttributePos.Req.DefaultDescription
table Yes table name
sql_query
init
filter
height
ui_style
no_checkbox
no_meta
meta_image
form_name
table_width
table_border
table_padding
table_spacing
table_class
form_href
form_extra
form_method
mv_action
"all_$tag"
header_row_class
header_row_style
number_list
explicit_edit
ui_meta_view
group_class
group_spacing
group_padding
group_width
no_group
group_image
header_link_class
checkbox_width
checkbox_name
edit_page
edit_parm
label
"explicit_edit_$_"
no_code_link
data_row_class_even
data_row_class_odd
href
more_message
more_list
next_anchor
prev_anchor
page_anchor
more_border
more_border_selected
edit_button_extra
confirm
no_top
bottom_buttons
no_bottom
top_buttons
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: UI_ERROR_PAGE, UI_SECURE, UI_LARGE_TABLE, UI_META_SELECT
Global Variables: MV_PAGE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

flex-select is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/flex_select.coretag
Lines: 1482


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: flex_select.coretag,v 1.18 2009-05-01 16:02:50 mheins Exp $

UserTag flex-select Order      table
UserTag flex-select addAttr
UserTag flex-select attrAlias  ml height
UserTag flex-select hasEndTag
UserTag flex-select Version    $Revision: 1.18 $
UserTag flex-select Routine    <<EOR
use vars qw/$CGI $Tmp $Tag/;
my @fs_more = qw/
help_name
icon_name
page_banner
page_title
ui_break_before
ui_description_fields
ui_flex_description
ui_flex_key
ui_show_fields
ui_sort_field
ui_sort_option
/;
sub flex_select_init {
my ($table, $opt) = @_;

my @warnings;
my @errors;

#::logDebug("Entering flex_select init");
if($CGI->{mv_more_ip}) {
  for(@fs_more) {
    $CGI->{$_} = $::Values->{$_};
  }
}

if($CGI->{mv_return_table}) {
  my $rt = delete $CGI->{mv_return_table};
  $rt =~ s/^\0+//;
  $rt =~ s/\0.*//;
  $CGI->{mv_data_table} = $rt if $rt;
}

my $bounce_url;
$::Scratch->{ui_class} = $CGI->{ui_class}
  if $CGI->{ui_class} &&  $CGI->{ui_class} =~ /^\w+$/;

if($opt->{sql_query}) {
  my $spec;
  eval {
    ($table) = Vend::Scan::sql_statement($opt->{sql_query}, { table_only => 1});
  };
  if($@) {
    $Tag->error( {
          set => errmsg(
                "flex-select -- bad query %s: %s",
                $opt->{sql_query},
                $@,
              ),
          name => 'flex_select',
          });
    return undef;
  }
}

if($table =~ s/\.(txt|asc)$/_$1/) {
  $table =~ s:.*/::;
}
my $db = database_exists_ref($table);

$Tmp->{flex_select} ||= {};
my $ts = $Tmp->{flex_select}{$table} = {};

if(! $db) {
$Tag->error({
      name => 'flex_select',
      set =>  errmsg('no %s database', $table),
  });
my $url = $Tag->area( {
      href => $::Variable->{UI_ERROR_PAGE} || 'admin/error',
      secure => $::Variable->{UI_SECURE},
    });
#::logDebug("delivering error url=$url");
$Tag->deliver( { location => $url });
return;
}

if( $::Variable->{UI_LARGE_TABLE} =~ /\b$table\b/ or $db->config('LARGE') ) {
$ts->{large} = 1;
}

if( $db->config('COMPOSITE_KEY') ) {
  $ts->{multikey} = 1;
  $ts->{key_columns} = $db->config('_Key_columns');
}

DELETE: {
  last DELETE unless $CGI->{item_id};
  last DELETE unless delete $CGI->{deleterecords};
  unless ($Tag->if_mm('tables', '=d')) {
    $Tag->error({
            name => 'flex_select',
            set => errmsg("no permission to delete records"),
          });
    last DELETE;
  };

  $Vend::Cfg->{NoSearch} = '';

  my @ids = split /\0/, $CGI->{item_id};
  for(grep $_, @ids) {
    if($db->delete_record($_)) {
      push @warnings, errmsg("Deleted record %s", $_);
    }
    else {
      push @errors, $db->errstr();
    }
  }
}

SEQUENCE: {
  my $dest = $CGI->{ui_sequence_destination} || '__UI_BASE__/flex_editor';
#::logDebug("Entering flex_select sequence edit stuff");
  last SEQUENCE unless $CGI->{ui_sequence_edit};
#::logDebug("doing flex_select sequence edit stuff");
  my $doit;
  if($CGI->{item_id_left} =~ s/^(.*?)[\0]//) {
    $CGI->{ui_sequence_edit} = 1;
    $CGI->{item_id} = $1;
    $doit = 1;
  }
  elsif ($CGI->{item_id_left}) {
    $CGI->{item_id} = delete $CGI->{item_id_left};
    delete $CGI->{ui_sequence_edit};
    $doit = 1;
  }
  else {
    delete $CGI->{item_id};
    delete $CGI->{ui_sequence_edit};
  }
  last SEQUENCE unless $doit;
  my $url = $Tag->area( {
                href => $dest,
                form => qq{
                  mv_data_table=$CGI->{mv_data_table}
                  item_id=$CGI->{item_id}
                  item_id_left=$CGI->{item_id_left}
                  ui_sequence_edit=$CGI->{ui_sequence_edit}
                },
              });
#::logDebug("flex_select sequence developed URL=$url");
  $Tag->deliver( { location => $url } );
  return;
}

$ts->{table_meta} = $Tag->meta_record($table, $CGI->{ui_meta_view}) || {};
my $tm = $ts->{table_meta};

my $extra;
if($tm->{name}) {
  $extra .= "<b>$tm->{name}</br>";
}
if($ts->{help_url}) {
  $extra .= qq{&nbsp;&nbsp;&nbsp;<small><a href="$ts->{help_url}">};
  $extra .= errmsg('help');
  $extra .= "</a></small>";
}
if($ts->{help}) {
  $extra .= "<blockquote>$ts->{help}</blockquote>";
}
$::Scratch->{page_banner} ||= $::Scratch->{page_title};
$::Scratch->{page_banner} .= $extra;

for(@errors) {
  $Tag->error({ name => 'flex_select', set => $_ });
}
for(@warnings) {
  $Tag->warnings($_);
}
return;
}

sub {
my ($table, $opt, $body) = @_;

#::logDebug("Entering flex_select");
my $CGI = \%CGI::values;

$table ||= $CGI->{mv_data_table};

## Do the initialization
if($opt->{init}) {
  return flex_select_init($table, $opt);
}

my $filter;
if(ref($opt->{filter}) eq 'HASH') {
  $filter = $opt->{filter};
}
$filter ||= {};

my $spec;
my $stmt;
my $q;
if($opt->{sql_query}) {
  $q = $opt->{sql_query};
  if($CGI->{ui_sort_field} =~ s/^(\w+)(:[rfn]+)?$/$1/) {
    my $field = $1;
    my $opt = $2 || $CGI->{ui_sort_option};
    $field .= ' DESC', $CGI->{ui_sort_option} = 'r' if $opt =~ /r/i;
    $q =~ s/
          \s+ORDER\s+BY
          \s+(\w+(\s+desc\w*)?)
          (\s*,\s*\w+(\s+desc\w*)?)*
          (\s*$|\s+LIMIT\s+\d+(?:\s*,\s*\d+)?)
         / ORDER BY $field$5/ix
    or
      $q =~ s/(\s+LIMIT\s+\d+(?:\s*,\s*\d+)?)/ ORDER BY $field$1/ix
      or $q .= " ORDER BY $field";
  }

  eval {
    ($spec) = Vend::Scan::sql_statement($q);
  };
  if($@ || ! $spec->{rt}) {
    $Tag->error( {
          set => errmsg("flex-select -- bad query %s: %s", $q, $@),
          name => 'flex_select',
          });
    return undef;
  }
  $table = $spec->{rt}->[0];
}

my $ref = dbref($table)
  or do {
    my $msg = errmsg("%s: table '%s' does not exist", 'flex_select', $table);
    logError($msg);
    $Tag->error({ name => 'flex_select', set => $msg });
    return undef;
  };
my $ts = $Tmp->{flex_select}{$table} ||= {};
my $meta = $ts->{table_meta} ||= $Tag->meta_record($table, $CGI->{ui_meta_view});

#::logDebug("flex_select table=$table");
if($meta->{sql_query}) {
  $q = $meta->{sql_query};
  if($CGI->{ui_sort_field} =~ s/^(\w+)(:[rfn]+)?$/$1/) {
    my $field = $1;
    my $opt = $2 || $CGI->{ui_sort_option};
    $field .= ' DESC', $CGI->{ui_sort_option} = 'r' if $opt =~ /r/i;
    $q =~ s/
          \s+ORDER\s+BY
          \s+(\w+(\s+desc\w*)?)
          (\s*,\s*\w+(\s+desc\w*)?)*
          (\s*$|\s+LIMIT\s+\d+(?:\s*,\s*\d+)?)
         / ORDER BY $field$5/ix
    or
      $q =~ s/(\s+LIMIT\s+\d+(?:\s*,\s*\d+)?)/ ORDER BY $field$1/ix
      or $q .= " ORDER BY $field";
  }

  eval {
    ($spec) = Vend::Scan::sql_statement($q);
  };
  if($@ or ! $spec->{rt}) {
    $Tag->error( {
          set => errmsg("flex-select -- bad query %s: %s", $q, $@),
          name => 'flex_select',
          });
    return undef;
  }
  $table = $spec->{rt}->[0];
}

if( $table ne $ref->config('name')) {
  ## Probably transient database
  $CGI->{mv_data_table_real} = $table = $ref->config('name');
}

my @labels;          ## Locally set labels in ui_show_fields
my @views;           ## Locally set view data in ui_show_fields
my @filter_show;     ## Locally set filters in ui_show_fields
my @calcs;           ## Data calculation code (if any) from fs_data_calc
my @redirect;        ## A column with a different metadata from standard
my @extras;          ## A column with a different metadata from standard
my @style;           ## Style for data cell, only have to read once
my @link_page;       ## Locally set filters in ui_show_fields
my @link_parm;       ## Locally set filters in ui_show_fields
my @link_parm_extra; ## Locally set filters in ui_show_fields
my @link_anchor;     ## Locally set filters in ui_show_fields
my $filters_done;    ## Tells us we are done with filters

if(my $show = $CGI->{ui_show_fields} ||= $meta->{ui_show_fields} || $meta->{field}) {
  my $i = 0;
  if($show =~ s/[\r\n]+/\n/g) {
    $show =~ s/^\s+//;
    $show =~ s/\s+$//;
    my @f = split /\n/, $show;
    my @c;
    for(@f) {
      s/^\s+//;
      s/\s+$//;
      if(s/\s*\((.+)\)\s*$//)  {
        $filter_show[$i] = $1;
      }
      
      if(/^(\w+)-(\w+)$/) {
        push @c, $1;
        $redirect[$i] = $2;
      }
      elsif(/^(\w+)(?:-([^=]+))?(?:=(.*))?/) {
        push @c, $1;
        $views[$i] = $2 if $2;
        $labels[$i] = $3;
      }
      else {
        push @c, $_;
      }
      $i++;
    }
    $show = join ",", @c;
  }
  else {
    $show =~ s/(\w+)(?:\((.*?)\))?/ ($filter_show[$i++] = $2), $1/eg;
    $show =~ s/[\0,\s]+/,/g;
  }
  $CGI->{ui_description_fields} = $show;
  $filters_done = 1;
}

if($spec) {
#::logDebug("flex_select spec=$spec");
  if($spec->{rf} and $spec->{rf}[0] ne '*') {
    my @c;
    my $header;
    for(my $i = 0; $i < @{$spec->{rf}}; $i++) {
      if($spec->{hf}[$i]) {
        $header++;
        push @c, $spec->{rf}[$i] . '=' . $spec->{hf}[$i];
      }
      else {
        push @c, $spec->{rf}[$i];
      }
    }
    if($header) {
      $CGI->{ui_show_fields} = join "\n", @c;
    }
    else {
      $CGI->{ui_show_fields} = join " ", @c;
    }
  }
  if($spec->{tf} and $spec->{tf}[0]) {
    $CGI->{ui_sort_field} = join ",", @{$spec->{tf}};
    $CGI->{ui_sort_option} = join ",", @{$spec->{to}};
  }
  $CGI->{ui_list_size} = $spec->{ml} if $spec->{ml};
}

$meta ||= {};

if($CGI->{ui_flex_key}) {
  $ts->{keypos} = $CGI->{ui_flex_key};
}
else {
  $ts->{keypos} = $ref->config('KEY_INDEX');
}

$ts->{keyname} = $ref->config('KEY');
$ts->{owner_field} = $ref->config('OWNER_FIELD') || $::Scratch->{ui_owner};

if($CGI->{ui_exact_record}) {
#::logDebug("found exact record input");
  undef $CGI->{mv_like_field};
  my $id = $CGI->{mv_like_spec};
  $id =~ s/\0.*//s;
  my $url = $Tag->area({
              href => 'admin/flex_editor',
              form => qq{
                mv_data_table=$CGI->{mv_data_table}
                item_id=$id
                ui_meta_view=$CGI->{ui_meta_view}
              },
            });

  $Tag->deliver({ location => $url });
#::logDebug("deliver=$url");
  return;
}

my $sf;
if($sf = $CGI->{ui_sort_field} and $sf =~ s/^(\w+)([,\s\0]+.*)?$/$1/) {
  my $fmeta;
  $fmeta = $Tag->meta_record("${table}::$sf", $CGI->{ui_meta_view})
    and do {
      $CGI->{ui_more_alpha} = $fmeta->{ui_more_alpha}
        if length($fmeta->{ui_more_alpha});
      if (! $CGI->{ui_sort_option} and length($fmeta->{ui_sort_option}) ) {
        my $o = $fmeta->{ui_sort_option};
        if($CGI->{ui_sort_option} =~ /r/) {
          $o =~ s/^([^r]+)$/$1r/
            or $o =~ s/r//;
        }
        $CGI->{ui_sort_option} = $o;
      }
    };
}

for(qw/ui_more_alpha ui_more_decade ui_meta_specific/) {
  $CGI->{$_} = $meta->{$_} unless defined $CGI->{$_};
}
$Vend::Cfg->{NoSearch} = '';
my $out_message = '';
my $ui_text_qualification = $CGI->{ui_text_qualification};

if ($ui_text_qualification and $CGI->{ui_text_qualification} =~ /[<!=>\^]/ ) {
  if($ts->{owner_field}) {
    $CGI->{ui_text_qualification} = <<EOF;
co=1
st=db
sf=$ts->{owner_field}
se=$Vend::username
op=eq
nu=0
os=0
su=0
bs=0
EOF
  }
  else {
    $CGI->{ui_text_qualification} = "co=1\n";
  }

  my @entries = split /\s+(and|or)\s+/i,  $ui_text_qualification;
  my $or;
  for(@entries) {
    if(/^or$/i) {
      $or = 1;
      $CGI->{ui_text_qualification} .= "os=1\n";
      next;
    }
    elsif(/^and$/i) {
      $or = 0;
      $CGI->{ui_text_qualification} .= "os=0\n";
      next;
    }
    my ($f, $op, $s) = split /\s*([<=!>\^]+)\s*/, $_, 2;
    $op = "eq" if $op eq "==";
    $op = "rm" if $op eq "=";
    if($op eq '^') {
      $op = 'rm';
      $CGI->{ui_text_qualification} .= "bs=1\nsu=1\n";
    }
    else {
      $CGI->{ui_text_qualification} .= "bs=0\nsu=0\n";
    }
    my $ms = defined $CGI->{mv_min_string} ? $CGI->{mv_min_string} : 1;
    if(length($s) > $ms) {
      $CGI->{ui_text_qualification} .= "se=$s\nsf=$f\nop=$op\n";
    }
    else {
      $CGI->{ui_text_qualification} .= "se=.\nsf=$f\nop=rn\n";
    }
    if($op =~ /[<>]/ and $s =~ /^[\d.]+$/) {
      $CGI->{ui_text_qualification} .= "nu=1\n";
    }
    else {
      $CGI->{ui_text_qualification} .= "nu=0\n";
    }
  }
  if(defined $or) {
    $CGI->{ui_text_qualification} .= $or ? "os=1\n" : "os=0\n";
  }

  $out_message = errmsg('Entries matching "%s"', $ui_text_qualification);
}
elsif ($ui_text_qualification) {
  $CGI->{ui_text_qualification} = "se=$CGI->{ui_text_qualification}";
  $out_message = errmsg('Entries matching "%s"', $ui_text_qualification);
  if($ts->{owner_field}) {
    $CGI->{ui_text_qualification} = <<EOF;
co=1
sf=$ts->{owner_field}
se=$Vend::username
op=eq
sf=:*
se=$CGI->{ui_text_qualification}
EOF
  }
}
elsif ( $CGI->{mv_like_field} ) {
  my @f = split /\0/, $CGI->{mv_like_field};
  my @s = split /\0/, $CGI->{mv_like_spec};
  my @q = 'ra=yes';
  my $found;
  for(my $i = 0; $i < @f; $i++) {
    next unless length $s[$i];
    $found++;
    push @q, "lf=$f[$i]";
    push @q, "ls=$s[$i]";
  }
  if($found) {
    $CGI->{ui_text_qualification} = join "\n", @q;
    my @out;
    for(@q) {
      my $thing = $_;
      $thing =~ s/^ls=/mv_like_spec=/;
      $thing =~ s/^lf=/mv_like_field=/;
      push @out, $thing; 
    }
    $ts->{like_recall} = join "\n", @out;
  }
  else     { $CGI->{ui_text_qualification} = "" }
}
elsif($ts->{owner_field}) {
  $CGI->{ui_text_qualification} = <<EOF;
co=1
sf=$ts->{owner_field}
se=$Vend::username
op=eq
EOF
}
elsif ($ts->{large}) {
  my $keylabel = $Tag->display({
            table => $table,
            name => 'item_id',
            column => $ts->{keyname},
            template => 1,
          });
  $ts->{like_spec} = $CGI->{mv_more_ip} ? 0 : 1;
  $CGI->{ui_text_qualification} = "";
}
else {
  $CGI->{ui_text_qualification} = "ra=yes";
}

if($meta->{ui_sort_combined} =~ /\S/) {
  $meta->{ui_sort_field} = $meta->{ui_sort_combined};
  $meta->{ui_sort_option} = '';
}

$CGI->{ui_sort_field}  ||= $meta->{ui_sort_field}
            ||  $meta->{lookup}
            ||  $ts->{keyname};
$CGI->{ui_sort_option}  ||= $meta->{ui_sort_option};
$CGI->{ui_sort_option}  =~ s/[\0,\s]+//g;
$CGI->{ui_list_size} = $opt->{height} || $meta->{height}
  if ! $CGI->{ui_list_size};

if(! $CGI->{ui_show_fields} ) {
  $CGI->{ui_show_fields} = 
    $CGI->{ui_description_fields}
      = join ",", $ref->columns();
}
else {
  my $i = 0;
  my $show = $CGI->{ui_show_fields};
  if($filters_done) {
    # do nothing
  }
  else {
    if($show =~ s/[\r\n]+/\n/g) {
      $show =~ s/^\s+//;
      $show =~ s/\s+$//;
      my @f = split /\n/, $show;
      my @c;
      for(@f) {
        s/^\s+//;
        s/\s+$//;
        if(s/\s*\((.+)\)\s*$//)  {
          $filter_show[$i] = $1;
        }
        
        if(/^(\w+)-(\w+)$/) {
          push @c, $1;
          $redirect[$i] = $2;
        }
        elsif(/^(\w+)(?:-([^=]+))?(?:=(.*))?/) {
          push @c, $1;
          $views[$i] = $2 if $2;
          $labels[$i] = $3;
        }
        else {
          push @c, $_;
        }
        $i++;
      }
      $show = join ",", @c;
    }
    else {
      $show =~ s/(\w+)(?:\((.*?)\))?/ ($filter_show[$i++] = $2), $1/eg;
      $show =~ s/[\0,\s]+/,/g;
    }
    $CGI->{ui_description_fields} = $show;
  }
}

my @cols = split /,/, $CGI->{ui_description_fields};

@cols = grep $ref->column_exists($_), @cols
  unless $spec;

my %limit_field;

$CGI->{ui_limit_fields} =~ s/[\0,\s]+/ /g;
$CGI->{ui_limit_fields} =~ s/^\s+//;
$CGI->{ui_limit_fields} =~ s/\s+$//;

my (@limit_field) = split " ", $CGI->{ui_limit_fields};

if(@limit_field) {
  @limit_field{@limit_field} = ();
  @cols = grep ! exists($limit_field{$_}), @cols;
}

unshift(@cols, $ts->{keyname})
  if $cols[0] ne $ts->{keyname};

$CGI->{ui_description_fields} = join ",", @cols;

unless ($CGI->{ui_sort_option}) { 
   $CGI->{ui_sort_option} = 'n'
      if $ref->numeric($CGI->{ui_sort_field}); 
} 

my $fi = $CGI->{mv_data_table_real} || $CGI->{mv_data_table};
$ts->{sparams} = ($ts->{like_spec} || $spec) ? '' : <<EOF;

fi=$fi
st=db
$CGI->{ui_text_qualification}
su=1
ma=$CGI->{ui_more_alpha}
md=$CGI->{ui_more_decade}
ml=$CGI->{ui_list_size}
tf=$CGI->{ui_sort_field}
to=$CGI->{ui_sort_option}
rf=$CGI->{ui_description_fields}
nh=1

EOF
$::Scratch->{page_banner} .= $out_message;
$::Scratch->{page_title} .= $out_message;

my %output;
### Header determination

my @refkeys = grep ref($opt->{$_}) eq 'HASH', keys %$opt;

my %default = (
  data_cell_class   => '',
  data_cell_style   => '',
  data_row_class_even   => 'rownorm',
  data_row_class_odd   => 'rowalt',
  data_row_style_even   => '',
  data_row_style_odd   => '',
  form_method => 'GET',
  explicit_edit => '',
  explicit_edit_page => '',
  explicit_edit_form => '',
  explicit_edit_anchor => '',
  no_code_link => '',
  group_image   => 'smindex.gif',
  group_class   => 'rhead',
  group_spacing   => 2,
  group_padding   => 0,
  group_width   => '100%',
  header_link_class   => 'rhead',
  header_cell_class   => 'rhead',
  header_cell_style   => '',
  header_row_class   => 'rhead',
  header_row_style   => '',
  mv_action => 'back',
  meta_image => errmsg('meta.png'),
  label => "flex_select_$table",
  no_checkbox => 0,
  radio_box => 0,
  user_merge => 0,
  check_uncheck_all => 0,
  number_list => 0,
  table_border  => 0,
  table_class   => 'rseparator',
  table_padding => 0,
  table_spacing => 1,
  table_style   => '',
  table_width   => '100%',
);

for(keys %default) {
  next if defined $opt->{$_};
  if(length $meta->{$_}) {
    $opt->{$_} = $meta->{$_};
  }
  else {
    $opt->{$_} = $default{$_};
  }
}

$opt->{ui_style} = 1 unless defined $opt->{ui_style};
$opt->{no_checkbox} = 1 if $ts->{multikey};

my $show_meta;
my $meta_anchor;
if($Tag->if_mm('super') and ! $opt->{no_meta}) {
$show_meta = defined $::Values->{ui_meta_force}
      ? $::Values->{ui_meta_force}
      : $::Variable->{UI_META_SELECT};
if($opt->{meta_image}) {
  $meta_anchor = qq{<img src="$opt->{meta_image}" border=0>};
}
else {
  $meta_anchor = 'M';
}
}

$opt->{form_name} ||= "fs_$table";

$output{TOP_OF_TABLE} = <<EOF;
<table width="$opt->{table_width}" border="$opt->{table_border}" cellpadding="$opt->{table_padding}" \
 \
 cellspacing="$opt->{table_spacing}" class="$opt->{table_class}">
EOF

my $cwp = $Global::Variable->{MV_PAGE};
$opt->{form_href} ||= $CGI->{ui_searchpage} || $cwp;
$opt->{form_extra} ||= '';
$opt->{form_extra} .= qq{ name="$opt->{form_name}"} if $opt->{form_name};
$opt->{form_extra} =~ s/^\s*/ /;
my $action = $Tag->process({href => $opt->{form_href}});

$output{TOP_OF_FORM} = <<EOF;
<form action="$action" method="$opt->{form_method}"$opt->{form_extra}>
<input type=hidden name=mv_data_table    value="$table">
<input type=hidden name=mv_action        value="$opt->{mv_action}">
<input type=hidden name=mv_click         value="warn_me_main_form">
<input type=hidden name=mv_session_id    value="$Vend::SessionID">
EOF

### What the heck is going on here?
if($CGI->{ui_meta_view}) {
  $output{TOP_OF_FORM} .= <<EOF;
<input type=hidden name=ui_meta_view         value="$CGI->{ui_meta_view}">
EOF
  $output{TOP_OF_FORM} .= $Tag->return_to();
}
else {
  $output{TOP_OF_FORM} .= <<EOF;
<!-- got no return-to -->
<input type=hidden name=ui_meta_specific value="$CGI->{ui_meta_specific}">
<input type=hidden name=ui_page_title    value="$CGI->{ui_page_title}">
<input type=hidden name=ui_page_banner   value="$CGI->{ui_page_banner}">
<input type=hidden name=ui_limit_fields  value="$CGI->{ui_limit_fields}">
<input type=hidden name=ui_show_fields   value="$CGI->{ui_show_fields}">
<input type=hidden name=ui_return_to     value="$cwp">
<input type=hidden name=ui_return_to     value="mv_data_table=$table">
EOF
}

my $cc = $ts->{column_meta} ||= {};
my $mview = $CGI->{ui_meta_view};

my $cmeta = sub {
  my $col = shift;
  return $cc->{$col} if $cc->{$col};
  my $m = $Tag->meta_record("${table}::$col", $mview);
  for(@refkeys) {
    $m->{$_} = $opt->{$_}{$col} if exists $opt->{$_}{$col};
  }
  $cc->{$col} = $m;
  return $m;
};

my $header_cell_style = sub {
      my $col = shift;
      my $m = $cmeta->($col);
#::logDebug("meta for header=" . ::uneval($m));
      my $stuff = '';
      for(qw/ class style align valign /) {
        my $tag = "header_cell_$_";
        my $thing;
        if(ref $opt->{$tag}) {
          $thing = $opt->{$tag}{$col} || $m->{$tag} || $opt->{"all_$tag"}
            or next;
        }
        else {
          $thing = $m->{$tag} || $opt->{$tag}
            or next;
        }
        encode_entities($thing);
        $stuff .= qq{ $_="$thing"};
      }
      return $stuff;
    };

my $data_cell_style = sub {
      my $col = shift;
      my $m = $cmeta->($col);
      my $stuff = '';
      for(qw/ class style align valign /) {
        my $tag = "data_cell_$_";
        my $thing;
        if(ref $opt->{$tag}) {
          $thing = $opt->{$tag}{$col} || $m->{$tag} || $opt->{"all_$tag"}
            or next;
        }
        else {
          $thing = $m->{$tag} || $opt->{$tag}
            or next;
        }
        encode_entities($thing);
        $stuff .= qq{ $_="$thing"};
      }
      return $stuff;
    };

my @head;
my $rc = $opt->{header_row_class};
push @head, "<tr ";
push @head, qq( class=$opt->{header_row_class}) if $opt->{header_row_class};
push @head, qq( style=$opt->{header_row_style}) if $opt->{header_row_style};
push @head, ">\n";
if(! $opt->{no_checkbox}) {
  push @head, "  <td class=rhead>&nbsp;</td>" 
}
if($opt->{radio_box}) {
  push @head, "  <td class=rhead>&nbsp;</td>" 
}
if($opt->{number_list}) {
  push @head, "  <td class=rhead align=right>#&nbsp;</td>" ;
}
if($opt->{explicit_edit}) {
  push @head, "  <td class=rhead>&nbsp;</td>" 
}

my $return = <<EOF;
ui_return_to=$cwp
ui_return_to=ui_meta_view=$opt->{ui_meta_view}
ui_return_to=mv_return_table=$table
mv_return_table=$table
ui_return_stack=$CGI->{ui_return_stack}
start_at=extended.ui_more_alpha
EOF

my %mkey;
if($ts->{multikey}) {
  for(@{$ts->{key_columns}}) {
    $mkey{$_} = 1;
  }
}

my @mcol;

my $idx = 0;
foreach my $col (@cols) {
  my $mcol = $col;
  if($redirect[$idx]) {
    $mcol .= "-$redirect[$idx]";
  }
  my $td_extra = $header_cell_style->($mcol);

  ## $cc is set in header_cell_class 
  my $m = $cc->{$mcol};

  if($mkey{$col}) {
    push @mcol, $idx - 1;
  }

  push @head, <<EOF;
<td$td_extra>
<table align="left" class="$opt->{group_class}" cellspacing=$opt->{group_spacing} \
 \
 cellpadding=$opt->{group_padding} width="$opt->{group_width}">
<tr>
EOF
unless($opt->{no_group} || $m->{fs_no_group}) {
my $u = $Tag->area({
          href => 'admin/flex_group',
          form => qq(
                mv_data_table=$table
                ui_meta_view=$mview
                from_page=$Global::Variable->{MV_PAGE}
                mv_arg=$col
              ),
        });
my $msg = errmsg('Select group by %s', $col);

    push @head, <<EOF;
    <td align="right" valign="center" width=1>
  <a href="$u" title="$msg"><img src="$opt->{group_image}" border=0></a>
    </td>
EOF

  }

  my $o = '';
  my $msg;
  my $rmsg;
  if($o = $m->{ui_sort_option}) {
    my @m;
    $msg = "sort by %s (%s)";

    if($CGI->{ui_sort_field} eq $col) {
      if($CGI->{ui_sort_option} =~ /r/) {
        $o =~ s/r//;
      }
      else {
        $o .= "r";
      }
    }
    push @m, errmsg('reverse') if $o =~ /r/;
    push @m, errmsg('case insensitive') if $o =~ /f/;
    push @m, errmsg('numeric') if $o =~ /n/;
    $rmsg = join ", ", @m;
  }
  else {
    if ($CGI->{ui_sort_field} eq $col and $CGI->{ui_sort_option} !~ /r/) {
      $o .= 'r';
      $msg = "sort by %s (%s)";
      $rmsg = errmsg('reverse');
    }
    else {
      $msg = "sort by %s";
    }
    $o .= 'n' if $ref->numeric($col);
  }
  my $sort_msg = errmsg($msg, $col, $rmsg);
  my $url = $Tag->area( {
              href => $cwp,
              form => qq(
                $ts->{like_recall}
                ui_text_qualification=$ui_text_qualification
                mv_data_table=$table
                ui_meta_view=$mview
                ui_sort_field=$col
                ui_sort_option=$o
                ui_more_alpha=$m->{ui_more_alpha}
              ),
            });

  my $lab = $labels[$idx] || $m->{label} || $col;

  # Set up some stuff for the data cells;
  $style[$idx] = $data_cell_style->($mcol);

  $filter_show[$idx] = $filter->{$mcol} if $filter->{$mcol};
  $filter_show[$idx] ||= $m->{fs_display_filter} || 'encode_entities';
  $filter_show[$idx] .= ' encode_entities'
     unless $filter_show[$idx] =~ /\b(?:encode_)?entities\b/;
  $style[$idx] .= " $1" while $filter_show[$idx] =~ s/(v?align=\w+)//i;

  if($views[$idx]) {
    my ($page, $parm, $l) = split /:/, $views[$idx];
    $m->{fs_link_page} = $page;

    $parm ||= 'item_id';
    my @p = split /[\s,\0]+/, $parm;
    my $arg = shift @p;
    $m->{fs_link_parm} = $arg;
    $m->{fs_link_parm_extra} = join ",", @p;
    $m->{fs_link_anchor} = $l;
  }

  if($m->{fs_link_page}) {
    $link_page[$idx]    = $m->{fs_link_page};
    $link_parm[$idx]    = $m->{fs_link_parm};
    if($m->{fs_link_parm_extra}) {
      my @p = grep /\S/, split /[\s,\0]+/, $m->{fs_link_parm_extra};
      $link_parm_extra[$idx]  = \@p;
    }
    $link_anchor[$idx]  = $m->{fs_link_anchor};
  }

  if(my $prog = $m->{fs_data_calc}) {
#::logDebug("looking at calcs=$prog");
    $prog =~ s/^\s+//;
    $prog =~ s/\s+$//;
    if($prog =~ /^\w+$/) {
      $calcs[$idx] = $Vend::Cfg->{Sub}{$prog} || $Global::GlobalSub->{$prog};
    }
    else {
      $prog =~ s/^\[(calc|perl)(.*?)\]//;
      $prog =~ s{\[/(calc|perl)\]$}{};
      $calcs[$idx] = $prog;
    }
    if($m->{fs_data_tables}) {
      tag_perl($m->{fs_data_tables}, {});
    }
  }

  push @head, <<EOF;
  <td$td_extra>
  <a href="$url" class=$opt->{header_link_class} title="$sort_msg">$lab</a>
    </td>
EOF

  if($show_meta) {
    my $u = $Tag->area({ href=>'admin/meta_editor',
               form => qq(
               item_id=${table}::$mcol
               ui_meta_view=$mview
               $return),
              });
    my $tit = errmsg(
            "Edit header meta information for %s::%s",
            $table,
            $col,
          );
    push @head, <<EOF;
<td width=1>
<a href="$u" title="$tit">$meta_anchor</a>
</td>
EOF

  }

  push @head, <<EOF;
  </tr>
  </table>  
</td>
EOF

  $idx++;
}
push @head, "</tr>";

shift @mcol;

my $ncols = $idx;
$ncols++ if $opt->{explicit_edit};
$ncols++ if $opt->{number_list};
$ncols++ if $opt->{radio_box};
$ncols++ unless $opt->{no_checkbox};

$output{HEADER_AREA} = join "", @head;
### Row output

my $cb_width = $opt->{checkbox_width} || '30';
my $cb_name = $opt->{checkbox_name} || 'item_id';
my $rb_name = $opt->{radiobox_name} || 'item_radio';
my $edit_page = $opt->{edit_page} || 'admin/flex_editor';
my $edit_parm = $opt->{edit_parm} || 'item_id';
my $edit_extra = <<EOF;
mv_data_table=$table
ui_page_title=$CGI->{ui_page_title}
ui_meta_view=$mview
ui_page_banner=$CGI->{ui_page_banner}
ui_meta_specific=$CGI->{ui_meta_specific}
EOF


my @rows;

if($ts->{like_spec}) {
  ## Do nothing
}
elsif($body =~ /\S/) {
  my $o = { 
        label    => $opt->{label},
        list_prefix  => 'flex',
        prefix    => 'flex',
        more    => 1,
        search    => $ts->{sparams},
      };
  push @rows, tag_loop_list($o);
}
else {
  my $ary;
  my $search;
  my $params;
  my $c;
#::logDebug("MM=$CGI->{MM}($CGI::values{MM}) mv_more_matches=$CGI->{mv_more_matches} \
($CGI::values{mv_more_matches})");
  if($CGI->{mv_more_ip}) {
    $search = $::Instance->{SearchObject}{$opt->{label}};
    $search ||= $::Instance->{SearchObject}{''};
    $search ||= perform_search();
    $ary = [ splice(
          @{$search->{mv_results}},
          $search->{mv_first_match},
          $search->{mv_matchlimit},
          )] ;
#::logDebug("search first_match=$search->{mv_first_match} length=$search->{mv_matchlimit}");
#::logDebug("Found search=" . ::uneval($search));
  }
  elsif($q) {
    my $db = dbref($table);
    my $o = {
      ma    => $CGI->{ui_more_alpha},
      md    => $CGI->{ui_more_decade},
      ml    => $CGI->{ui_list_size},
      more  => 1,
      table  => $fi,
      query  => $q,
    };
    $ary = $db->query($o);
  }
  else {
#::logDebug("In new search");
    $params = escape_scan($ts->{sparams});
    $c = { mv_search_immediate => 1, mv_search_label => $opt->{label} };
    Vend::Scan::find_search_params($c, $params);
    $search = Vend::Scan::perform_search($c);
    $ary = $search->{mv_results};
  }

  finish_search($search) if $search;
  
  $search ||= {};

  if($CGI->{ui_return_to} and ! $CGI->{ui_return_stack}) {
    $edit_extra .= $Tag->return_to('formlink');  
  }
  else {
    $edit_extra .= "ui_return_to=$cwp";
  }

  my $edit_anchor;
  my $ee_extra;
  if($opt->{explicit_edit}) {
    $edit_anchor = $opt->{explicit_edit_anchor} || errmsg('edit record');
    $edit_anchor =~ s/ /&nbsp;/g;
    $ee_extra = '';
    for(qw/ class style width align valign /) {
      my $v = $opt->{"explicit_edit_$_"}
        or next;
      $ee_extra .= qq{ $_="$v"};
    }
    $ee_extra ||= ' width=30';
  }
#::logDebug("explicit_edit=$opt->{explicit_edit} no_code_link=$opt->{no_code_link}");
  my $j = $search->{mv_first_match} || 0;
  foreach my $line (@$ary) {
    my $code = shift (@$line);
    my $ecode = encode_entities($code);
    my $rc = $j++ % 2
        ? $opt->{data_row_class_even}
        : $opt->{data_row_class_odd};
    my $out = qq{<tr class="$rc">\n};

    my $code_pre; my $code_post;
    my $ep_string = '';
    if($opt->{no_code_link} and ! $opt->{explicit_edit}) {
      $code_pre = $code_post = '';
    }
    else {
      my @what;
      push @what, "$edit_parm=$code";
      if($ts->{multikey}) {
        unshift @what, 'ui_multi_key=1';
        for(@mcol) {
          push @what, "$edit_parm=$line->[$_]";
        }

      }

      $ep_string = join "\n", @what, $edit_extra;

      my $edit_url = $Tag->area({
                href => $edit_page,
                form => $ep_string,
              });
      my $msg = errmsg('edit %s', $ecode);
      $code_pre = qq{<a href="$edit_url" title="$msg">};
      $code_post = qq{</a>};
    }

    unless($opt->{no_checkbox}) {
      $out .= <<EOF;
<td width="$cb_width"><input type=checkbox name=$cb_name value="$ecode"></td>
EOF
    }
    if($opt->{radio_box}) {
      $out .= <<EOF;
<td width="$cb_width"><input type=radio name=$rb_name value="$ecode"></td>
EOF
    }

    if($opt->{number_list}) {
      $out .= qq{<td align=right>&nbsp;$j&nbsp;</td>};
    }

    if($opt->{explicit_edit}) {
      my $form = $opt->{explicit_edit_form} || '';
      if($form) {
        $form .= $ecode;
      }
      my $url = $Tag->area({
                href => $opt->{explicit_edit_page} || $edit_page,
                form => $form || $ep_string,
              });
      my $msg = errmsg('process %s', $ecode);
      my $pre = qq{<a href="$url" title="$msg">};
      $out .= qq{<td$ee_extra>&nbsp;$pre$edit_anchor$code_post&nbsp;</td>};
    }

#::logDebug("keyname=$ts->{keyname}");
    $out .= "<td" . $data_cell_style->($ts->{keyname}) . ">";
    $ecode = '';
    if ($calcs[0]) {
      my %item;
      @item{@cols} = ($code, @$line);
      if(ref($calcs[0]) eq 'CODE') {
        $ecode = $calcs[0]->(\%item);
      }
      else {
        $Vend::Interpolate::item = \%item;
        $ecode = tag_calc($calcs[0]);
      }
    }
    if ($filter_show[0]) {
      $ecode = $code unless $ecode;
      $ecode = $Tag->filter($filter_show[0], $ecode, $cols[0]);
      $ecode =~ s/\[/&#91;/g;
    }
    $ecode = encode_entities($code) unless $ecode;
    $out .= "$code_pre$ecode$code_post</td>";
    my $i = 1;
    for my $v (@$line) {
      my $extra = $style[$i];
      my $pre = '';
      my $post = '';
      my $lab;

      if($link_page[$i]) {
        my $opt = { $link_parm[$i] => $v, form => 'auto' };
        if(my $p = $link_parm_extra[$i]) {
          for(@$p) {
            $opt->{$_} = $CGI->{$_};
          }
        }
        $opt->{href} = $link_page[$i];

        $lab = $link_anchor[$i];
        $lab =~ s/^\s+//;
        my $url = $Tag->area($opt);
        my $ev = encode_entities($v);
        $pre = qq{<a href="$url" title="$ev">};
        $post = '</a>';
      }

      if($calcs[$i]) {
#::logDebug("found a calc");
        my %item;
        @item{@cols} = ($code, @$line);
        if(ref($calcs[$i]) eq 'CODE') {
          $lab = $calcs[$i]->(\%item);
        }
        else {
          $Vend::Interpolate::item = \%item;
          $lab = tag_calc($calcs[$i]);
        }
      }

      $lab ||= $v;

      $lab = $Tag->filter($filter_show[$i], $lab, $cols[$i]);

      $lab =~ s/\[/&#91;/g;
      $out .= "<td$extra>$pre$lab$post</td>";

      $i++;
    }
    $out .= "</tr>\n";
    push @rows, $out;
  }

  unless(@rows) {
    my $nomsg = errmsg('No records');
    push @rows, qq{<tr><td colspan=$ncols><blockquote>$nomsg.</blockquote></td></tr>};
  }
  else {
    my $mmsg = errmsg($opt->{more_message} ||= 'More rows');
    $opt->{more_list} ||= <<EOF;
<tr>
<td colspan={NCOLS} align=center>
$mmsg: [decade-next][/decade-next] [more] [decade-prev][/decade-prev]
</td>
</tr>
EOF
    $opt->{more_list} =~ s/\{NCOLS\}/$ncols/g;
    my $override = { mv_data_table => $table, ui_meta_view => $mview };
    my @forms;
    my @formparms = qw/ mv_data_table ui_meta_view ui_meta_specific /;
    for(@formparms) {
      my $thing = $override->{$_} || $CGI->{$_};
      next unless length $thing;
      push @forms, "$_=$thing";
    }
    my $o = {
      object => $search,
      label => $opt->{label},
      form => join("\n", @forms),
    };
    $output{MORE_LIST} = tag_more_list(
                  $opt->{next_anchor},
                  $opt->{prev_anchor},
                  $opt->{page_anchor},
                  $opt->{more_border},
                  $opt->{more_border_selected},
                  $o,
                  $opt->{more_list},
                );
  }
}

$output{BOTTOM_OF_TABLE} = '</table>';
$output{BOTTOM_OF_FORM} = '</form>';
my $calc_sequence = <<'EOF';
ui_sequence_edit=[calc]
$CGI->{item_id_left} = $CGI->{item_id};
$CGI->{item_id_left} =~ s/\0+/,/g;
if($CGI->{item_id_left} =~ s/^(.*?),//) {
  $CGI->{item_id} = $1;
  return 1;
}
else {
  delete $CGI->{item_id_left};
  return '';
}
[/calc]
EOF
$calc_sequence .= "mv_nextpage=$edit_page\nmv_todo=return";
my $ebutton = $Tag->button(  
            {
              text => errmsg('Edit checked records in sequence'),
              extra => $opt->{edit_button_extra} || ' class=s2',
            },
            $calc_sequence,
          );
my $mbutton = '';
my $dbutton = '';
if($Tag->if_mm({ function => 'tables', table => "$table=d"}) ) {
  $opt->{confirm} ||= "Are you sure you want to delete the checked records?";
  my $dtext = qq{
[flag type=write table=$table]
deleterecords=1
mv_click=db_maintenance};
  $dbutton = '&nbsp;';
  $dbutton .= $Tag->button(  
            {
              text => errmsg('Delete checked records'),
              extra => $opt->{edit_button_extra} || ' class=s2',
              confirm => errmsg($opt->{confirm}),
            },
            $dtext,
          );
  
  if($opt->{user_merge}) {
    $opt->{confirm_merge} ||= "Are you sure you want to merge the checked users?";
    $mbutton = '&nbsp;';
    $mbutton .= $Tag->button(  
              {
                text => errmsg('Merge checked users'),
                extra => $opt->{merge_button_extra} || ' class=s2',
                confirm => errmsg($opt->{confirm_merge}),
              },
              '[user-merge]',
            );
      
  }
}
my $cboxes = '';

if($meta->{check_uncheck_all}) {
  my $uc_msg = errmsg('Uncheck all');
  my $ch_msg = errmsg('Check all');
  $ch_msg =~ s/\s/&nbsp;/g;
  $uc_msg =~ s/\s/&nbsp;/g;
  $cboxes = <<EOF;
<a href="javascript:checkAll(document.$opt->{form_name}, '$cb_name')">
$ch_msg
</a>&nbsp;&nbsp;
<a href="javascript:checkAll(document.$opt->{form_name}, '$cb_name', 1)">
$uc_msg
</a>&nbsp;&nbsp;
EOF
  $cboxes =~ s/\n//g;
}

if(! $opt->{no_checkbox} and ! $ts->{like_spec}) {
  unless($opt->{no_top} || $opt->{bottom_buttons}) {
    $output{TOP_BUTTONS} = $cboxes;
    $output{TOP_BUTTONS} .= $ebutton;
    if($mbutton) {
      $output{TOP_BUTTONS} .= '&nbsp;' x 4;
      $output{TOP_BUTTONS} .= $mbutton;
    }
    if($dbutton) {
      $output{TOP_BUTTONS} .= '&nbsp;' x 4;
      $output{TOP_BUTTONS} .= $dbutton;
    }
  }

  unless($opt->{no_bottom} || $opt->{top_buttons}) {
    $output{BOTTOM_BUTTONS} = $cboxes;
    $output{BOTTOM_BUTTONS} .= $ebutton;
    if($mbutton) {
      $output{BOTTOM_BUTTONS} .= '&nbsp;' x 4;
      $output{BOTTOM_BUTTONS} .= $mbutton;
    }
    if($dbutton) {
      $output{BOTTOM_BUTTONS} .= '&nbsp;' x 4;
      $output{BOTTOM_BUTTONS} .= $dbutton;
    }
  }
}

my %map = qw/
    TOP_OF_FORM      top_of_form
    BOTTOM_OF_FORM    bottom_of_form
    HIDDEN_FIELDS        hidden_fields
    TOP_BUTTONS          top_buttons
    BOTTOM_BUTTONS      bottom_buttons
    EXTRA_BUTTONS      extra_buttons
  /;

my @areas = qw/
        TOP_OF_TABLE
        TOP_OF_FORM
        HIDDEN_FIELDS
        TOP_BUTTONS 
        HEADER_AREA
        MAIN_BODY
        MORE_LIST
        BOTTOM_BUTTONS
        EXTRA_BUTTONS
        BOTTOM_OF_FORM
        BOTTOM_OF_TABLE
      /;
if($ts->{like_spec}) {
  push @rows, <<EOF;
<tr>
<td>&nbsp;</td>
<td colspan="$ncols" align=left>
[L]Check the box for exact record and enter the record id/key.[/L]
[L]Or enter a query by example to select a set of records.[/L]
[L]Each input will match on the <i>beginning</i> text in the field.[/L]
<p>
<small><input type=checkbox name=ui_exact_record value=1 class=s3> Edit \
 exact record in key column</small>
<br>
&nbsp;
</td>
</tr>
<tr>
<td>&nbsp;</td>
[loop list="[cgi ui_description_fields]"]
<td>
  <input type=hidden name=mv_like_field value="[loop-code]">
  <input type=text name=mv_like_spec size=10>
</td>
[/loop]
</tr>
<tr>
<td>&nbsp;</td>
<td colspan="$ncols" align=left>
&nbsp;
<br>
&nbsp;
<br>
<input type=submit value="[L]Find[/L]">
</td>
</tr>
EOF
}

$output{MAIN_BODY} = join "", @rows;

my @out;
for(@areas) {
  next unless $output{$_};
  if($opt->{ui_style} and $map{$_}) {
    my $op = $map{$_};
    $Tag->output_to($op, { name => $op }, $output{$_} );
  }
  else {
    push @out, $output{$_};
  }
}
return join "", @out;
}
EOR

SEE ALSO


Name

fly-list — display item in a flypage-like fashion

ATTRIBUTES

AttributePos.Req.DefaultDescription
code Yes item code
onfly
prefix item list prefix
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

Performs the flypage lookup function and displays the item as on the flypage.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

fly-list is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/fly_list.coretag
Lines: 15


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: fly_list.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag fly-list            Order        code
UserTag fly-list            addAttr
UserTag fly-list            hasEndTag
UserTag fly-list            PosNumber    2
UserTag fly-list            Version      $Revision: 1.4 $
UserTag fly-list            MapRoutine   Vend::Interpolate::fly_page

Source: lib/Vend/Interpolate.pm
Lines: 5103

sub fly_page {
my($code, $opt, $page) = @_;

my ($selector, $subname, $base, $listref);

return $page if (! $code and $Vend::Flypart eq $Vend::FinalPath);

$code = $Vend::FinalPath
  unless $code;

$Vend::Flypart = $code;

if ($subname = $Vend::Cfg->{SpecialSub}{flypage}) {
  my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname}; 
  $listref = $sub->($code);

  return unless defined $listref;

  if (ref $listref) {
    $base = $listref;
  }

  else {
    $code = $listref;
    $listref = { mv_results => [[$listref]] };
    $base = product_code_exists_ref($code);
  }
}
else {
  $listref = {mv_results => [[$code]]};
  $base = product_code_exists_ref($code);
}

#::logDebug("fly_page: code=$code base=$base page=" . substr($page, 0, 100));
return undef unless $base || $opt->{onfly};

$base = $Vend::Cfg->{ProductFiles}[0] unless $base;

  if($page) {
  $selector = 'passed in tag';
}
elsif(  $Vend::ForceFlypage ) {
  $selector = $Vend::ForceFlypage;
  undef $Vend::ForceFlypage;
}
elsif(  $selector = $Vend::Cfg->{PageSelectField}
    and db_column_exists($base,$selector)
  )
{
    $selector = database_field($base, $code, $selector)
}

$selector = find_special_page('flypage')
  unless $selector;
#::logDebug("fly_page: selector=$selector");

unless (defined $page) {
  unless( allowed_file($selector) ) {
    log_file_violation($selector, 'fly_page');
    return undef;
  }
  $page = readin($selector);
  if (defined $page) {
    vars_and_comments(\$page);
  } else {
    logError("attempt to display code=$code with bad flypage '$selector'");
    return undef;
  }
}

# This allows access from embedded Perl
$Tmp->{flycode} = $code;
# TRACK
$Vend::Track->view_product($code) if $Vend::Track;
# END TRACK

$opt->{prefix} ||= 'item';
# LEGACY
list_compat($opt->{prefix}, \$page) if $page;
# END LEGACY

return labeled_list( $opt, $page, $listref);
}

SEE ALSO


Name

fly-tax

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

fly-tax is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/fly_tax.coretag
Lines: 15


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: fly_tax.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag fly-tax             Order        area
UserTag fly-tax             PosNumber    1
UserTag fly-tax             AddAttr
UserTag fly-tax             attrAlias    space discount_space
UserTag fly-tax             Version      $Revision: 1.5 $
UserTag fly-tax             MapRoutine   Vend::Interpolate::fly_tax

Source: lib/Vend/Interpolate.pm
Lines: 5518

sub fly_tax {
my ($area, $opt) = @_;

if(my $country_check = $::Variable->{TAXCOUNTRY}) {
  $country_check =~ /\b$::Values->{country}\b/
    or return 0;
}

if(! $area) {
  my $zone = $Vend::Cfg->{SalesTax};
  while($zone =~ m/(\w+)/g) {
    last if $area = $::Values->{$1};
  }
}
#::logDebug("flytax area=$area");
return 0 unless $area;
my $rates = $::Variable->{TAXRATE};
my $taxable_shipping = $::Variable->{TAXSHIPPING} || '';
my $taxable_handling = $::Variable->{TAXHANDLING} || '';
$rates =~ s/^\s+//;
$rates =~ s/\s+$//;
$area =~ s/^\s+//;
$area =~ s/\s+$//;
my (@rates) = split /\s*,\s*/, $rates;
my $rate;
for(@rates) {
  my ($k,$v) = split /\s*=\s*/, $_, 2;
  next unless "\U$k" eq "\U$area";
  $rate = $v;
  $rate = $rate / 100 if $rate > 1;
  last;
}
#::logDebug("flytax rate=$rate");
return 0 unless $rate;

my ($oldcart, $oldspace);
if ($opt->{cart}) {
  $oldcart = $Vend::Items;
  tag_cart($opt->{cart});
}
if ($opt->{discount_space}) {
  $oldspace = switch_discount_space($opt->{discount_space});
}

my $amount = taxable_amount();
#::logDebug("flytax before shipping amount=$amount");
$amount   += tag_shipping()
  if $taxable_shipping =~ m{(^|[\s,])$area([\s,]|$)}i;
$amount   += tag_handling()
  if $taxable_handling =~ m{(^|[\s,])$area([\s,]|$)}i;

$Vend::Items = $oldcart if defined $oldcart;
switch_discount_space($oldspace) if defined $oldspace;

#::logDebug("flytax amount=$amount return=" . $amount*$rate);
return $amount * $rate;
}

SEE ALSO


Name

form-session-id — insert hidden form field containing the session ID

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

It is necessary to include the Interchange session ID on HTML forms when users are not accepting cookies, or they might lose the session information. The form-session-id tag inserts the appropriate hidden form field containing session ID on a page, but only when necessary.

In most cases, the tag will insert the hidden form field (that is, when users are not accepting cookies or public display of session IDs — no_session_id — is not disabled). It will not, however, insert the field if the user is accepting browser cookies and no_session_id is enabled.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Simple form with an optional session ID form field

Here's a very simple login form. As you can see, all you have to do to include the session ID on the form is to include form-session-id somewhere in it.

<form action="[process secure=1]" method="POST">
  <input type="hidden" name="mv_todo"  value="return">
  <input type="hidden" name="mv_click" value="Login">
  <input type="hidden" name="mv_failpage" value="login">
  <input type="hidden" name="mv_successpage" value="[either][scratchd mv_successpage][or]member/service[/either]">
  <input type="hidden" name="mv_nextpage" value="index">
  [form-session-id]

  [L]Username[/L]: <input name="mv_username" value="[scratch cookie_username]"><br/>
  [L]Password[/L]: <input type="password" name="mv_password" VALUE=""><br/>
  <input class="button3" type=submit value="[L]Log In[/L]">
</form>

NOTES

AVAILABILITY

form-session-id is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/form_session_id.coretag
Lines: 16


# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: form_session_id.coretag,v 1.3 2007-03-30 23:40:49 pajamian Exp $

UserTag form-session-id Version $Revision: 1.3 $
UserTag form-session-id Routine <<EOR
sub {
return if $Vend::Cookie and $::Scratch->{mv_no_session_id};
return qq{<input type="hidden" name="mv_session_id" value="$Vend::SessionID"$Vend::Xtrailer>};
}
EOR

SEE ALSO


Name

formel — generate HTML form elements

ATTRIBUTES

AttributePos.Req.DefaultDescription
label YesYes User-visible description of the form element's purpose or intended use.
name YesYes  Name to assign to this form element (appears as name parameter to the appropriate HTML tag).
type YesYes  Form element type. Supported HTML element types are text, textarea, checkbox, radio and select. Special value of display does not produce any form element but simply displays the element value in a label.
size     Usually the width of an element. For the textarea type, you can specify width and height in form of "AxB", "A,B" or "A B".
cause    Format string for the error message. If set, the error message is appended to the label. (%s) is a reasonable value.
checkfor   The element's name value. Name to pass to the error tag.
choices     Comma-separated list of choices for the checkbox, radio or select elements. To display labels different from the values, use the value1=label1 notation.
format   %s %s %s The container format string for the label, form element and help text.
help     Help text for the element. If the user was to input, say, an username, you could set the help field to alphanumeric (5-10 characters)
maxlength    The maxlength attribute for the HTML form element.
order   0 If not set, the user-visible description comes first (before the form element) in the output.
reset   0Discard any previous element value?
signal   <span class="mv_contrast">%s</span> Label container in case of errors. If the CSS_CONTRAST variable is defined, it is used instead of the mv_contrast class name.
table     Database name to pass to the display tag. Of course, this is only used with the display form "element".

DESCRIPTION

This tag creates HTML form elements. formel consults the value namespace for defaults, thus preserving user input from previous HTML forms. It also keeps track of input errors (using the error tag).

The error messages will be displayed according to the mv_contrast CSS class (or the class defined in the CSS_CONTRAST variable).

Note that you can define values to control this tag's defaults. See the section called “EXAMPLES”.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: CSS_CONTRAST

EXAMPLES

Example: Define tag defaults with form values

[value name="mv_formel_cause"  set=" (<I>%s</I>)" hide=1]
[value name="mv_formel_format" set="<tr><td>%s</td><td>%s</td></tr>" hide=1]
[value name="mv_formel_order"  set=1 hide=1]
[value name="mv_formel_signal" set="<blink>%s</blink>" hide=1]

Note that the values, once you set them, remain persistent during the user's session.


Example: Change indicator for errors

[formel label=Username name=username signal="<b>%s</b>"]

Example: Displaying the label and form element in two passes

If you had specific requirements, you could, by using a little trickery, display the form element label and the element itself in two passes:

[formel label=Username: name=login format="%s"]
[formel name=login order=1 format="%s"]

NOTES

AVAILABILITY

formel is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/formel.tag
Lines: 203


# Copyright 2002-2007 Interchange Development Group and others
# Copyright 2002-2005 Stefan Hornburg (racke@linuxia.de)
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: formel.tag,v 1.19 2007-08-01 10:52:44 kwalsh Exp $

UserTag formel Order   label name type size
UserTag formel addAttr
UserTag formel Version $Revision: 1.19 $
UserTag formel Routine <<EOF
sub {
my ($label, $name, $type, $size, $opt) = @_;
my ($labelhtml, $elhtml, $fmt);
my $checkfor = $opt->{'checkfor'} || $name;
my $sizestr = '';
my $labelproc;

$labelproc = sub {
  my ($label, $keep) = @_;
  my ($error);

  if ($opt->{cause}) {
    if ($error = $Tag->error({name => $checkfor, keep => 1})) {
      $label .= $Tag->error({name => $checkfor, keep => $keep, 
          text => $opt->{cause}});
    }
}
else {
$error = $Tag->error({name => $checkfor, keep => $keep});
}

if ($error) {
if ($opt->{signal}) {
  sprintf($opt->{signal}, $label);
}
else {
  my $contrast = $::Variable->{CSS_CONTRAST} || 'mv_contrast';
  qq{<span class="$contrast">$label</span>};
}  
}
else {      
    $label;
  }
};

# set defaults
$type = 'text' unless $type;

for ('cause', 'format', 'order', 'reset', 'signal', 'size') {
  next if $opt->{$_};
  if ($::Values->{"mv_formel_$_"}) {
    $opt->{$_} = $::Values->{"mv_formel_$_"};
  }   
}

if ($opt->{'format'}) {
  $fmt = $opt->{'format'};
}
else {
  $fmt = '%s %s %s';
}

if ($opt->{'size'}) {
  if ($type eq 'textarea') {
    my ($cols, $rows) = split (/\s*[,x\s]\s*/, $opt->{'size'});
    $sizestr = qq{ rows="$rows" cols="$cols"};
  }
  else {
    $sizestr = qq{ size="$opt->{size}"};
  }
}

if ($opt->{'maxlength'}) {
  $sizestr .= qq{ maxlength="$opt->{maxlength}"};
}

if ($type eq 'radio' || $type eq 'checkbox') {    
  my ($rlabel, $rvalue, $select, @vals);
  
  if ($type eq 'checkbox') {
    @vals = split(/\0/, $::Values->{$name});
  }

  for my $button (split (/\s*,\s*/, $opt->{choices})) {
    $select = '';
    if ($button =~ /^(.*?)=(.*)$/) {
      $rvalue = $1;
      $rlabel = $2;
    }
    else {
      $rvalue = $rlabel = $button;
    }

    if ($type eq 'checkbox') {
      # multiple values possible for checkboxes
      for my $val (@vals) {
        if ($val eq $rvalue) {
          $select = 'checked';
          last;
        }
      }
    } elsif ($::Values->{$name} eq $rvalue) {
      $select = ' checked';
    }

    $rlabel = &$labelproc($rlabel, 1);

    $elhtml .= qq{<input type="$type" name="$name" value="${rvalue}"$select \
 $Vend::Xtrailer> $rlabel};
  }
  # delete error implicitly
  $labelhtml = &$labelproc($label);
  return sprintf ($fmt, $labelhtml, $elhtml);
}

$labelhtml = &$labelproc($label) if $label || $type ne 'display';

if ($type eq 'select') {
  my ($rlabel, $rvalue, $select);

  for my $option (split (/\s*,\s*/, $opt->{choices})) {
    $select = '';
    if ($option =~ /^(.*?)=(.*)$/) {
      $rvalue = $1;
      $rlabel = $2;
    }
    else {
      $rvalue = $rlabel = $option;
    }

    if ($::Values->{$name} eq $rvalue) {
      $select = ' selected="selected"';
    }
    if ($rvalue eq $rlabel) {  
      $elhtml .= qq{<option $select>$rlabel</option>};
    }
    else {
      $elhtml .= qq{<option value="$rvalue"$select>$rlabel</option>};
    }
  }
  return sprintf ($fmt, $labelhtml, 
      qq{<select name="$name">$elhtml</select>});
}

if ($type eq 'display') {
  if ($label) {
    # use provided label
    $elhtml = $Tag->display($opt->{table} || 'products', $name, '', 
        {value => $Values->{$name}});
  }
  else {
    # use dummy template to retrieve label from metadata
    $elhtml = $Tag->display($opt->{table} || 'products', $name, '', 
        {value => $Values->{$name}, 
        template => join(" \0", '$LABEL$', '$WIDGET$')});
    ($label, $elhtml) = split(/\s\0/, $elhtml);
    $labelhtml = &$labelproc($label);
  }
} elsif ($opt->{reset}) {
  if ($type eq 'textarea') {
    $elhtml = qq{<textarea name="${name}"$sizestr></textarea>};
  }
  else {
    $elhtml = qq{<input type="$type" name="${name}"$sizestr $Vend::Xtrailer>};
  }
}
else {
  if ($type eq 'textarea') {
    $elhtml = qq{<textarea name="${name}"$sizestr>$::Values->{$name}</textarea>};

  }
  elsif ($type eq 'text' || $type eq 'password' || $type !~ /\S/) {
    $elhtml = qq{<input type="$type" name="$name" value="$::Values->{$name}"$sizestr \
 $Vend::Xtrailer>};
  }
  else {
    # pass type directly to display tag
    if ($opt->{order}) {
      $fmt = sprintf($fmt, '$WIDGET$', '$LABEL$', $opt->{help});
    } else {
      $fmt = sprintf($fmt, '$LABEL$', '$WIDGET$', $opt->{help});
    }

    return $Tag->display({name => $name,
             type => $type,
             label => $label,
             value => $Values->{$name},
             template => $fmt});
  }
}

if ($opt->{order}) {
  # display form element first
  sprintf ($fmt, $elhtml, $labelhtml, $opt->{help});
}
else {
  # display label first
  sprintf ($fmt, $labelhtml, $elhtml, $opt->{help});
}
}
EOF


Name

fortune — use the "fortune" program to display random saying

ATTRIBUTES

AttributePos.Req.DefaultDescription
short Yes 0Display only short (less than 160 characters) fortune sayings?
no-computer   0 Prevent display of computer-related fortunes?
a   1Select random of all (potentially offensive) fortunes.
o   0Select only offensive fortunes.
raw   0Don't apply basic HTML formating to the text output from the fortune program?

DESCRIPTION

The fortune tag calls the popular Unix fortune program to display random saying.

If no raw option is specified, basic HTML formatting is applied to the output (using the <filter>text2html</filter> Interchange filter).

The fortune program path defaults to /usr/games/fortune. You can override that by setting the MV_FORTUNE_COMMAND variable.

Any single-character option supported by the fortune program can be passed to this tag. See fortune manual page for more information.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: MV_FORTUNE_COMMAND

EXAMPLES

Example: Display short fortune saying

Put the following on your page:

[fortune 1]

NOTES

AVAILABILITY

fortune is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/fortune.tag
Lines: 57


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: fortune.tag,v 1.7 2007-03-30 23:40:57 pajamian Exp $

UserTag fortune Order   short
UserTag fortune addAttr
UserTag fortune Version $Revision: 1.7 $
UserTag fortune Routine <<EOR
sub {
my ($short, $opt) = @_;
my $cmd = $Global::Variable->{MV_FORTUNE_COMMAND} || '/usr/games/fortune';
my @flags;
push @flags, '-s' if is_yes($short);
for(grep length($_) == 1, keys %$opt) {
push @flags, "-$_" if $opt->{$_};
}

if(is_yes($opt->{no_computer}) ) {
  push @flags, qw/
    6% education 
    6% food 
    6% humorists 
    6% kids 
    6% law 
    6% literature 
    6% love 
    6% medicine 
    6% people 
    6% pets 
    6% platitudes 
    6% politics 
    6% science 
    6% sports 
    6% work
    10% wisdom
    /;
}

my $out = '';
open(FORT, '-|') || exec ($cmd, @flags);

while (<FORT>) {
  $out .= $_
}

unless($opt->{raw}) {
  $out = filter_value('text2html', $out);
  $out =~ s/--(?!:.*--)/<br>--/s;
}
return $out;
}
EOR

SEE ALSO


Name

forum — display forum threads

ATTRIBUTES

AttributePos.Req.DefaultDescription
header_template
link_template
threshold_message
scrub_template
template
reply_page
submit_page
display_page
date_format
full
scrub_score
show_score
show_level
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: MV_PAGE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

forum is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/forum.tag
Lines: 264


# Copyright 2002-2010 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag forum-userlink PosNumber 0
UserTag forum-userlink addAttr
UserTag forum-userlink Version   1.7
UserTag forum-userlink Routine   <<EOR
sub {
my ($row) = @_;
return $row->{name} || $Variable->{FORUM_ANON_NAME} || 'Anonymous Coward'
if $row->{anon} or ! $row->{username};
my $realname = tag_data('userdb', 'handle', $row->{username})
    || tag_data('userdb', 'fname', $row->{username});
return $realname || $row->{username};
}
EOR

UserTag forum Order     top
UserTag forum addAttr 
UserTag forum hasEndTag 
UserTag forum NoReparse 1
UserTag forum Version   1.7
UserTag forum Routine   <<EOR
my @uls;
my $lastlevel;

sub {
my ($id, $opt, $tpl) = @_;

if(! $id) {
 $id = '0';
}

my $forum_header;
my $forum_footer;
my $forum_link;
my $forum_scrub;

$tpl ||= '';
$tpl =~ s{\[forum[-_]header\](.*)\[/forum[-_]header\]}{}is
 and $forum_header = $1;
$tpl =~ s{\[forum[-_]footer\](.*)\[/forum[-_]footer\]}{}is
 and $forum_footer = $1;
$tpl =~ s{\[forum[-_]link\](.*)\[/forum[-_]link\]}{}is
 and $forum_link = $1;
$tpl =~ s{\[forum[-_]scrub\](.*)\[/forum[-_]scrub\]}{}is
 and $forum_scrub = $1;

$forum_header ||= $opt->{header_template} || <<EOF;
<table>
<tr>
<td class=contentbar1>
 <b>{SUBJECT}</b>
 by <b>{USERINFO}</b>
 on {DATE}
</td>
</tr>
<tr>
<td>
 {COMMENT}
</td>
</tr>
{ADDITIONAL?}
<tr>
<td>
 {ADDITIONAL}
</td>
</tr>
{/ADDITIONAL?}
<tr>
 <td>
  &#91; 
   {TOP_URL?}<A HREF="{TOP_URL}">Top</A> |{/TOP_URL?}
   {PARENT_URL?}<A HREF="{PARENT_URL}">Parent</A> |{/PARENT_URL?}
   <A HREF="{REPLY_URL}">Reply</A>
  &#93; 
 </td>
</tr>
</table>
<hr>
EOF

$forum_link ||= $opt->{link_template} || <<EOF;
<A HREF="{DISPLAY_URL}">{SUBJECT}</a> by {USERINFO} on {DATE}
EOF

$opt->{threshold_message} ||= errmsg("Message below your threshold");
$forum_scrub ||= $opt->{scrub_template} || <<EOF;
<A HREF="{DISPLAY_URL}">$opt->{threshold_message}</a>
EOF

$tpl ||= $opt->{template} || <<EOF;
<table cellspacing=0 cellpadding=2>
<tr>
<td class=contentbar1>
 <A HREF="{DISPLAY_URL}"><b>{SUBJECT}</b></A>
 by <b>{USERINFO}</b>
 on {DATE}
</td>
<td class=contentbar1 align=right>
 <small>&#91; <A HREF="{REPLY_URL}"><b>Reply</b></A> &#93;</font></small>
</td>
</tr>
<tr>
<td colspan=2>
{COMMENT}
<!--
 prior to UL: {MSG1}
 prior to /UL: {MSG2}
 prior to END: {MSG3}
-->
</td>
</tr>
</table>
EOF

$forum_footer ||= <<EOF;
<!-- end of forum -->
EOF

my $lastlevel = 0;
my @uls;

my $Tag = new Vend::Tags;
my $row = shift;

$opt->{reply_page} ||= 'forum/reply';
$opt->{submit_page} ||= 'forum/submit';
$opt->{display_page} ||= $Global::Variable->{MV_PAGE};
$opt->{date_format} ||= '%B %e, %Y @%H:%M';
my $menu_row = sub {
shift;
my $row = shift;
 $row->{reply_url} = $Tag->area({
                 href => $opt->{reply_page},
                 arg => $row->{code},
               });
 if($row->{code} ne $row->{artid}) {
   $row->{top_url} = $Tag->area( {
                 href => $opt->{display_page},
                 arg => $row->{artid},
               });
 }
 if($row->{parent}) {
   $row->{parent_url} = $Tag->area( {
                 href => $opt->{display_page},
                 arg => $row->{parent},
               });
 }
 $row->{display_url} = $Tag->area({
               href => $opt->{display_page},
               arg => $row->{code},
               });
 $row->{userinfo} = $Tag->forum_userlink($row);
 $row->{date} = $Tag->convert_date({
                 fmt => $opt->{date_format},
                 body => $row->{created},
               });
 my $lev = $row->{mv_level};
 my $children = $row->{mv_children};
 my $last = $row->{mv_last};
 my $pre = '';
 my $post = '';
 my $num_uls = scalar(@uls);
 $row->{msg1} = "lastlevel=$lastlevel lev=$lev children=$children uls=$num_uls";
 if(! $lev) {
   $pre .= join "", splice (@uls);
 }
 elsif ($lastlevel < $lev) {
   $lastlevel = $lev;
 }
 elsif ($lastlevel > $lev) {
   $lastlevel = $lev;
   $pre .= join "", splice (@uls,$lev);
 }
 if($children) {
   push @uls, '</ul>';
 }
 $num_uls = scalar(@uls);
 $row->{msg2} = "lastlevel=$lastlevel lev=$lev children=$children uls=$num_uls";
 if($children) {
   $post .= '<ul>';
 }
 elsif($last) {
   $post .= join "", splice (@uls, $lev);
 }
 $num_uls = scalar(@uls);
 $row->{msg3} = "lastlevel=$lastlevel lev=$lev children=$children uls=$num_uls";
 $row->{forum_prepend} = $pre;
 $row->{forum_append} = $post;
 return $row;
};

my $fdb = database_exists_ref('forum')
 or die "No forum DB!";

my $record = $fdb->row_hash($id);
return undef unless $record;

$menu_row->(undef, $record);
my @out;

$opt->{full} = 1 if ! defined $opt->{full};

push @out, $Tag->uc_attr_list($record, $forum_header);

my %o = (
 table      => 'forum',
 start      => $id,
 master    => 'parent',
 subordinate  => 'code',
 full      => $opt->{full},
 sort      => $opt->{sort} || 'code',
 spacer    => "&nbsp;",
 autodetect  => 1,
 iterator    => $menu_row,
 spacing    => 4,
);

$Tag->tree(\%o);

my $rows = $o{object}{mv_results};
$opt->{scrub_score} ||= 0;
$opt->{show_score} ||= 1;
if(! defined $opt->{show_level}) {
 if($record->{code} == $record->{artid}) {
   $opt->{show_level} = 0;
 }
 else {
   $opt->{show_level} = 2;
 }
}

for(\$tpl, \$forum_link, \$forum_scrub) {
 $$_ = "{FORUM_PREPEND}$$_" unless $$_ =~ /\{FORUM_PREPEND\}/;
 $$_ .= '{FORUM_APPEND}' unless $$_ =~ /\{FORUM_APPEND\}/;
}

for my $record (@$rows) {

 my $this_tpl;
 if($record->{score} <= $opt->{scrub_score}) {
   $this_tpl = $forum_scrub;
 }
 elsif($record->{score} >= $opt->{show_score}) {
   $this_tpl = $tpl;
 }
 elsif($record->{mv_level} <= $opt->{show_level}) {
   $this_tpl = $tpl;
 }
 else {
   $this_tpl = $forum_link;
 }
 push @out, $Tag->uc_attr_list($record, $this_tpl);
}
push @out, join "", @uls;
push @out, $Tag->uc_attr_list($opt, $forum_footer);
return join "\n", @out;
}
EOR

SEE ALSO


Name

forum-userlink

ATTRIBUTES

AttributePos.Req.DefaultDescription
header_template
link_template
threshold_message
scrub_template
template
reply_page
submit_page
display_page
date_format
full
scrub_score
show_score
show_level
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: FORUM_ANON_NAME

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

forum-userlink is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/forum.tag
Lines: 264


# Copyright 2002-2010 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag forum-userlink PosNumber 0
UserTag forum-userlink addAttr
UserTag forum-userlink Version   1.7
UserTag forum-userlink Routine   <<EOR
sub {
my ($row) = @_;
return $row->{name} || $Variable->{FORUM_ANON_NAME} || 'Anonymous Coward'
if $row->{anon} or ! $row->{username};
my $realname = tag_data('userdb', 'handle', $row->{username})
     || tag_data('userdb', 'fname', $row->{username});
return $realname || $row->{username};
}
EOR

UserTag forum Order     top
UserTag forum addAttr 
UserTag forum hasEndTag 
UserTag forum NoReparse 1
UserTag forum Version   1.7
UserTag forum Routine   <<EOR
my @uls;
my $lastlevel;

sub {
my ($id, $opt, $tpl) = @_;

if(! $id) {
  $id = '0';
}

my $forum_header;
my $forum_footer;
my $forum_link;
my $forum_scrub;

$tpl ||= '';
$tpl =~ s{\[forum[-_]header\](.*)\[/forum[-_]header\]}{}is
  and $forum_header = $1;
$tpl =~ s{\[forum[-_]footer\](.*)\[/forum[-_]footer\]}{}is
  and $forum_footer = $1;
$tpl =~ s{\[forum[-_]link\](.*)\[/forum[-_]link\]}{}is
  and $forum_link = $1;
$tpl =~ s{\[forum[-_]scrub\](.*)\[/forum[-_]scrub\]}{}is
  and $forum_scrub = $1;

$forum_header ||= $opt->{header_template} || <<EOF;
<table>
<tr>
<td class=contentbar1>
  <b>{SUBJECT}</b>
  by <b>{USERINFO}</b>
  on {DATE}
</td>
</tr>
<tr>
<td>
  {COMMENT}
</td>
</tr>
{ADDITIONAL?}
<tr>
<td>
  {ADDITIONAL}
</td>
</tr>
{/ADDITIONAL?}
<tr>
  <td>
   &#91; 
    {TOP_URL?}<A HREF="{TOP_URL}">Top</A> |{/TOP_URL?}
    {PARENT_URL?}<A HREF="{PARENT_URL}">Parent</A> |{/PARENT_URL?}
    <A HREF="{REPLY_URL}">Reply</A>
   &#93; 
  </td>
</tr>
</table>
<hr>
EOF

 $forum_link ||= $opt->{link_template} || <<EOF;
<A HREF="{DISPLAY_URL}">{SUBJECT}</a> by {USERINFO} on {DATE}
EOF

 $opt->{threshold_message} ||= errmsg("Message below your threshold");
 $forum_scrub ||= $opt->{scrub_template} || <<EOF;
<A HREF="{DISPLAY_URL}">$opt->{threshold_message}</a>
EOF

$tpl ||= $opt->{template} || <<EOF;
<table cellspacing=0 cellpadding=2>
<tr>
<td class=contentbar1>
  <A HREF="{DISPLAY_URL}"><b>{SUBJECT}</b></A>
  by <b>{USERINFO}</b>
  on {DATE}
</td>
<td class=contentbar1 align=right>
  <small>&#91; <A HREF="{REPLY_URL}"><b>Reply</b></A> &#93;</font></small>
</td>
</tr>
<tr>
<td colspan=2>
{COMMENT}
<!--
  prior to UL: {MSG1}
  prior to /UL: {MSG2}
  prior to END: {MSG3}
-->
</td>
</tr>
</table>
EOF

$forum_footer ||= <<EOF;
<!-- end of forum -->
EOF

my $lastlevel = 0;
my @uls;

my $Tag = new Vend::Tags;
my $row = shift;

$opt->{reply_page} ||= 'forum/reply';
$opt->{submit_page} ||= 'forum/submit';
$opt->{display_page} ||= $Global::Variable->{MV_PAGE};
$opt->{date_format} ||= '%B %e, %Y @%H:%M';
my $menu_row = sub {
shift;
my $row = shift;
  $row->{reply_url} = $Tag->area({
                  href => $opt->{reply_page},
                  arg => $row->{code},
                });
  if($row->{code} ne $row->{artid}) {
    $row->{top_url} = $Tag->area( {
                  href => $opt->{display_page},
                  arg => $row->{artid},
                });
  }
  if($row->{parent}) {
    $row->{parent_url} = $Tag->area( {
                  href => $opt->{display_page},
                  arg => $row->{parent},
                });
  }
  $row->{display_url} = $Tag->area({
                href => $opt->{display_page},
                arg => $row->{code},
                });
  $row->{userinfo} = $Tag->forum_userlink($row);
  $row->{date} = $Tag->convert_date({
                  fmt => $opt->{date_format},
                  body => $row->{created},
                });
  my $lev = $row->{mv_level};
  my $children = $row->{mv_children};
  my $last = $row->{mv_last};
  my $pre = '';
  my $post = '';
  my $num_uls = scalar(@uls);
  $row->{msg1} = "lastlevel=$lastlevel lev=$lev children=$children uls=$num_uls";
  if(! $lev) {
    $pre .= join "", splice (@uls);
  }
  elsif ($lastlevel < $lev) {
    $lastlevel = $lev;
  }
  elsif ($lastlevel > $lev) {
    $lastlevel = $lev;
    $pre .= join "", splice (@uls,$lev);
  }
  if($children) {
    push @uls, '</ul>';
  }
  $num_uls = scalar(@uls);
  $row->{msg2} = "lastlevel=$lastlevel lev=$lev children=$children uls=$num_uls";
  if($children) {
    $post .= '<ul>';
  }
  elsif($last) {
    $post .= join "", splice (@uls, $lev);
  }
  $num_uls = scalar(@uls);
  $row->{msg3} = "lastlevel=$lastlevel lev=$lev children=$children uls=$num_uls";
  $row->{forum_prepend} = $pre;
  $row->{forum_append} = $post;
  return $row;
};

my $fdb = database_exists_ref('forum')
  or die "No forum DB!";

my $record = $fdb->row_hash($id);
return undef unless $record;

$menu_row->(undef, $record);
my @out;

$opt->{full} = 1 if ! defined $opt->{full};

push @out, $Tag->uc_attr_list($record, $forum_header);

my %o = (
  table      => 'forum',
  start      => $id,
  master    => 'parent',
  subordinate  => 'code',
  full      => $opt->{full},
  sort      => $opt->{sort} || 'code',
  spacer    => "&nbsp;",
  autodetect  => 1,
  iterator    => $menu_row,
  spacing    => 4,
);

$Tag->tree(\%o);

my $rows = $o{object}{mv_results};
$opt->{scrub_score} ||= 0;
$opt->{show_score} ||= 1;
if(! defined $opt->{show_level}) {
  if($record->{code} == $record->{artid}) {
    $opt->{show_level} = 0;
  }
  else {
    $opt->{show_level} = 2;
  }
}

for(\$tpl, \$forum_link, \$forum_scrub) {
  $$_ = "{FORUM_PREPEND}$$_" unless $$_ =~ /\{FORUM_PREPEND\}/;
  $$_ .= '{FORUM_APPEND}' unless $$_ =~ /\{FORUM_APPEND\}/;
}

for my $record (@$rows) {

  my $this_tpl;
  if($record->{score} <= $opt->{scrub_score}) {
    $this_tpl = $forum_scrub;
  }
  elsif($record->{score} >= $opt->{show_score}) {
    $this_tpl = $tpl;
  }
  elsif($record->{mv_level} <= $opt->{show_level}) {
    $this_tpl = $tpl;
  }
  else {
    $this_tpl = $forum_link;
  }
  push @out, $Tag->uc_attr_list($record, $this_tpl);
}
push @out, join "", @uls;
push @out, $Tag->uc_attr_list($opt, $forum_footer);
return join "\n", @out;
}
EOR

SEE ALSO


Name

get-gpg-keys — lists GPG keys

ATTRIBUTES

AttributePos.Req.DefaultDescription
dir Yes No GPG home directory
long include date and id in output
joiner
none
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: GPG_PATH

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

get-gpg-keys is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/get_gpg_keys.coretag
Lines: 46


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: get_gpg_keys.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag get-gpg-keys Order    dir
UserTag get-gpg-keys addAttr
UserTag get-gpg-keys Version  $Revision: 1.5 $
UserTag get-gpg-keys Routine  <<EOR
sub {
my ($dir, $opt) = @_;
my $gpgexe = $Global::Variable->{GPG_PATH} || 'gpg';

my $flags = "--list-keys";
if($dir) {
$dir = filter_value('filesafe', $dir);
  $flags .= "--homedir $dir";
}
#::logDebug("gpg_get_keys flags=$flags");

open(GPGIMP, "$gpgexe $flags |") 
  or die "Can't fork: $!";

my $fmt = $opt->{long} ?  "%s=%s (date %s, id %s)" : "%s=%s";

my @out;
while(<GPGIMP>) {
  next unless s/^pub\s+//;
  my ($id, $date, $text) = split /\s+/, $_, 3;
  $id =~ s:.*?/::;
  $text = ::errmsg( $fmt, $id, $text, $date, $id );
  $text =~ s/</&lt;/g;
  $text =~ s/>/&gt;/g;
  $text =~ s/,/&#44;/g;
  push @out, $text;
}
close GPGIMP;
my $joiner = $opt->{joiner} || ",\n";
unshift @out, "=none" if $opt->{none};
return join($joiner, @out);
}
EOR

SEE ALSO


Name

get-url — dispatch HTTP request and return response

ATTRIBUTES

AttributePos.Req.DefaultDescription
url YesYes URL to fetch.
method   GETForm method. Can be one of GET, POST, HEAD or PUT.
strip   0If set, delete everything before <body> and after </body> prior to returning contents.
content_type   application/x-www-form-urlencodedMIME content type.
content     CGI to pass. If you want to use this, the form method should be POST or PUT. The list can be ampersand-separated, like fname=Brev&lname=Patterson&state=UT, and to URL-encode the variables themselves, use [filter op=urlencode]. The form, however, does not need to be URL-encoded, see the section called “EXAMPLES”.
authuser    Username to send for authentication.
authpass    Password to send for authentication.
useragent    The User Agent string (in other words, your "browser" identification).
timeout   180Set timeout for the operation. Timeout can be specified as a valid interval (such as "3 min").
scratch   NoneStore result in the named scratch variable instead of returning it.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

Dispatches HTTP request for the URI supplied with the url parameter.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example:

[get-url
  url="valid_url"
  method="POST"
  strip=1
  content_type="application/x-www-form-urlencoded"
  content="name=Brev"
  authuser="username"
  authpass="password"
  useragent="useragent string"
]

[get-url
  url="http://www.icdevgroup.org"
  method=POST
  form=|
    foo=bar
    buz=baz
    boo=The red's the thing.
  |
]

NOTES

get-url is just a thin wrapper around LWP::UserAgent. Therefore the default for the timeout parameter is imposed by this module.

AVAILABILITY

get-url is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/get_url.tag
Lines: 87


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: get_url.tag,v 1.12 2007-12-05 00:38:03 racke Exp $

UserTag get-url Order        url
UserTag get-url AddAttr
UserTag get-url Interpolate
UserTag get-url Version      $Revision: 1.12 $
UserTag get-url Routine      <<EOR
require LWP::UserAgent;
sub {
my ($url, $opt) = @_;
my $html = '';
my $method;

my $ua = LWP::UserAgent->new;

if($opt->{method}) { 
  $method = uc($opt->{method});
} else {
  $method = 'GET';
}

  if($opt->{timeout}) {
  my $to = Vend::Config::time_to_seconds($opt->{timeout});
  $ua->timeout($to);
}

if($opt->{useragent} ) {
    $ua->agent($opt->{useragent});
}

if($opt->{form}) {
  $opt->{content} = Vend::Interpolate::escape_form($opt->{form});
}

my $do_content;

if ($opt->{content}) {
  if ($method eq 'POST' || $method eq 'PUT') {
    $opt->{content_type} ||= 'application/x-www-form-urlencoded';
    $do_content = 1;
  } 
  else {
    $url .= $opt->{url} =~ /\?/ ? '&' : '?';
    $url .= $opt->{content};
  }
}

my $req = HTTP::Request->new($method, $url);

if($do_content) {
  $req->content_type($opt->{content_type});
  $req->content($opt->{content});
}

if($opt->{authuser} && $opt->{authpass}) {
  $req->authorization_basic($opt->{authuser}, $opt->{authpass});
}


my $res = $ua->request($req);

if ($res->is_success) {
  $html .= $res->content;
} else {
  $html .= "Failed - " . $res->status_line;
}

if($opt->{strip}) {
  $html =~ s/.*<body[^>]*>//si;
  $html =~ s:</body>.*::si;
}

if ($opt->{scratch}) {
  $::Scratch->{$opt->{scratch}} = $html;
  return;
}

return $html;
}
EOR

SEE ALSO


Name

global-value

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

global-value is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/global_value.coretag
Lines: 19


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: global_value.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag  global-value  Order   name
UserTag  global-value  Version $Revision: 1.5 $
UserTag  global-value  Routine <<EOR
sub {
my $thing = shift;
no strict 'refs';
return '' unless defined ${$thing};
return ${$thing};
}
EOR

SEE ALSO


Name

grep-mm

ATTRIBUTES

AttributePos.Req.DefaultDescription
table
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

grep-mm is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/grep_mm.coretag
Lines: 25


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: grep_mm.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag grep-mm Order        function
UserTag grep-mm addAttr
UserTag grep-mm Interpolate
UserTag grep-mm hasEndTag
UserTag grep-mm Version      $Revision: 1.4 $
UserTag grep-mm Routine      <<EOR
sub {
my($func, $opt, $text) = @_;
#::logDebug("grep-mm record: " . Vend::Util::uneval_it(\@_));
my $table = $opt->{table} || $::Values->{mv_data_table};
my $acl = UI::Primitive::get_ui_table_acl($table);
return $text unless $acl;
my @items = grep /\S/, Text::ParseWords::shellwords($text);
return join "\n", UI::Primitive::ui_acl_grep($acl, $func, @items);
}
EOR


Name

handling — calculate and display handling costs

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ mode | modes | name ] Yes  .
[ cart | carts ]    .
[ table | tables ]    .
noformatYesNoNoOutput plain number instead of formatting it according to the currency locale?
convert    .
default    .
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

handling is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/handling.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: handling.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag handling            Order        mode
UserTag handling            addAttr
UserTag handling            attrAlias    tables table
UserTag handling            attrAlias    carts cart
UserTag handling            attrAlias    modes mode
UserTag handling            attrAlias    name mode
UserTag handling            PosNumber    1
UserTag handling            Version      $Revision: 1.5 $
UserTag handling            MapRoutine   Vend::Interpolate::tag_handling

Source: lib/Vend/Interpolate.pm
Lines: 5232

*tag_handling = \&Vend::Ship::tag_handling;

Source: lib/Vend/Ship.pm
Lines: 1008

sub tag_handling {
my ($mode, $opt) = @_;
$opt = { noformat => 1, convert => 1 } unless $opt;

if($opt->{default}) {
  undef $opt->{default}
    if tag_shipping( undef, {handling => 1});
}

$opt->{handling} = 1;
if(! $mode) {
  $mode = $::Values->{mv_handling} || undef;
}
return tag_shipping($mode, $opt);
}

SEE ALSO


Name

harness

ATTRIBUTES

AttributePos.Req.DefaultDescription
expected
name
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

harness is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/harness.coretag
Lines: 46


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: harness.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag harness             addAttr
UserTag harness             hasEndTag
UserTag harness             PosNumber    0
UserTag harness             Version      $Revision: 1.4 $
UserTag harness             Routine      <<EOR
my $Test = 'test001';
sub {
my ($opt, $input) = @_;
my $not;
my $expected =  $opt->{expected} || 'OK';
$input =~ s:^\s+::;
$input =~ s:\s+$::;
$input =~ s:\s*\[expected\](.*)\[/expected\]\s*::s
  and $expected = $1;
$input =~ s:\[not\](.*)\[/not\]::s
  and $not = $1;
my $name = $Test++;
$name = $opt->{name}
  if defined $opt->{name};
my $result;
eval {
  $result = Vend::Interpolate::interpolate_html($input);
};
if($@) {
  my $msg = "DIED in test $name. \$\@: $@";
#::logDebug($msg);
  return $msg;
}
if($expected) {
  return "NOT OK $name: $result!=$expected" unless $result =~ /$expected/;
}
if($not) {
  return "NOT OK $name: $result==$not" unless $result !~ /$not/;
}
return "OK $name";
}
EOR

SEE ALSO


Name

history-scan — generate link to (or just display name of) a previously visited page

ATTRIBUTES

AttributePos.Req.DefaultDescription
find YesYes  Regular expression that a candidate page must match. First match wins.
exclude Yes  Regular expression specifying a pattern which, if matched, causes individual history entries to be removed from the list of possible candidates.
default Yes  Value of the SpecialPage catalog directive (which is usually index.html). Default link. Displayed if nothing else matched your criteria, or the user's history is empty.
include    Regular expression specifying a pattern which pages in user's history must match to be included as candidates.
form     Additional form data.
pageonly   0 Only display page name instead of generating an HTML link around it.
count     How many most-recently-visited pages to leave out from the list of candidates.
var_exclude    mv_credit_card_number 1
mv_pc 1
mv_session_id 1
expand 1
collapse 1
expandall 1
collapseall 1
Hash of variables to exclude from the form if form is used in the generated link. The default value shows a meaningful example. Note that since this is a hash, the number 1 (or any true value for that matter) after each entry is necessary, but redundant.
sizelimit   1024 maximum limit for resulting URL

DESCRIPTION

This tag produces an HTML link to some previously visited page. Optionally, just the page name (without the link) can be displayed.

Pages in history which are marked "expired" (for any reason) are automatically discarded from the link candidates list.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: "Continue Shopping" button

[button
  text="Continue shopping"
  src="__THEME_IMG_DIR__/continueshopping.gif"
  hidetext=1
  extra="class='maincontent'"
  form=basket
]
  [bounce href='[history-scan exclude="^/ord|^/multi/|^/process|^/login"
          default=index]']
  mv_nextpage=nothing
[/button]

This example was provided by Jeff Dafoe.


Here's a simple login form that returns the user to the previous page after successful login:

<form action="[process secure=1]" method="post">
<input type="hidden"   name="mv_todo"        value="return>
<input type="hidden"   name="mv_click"       value="Login">
<input type="hidden"   name="mv_failpage"    value="login">
<input type="hidden"   name="mv_successpage" value="[history-scan
      exclude="^/ord|^/multi/|^/process|^/login|^/logout" pageonly=1]">
<input type="hidden"   name="mv_nextpage"    value="index">
<input type="hidden"   name="mv_session_id"  value="[data session id]">
<input type="text"     name="mv_username"    value="[read-cookie MV_USERNAME]">
<input type="password" name="mv_password"    value="">
<input type="submit"   name="submit"         value="Log In">
</form>

NOTES

AVAILABILITY

history-scan is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/history_scan.tag
Lines: 93


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: history_scan.tag,v 1.20 2007-03-30 23:40:57 pajamian Exp $

UserTag history-scan Order   find exclude default
UserTag history-scan addAttr
UserTag history-scan Version $Revision: 1.20 $
UserTag history-scan Routine <<EOR
my %var_exclude = ( qw/
  mv_credit_card_number 1
  mv_pc                 1
  mv_session_id         1
  expand                1
  collapse              1
  expandall             1
  collapseall           1
  /);

sub {
my ($find, $exclude, $default, $opt) = @_;
$default ||= $Vend::Cfg->{SpecialPage}{catalog};
my $ref = $Vend::Session->{History};

use vars qw/$CGI $Tag/;

$opt->{size_limit} ||= '1024';
unless ($ref) {
  return $default if $opt->{pageonly};
  return $Tag->area($default);
}
my ($hist, $href, $cgi);
$exclude = qr/$exclude/ if $exclude;
my $include;
$include = qr/$opt->{include}/ if $opt->{include};
for (my $i = $#$ref - abs($opt->{count}); $i >= 0; $i--) {
  next if $ref->[$i][0] eq 'expired';
  if ($exclude and $ref->[$i][0] =~ $exclude) {
    next;
  }
  if ($include and $ref->[$i][0] !~ $include) {
    next;
  }
  if($find) {
    next unless $ref->[$i][0] =~ /$find/;
  }
  ($href, $cgi) = @{$ref->[$i]};
  last;
}
unless ($href) {
  return $default if $opt->{pageonly};
  return $Tag->area($default);
}
$href =~ s|/+|/|g;
$href =~ s|^/||;
if ($opt->{pageonly}) {
  return $href;
}
my $form = '';
if($opt->{var_exclude}) {
  for(split /[\s,\0]+/, $opt->{var_exclude}) {
    $var_exclude{$_} = 1;
  }
}
for(grep !$var_exclude{$_}, keys %$cgi) {
  $form .= "\n$_=";
  $form .= join("\n$_=", split /\0/, $cgi->{$_});
}
$form .= "\n$opt->{form}" if $opt->{form};
my $string = $Tag->area( {
              href => $href,
              form => $form,
              no_session => $opt->{no_session},
            } );
my $len = length($string);
if($len > $opt->{size_limit}) {
  $len = $Tag->filter('commify.0', $len);
  my $m = errmsg(
        'Huge URL (%s bytes) exceeds %s byte limit, returning blank.',
        $len,
        $opt->{size_limit},
      );
  $Tag->error({ name => 'history-scan', set => $m })
    if $opt->{debug};
  return undef;
}
return $string;
}
EOR

SEE ALSO


Name

href

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

href is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/area.coretag
Lines: 17


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: area.coretag,v 1.6 2007-09-21 16:15:48 kwalsh Exp $

UserTag href Alias        area

UserTag area Order        href arg
UserTag area addAttr
UserTag area Implicit     secure secure
UserTag area PosNumber    2
UserTag area Version      $Revision: 1.6 $
UserTag area MapRoutine   Vend::Interpolate::tag_area

SEE ALSO


Name

html-table — output HTML table

ATTRIBUTES

AttributePos.Req.DefaultDescription
columns Names for the columns, separated by whitespace (\s+). If the th attribute is used, this one is ignored, so the column names must be passed as the first row of table input data.
delimiter \t Field delimiter to use if the data is provided in-place (in the tag body) instead of as an array reference.
record_delim \n Record delimiter to use if the data is provided in-place (in the tag body) instead of as an array reference.
tr Extra arguments for each table row. Any arguments you place here will render as <tr ARGUMENTS>.
td Extra arguments for each table cell. Any arguments you place here will render as <td ARGUMENTS>.
th Extra arguments for table header. Any arguments you place here will render as <th ARGUMENTS>. When this attribute is used, columns is ignored.
fc Extra arguments for the first table column. Any arguments you place here will render as <td ARGUMENTS>.
fr Extra arguments for the first table row. Any arguments you place here will render as <tr ARGUMENTS>.
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

This tag creates an HTML table by auto-inserting the appropriate HTML markup. Table data can either be provided in-place (within the tag body), or passed as a array reference.

The enclosing <table> HTML tag is not included, you have to include it yourself.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Creating an HTML table using in-place data

<table width="90%" border="1">

[html-table fc="bgcolor='red'" fr="bgcolor='blue'" th="bgcolor='yellow'"]
title1  title2  title3
r1c1    r1c2    r1c3
r2c1    r2c2    r2c3
r3c1    r3c2    r3c3
[/html-table]

</table>

Example: Creating an HTML table using an array reference


[calc]
  $Scratch->{table} = (
    [qw/title1 title2 title3/],
    ['r1c1', 'r1c2', 'r1c3'],
    [qw/r2c1 r2c2 r2c3/],
    [qw/r3c1 r3c2 r3c3/],
  );
[/calc]

<table width="90%" border="1">
[html-table body=`$Scratch->{table}` /]
</table>


NOTES

Since the tag body responds to TABs (\t) and newlines (\n) by default, make sure that the table input data is not indented.

Separate fields using exactly one field delimiter (one TAB, for example); multiple delimiters in a row will imply empty cells.

AVAILABILITY

html-table is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/html_table.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: html_table.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag html-table          addAttr
UserTag html-table          hasEndTag
UserTag html-table          PosNumber    0
UserTag html-table          Version      $Revision: 1.4 $
UserTag html-table          MapRoutine   Vend::Interpolate::html_table

Source: lib/Vend/Interpolate.pm
Lines: 4646

sub html_table {
  my($opt, $ary, $na) = @_;

if (!$na) {
  $na = [ split /\s+/, $opt->{columns} ];
}
if(! ref $ary) {
  $ary =~ s/^\s+//;
  $ary =~ s/\s+$//;
  my $delimiter = quotemeta $opt->{delimiter} || "\t";
  my $splittor = quotemeta $opt->{record_delim} || "\n";
  my (@rows) = split /$splittor/, $ary;
  $na = [ split /$delimiter/, shift @rows ] if $opt->{th};
  $ary = [];
  my $count = scalar @$na || -1;
  for (@rows) {
    push @$ary, [split /$delimiter/, $_, $count];
  }
}

my ($tr, $td, $th, $fc, $fr) = @{$opt}{qw/tr td th fc fr/};

for($tr, $td, $th, $fc, $fr) {
  next unless defined $_;
  s/(.)/ $1/;
}

my $r = '';
$tr = '' if ! defined $tr;
$td = '' if ! defined $td;
if(! defined $th || $th and scalar @$na ) {
  $th = '' if ! defined $th;
  $r .= "<tr$tr>";
  for(@$na) {
    $r .= "<th$th><b>$_</b></th>";
  }
  $r .= "</tr>\n";
}
my $row;
if($fr) {
  $r .= "<tr$fr>";
  my $val;
  $row = shift @$ary;
  if($fc) {
    $val = (shift @$row) || '&nbsp;';
    $r .= "<td$fc>$val</td>";
  }
  foreach (@$row) {
    $val = $_ || '&nbsp;';
    $r .= "<td$td>$val</td>";
  }
  $r .= "</tr>\n";
  
}
foreach $row (@$ary) {
  $r .= "<tr$tr>";
  my $val;
  if($fc) {
    $val = (shift @$row) || '&nbsp;';
    $r .= "<td$fc>$val</td>";
  }
  foreach (@$row) {
    $val = $_ || '&nbsp;';
    $r .= "<td$td>$val</td>";
  }
  $r .= "</tr>\n";
}
return $r;
}

SEE ALSO


Name

if — conditional parsing

ATTRIBUTES

AttributePos.Req.DefaultDescription
type Yes
term Yes
op Yes
compare Yes
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

Allows conditional parsing based upon the setting of various Interchange session and database values:

config

The Interchange configuration variables. These are set by the directives in your Interchange configuration file (or the defaults).

cgi

Test CGI variable, posted into the page with a HTML form, or via a URI argument.

data

The Interchange database tables. Retrieves a column in the named table and returns true or false, based upon the value.

discount

Checks to see if a discount is present for an item.

errors

Check to see whether there are any error/information messages associated with a named form value.

[if errors fname]
	Please enter your first name.
[/if]

explicit

A test for an explicit value. If Perl code is placed in a [condition] container then the supplied code will be used to make the comparison.

field

This is much like the data test type, listed above, except that it works on the the table(s) listed in the DefaultTables local configuration directive.

file

Tests for the existence of a file. Useful for placing image tags only if the image is present.

file-A

Compares against a file's access time (in days).

file-B

Compares against a file's binary status

file-d

Tests whether a file is a directory.

file-e

Tests whether the file (or directory) exists at all.

file-f

Tests whether a file is a plain file (follows symbolic links).

file-l

Tests whether a file is a symbolic link.

file-M

Tests against the number of days since the file was modified.

file-r

Tests whether file is readable by the Interchange user.

file-s

Allows tests against the size of a file.

file-T

Tests whether a file is a plain text file.

file-w

Tests whether the file can be written to by the Interchange user.

file-x

Tests whether the file is executable by the Interchange user.

global

Configuration variables set using a global Variable directive.

items

Usually used as a litmus test to see if anything is in the cart, for example: If no cart name is specified then "main" will be used.

ordered

Order status of individual items in the Interchange shopping carts. If no cart name is specified then "main" will be used.

pragma

Test a page Pragma value, set with the the Pragma directive in the catalog.cfg file, or with the pragma tag.

scratch

Test a scratchpad variables, previously set with set, seti, tmp and tmpn (or not set, as the case may be).

scratchd

This is the same as the "scratch" test type, except that the variable is deleted from the scratchpad after testing.

[Note]Note

Introduced in version 5.5.1.

session

Test an Interchange session variable.

tmp

Test for existence of non-session temporary value, set with either the ts or tn tags, or via $Tmp in Perl.

[Note]Note

Introduced in version 5.8.2.

validcc

A special case which takes the form [if validcc no type exp_date]. Evaluates to true if the supplied credit card number, type of card and expiration date pass a validity test. Does a LUHN-10 calculation to weed out typos or phony card numbers. Uses the standard CreditCardAuto values for targets if nothing else is specified.

value

Test a form value, previously set with value or via a previous HTML form post.

variable

Configuration variables set using a local Variable or VariableDatabase directive.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

if is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 1467

sub tag_if {
my ($cond,$body,$negate) = @_;
#::logDebug("Called tag_if: $cond\n$body\n");
my ($base, $term, $op, $operator, $comp);
my ($else, $elsif, $else_present, @addl);

($base, $term, $operator, $comp) = split /\s+/, $cond, 4;
if ($base eq 'explicit') {
  $body =~ s#$QR{condition_begin}##o
    and ($comp = $1, $operator = '');
}
#::logDebug("tag_if: base=$base term=$term op=$operator comp=$comp");

#Handle unless
($base =~ s/^\W+// or $base = "!$base") if $negate;

$else_present = 1 if
  $body =~ /\[[EeTtAaOo][hHLlNnRr][SsEeDd\s]/;

($body, $elsif, $else, @addl) = split_if($body)
  if $else_present;

#::logDebug("Additional ops found:\n" . join("\n", @addl) ) if @addl;

unless(defined $operator) {
  undef $operator;
  undef $comp;
}

my $status = conditional ($base, $term, $operator, $comp, @addl);

#::logDebug("Result of if: $status\n");

my $out;
if($status) {
  $out = $body;
}
elsif ($elsif) {
  $else = '[else]' . $else . '[/else]' if length $else;
  my $pertinent = Vend::Parse::find_matching_end('elsif', \$elsif);
  unless(defined $pertinent) {
    $pertinent = $elsif;
    $elsif = '';
  }
  $elsif .= '[/elsif]' if $elsif =~ /\S/;
  $out = '[if ' . $pertinent . $elsif . $else . '[/if]';
}
elsif (length $else) {
  $out = $else;
}
return $out;
}

# This generates a *session-based* Autoload routine based
# on the contents of a preset Profile (see the Profile directive).
#
# Normally used for setting pricing profiles with CommonAdjust,
# ProductFiles, etc.
# 
sub restore_profile {
my $save;
return unless $save = $Vend::Session->{Profile_save};
for(keys %$save) {
  $Vend::Cfg->{$_} = $save->{$_};
}
return;
}

sub tag_profile {
my($profile, $opt) = @_;
#::logDebug("in tag_profile=$profile opt=" . uneval_it($opt));

$opt = {} if ! $opt;
my $tag = $opt->{tag} || 'default';

if(! $profile) {
  if($opt->{restore}) {
    restore_profile();
    if(ref $Vend::Session->{Autoload}) {
       @{$Vend::Session->{Autoload}} = 
         grep $_ !~ /^$tag-/, @{$Vend::Session->{Autoload}};
    }
  }
  return if ! ref $Vend::Session->{Autoload};
  $opt->{joiner} = ' ' unless defined $opt->{joiner};
  return join $opt->{joiner},
    grep /^\w+-\w+$/, @{ $Vend::Session->{Autoload} };
}

if($profile =~ s/(\w+)-//) {
  $opt->{tag} = $1;
  $opt->{run} = 1;
}
elsif (! $opt->{set} and ! $opt->{run}) {
  $opt->{set} = $opt->{run} = 1;
}

if( "$profile$tag" =~ /\W/ ) {
  logError(
    "profile: invalid characters (tag=%s profile=%s), must be [A-Za-z_]+",
    $tag,
    $profile,
  );
  return $opt->{failure};
}

if($opt->{run}) {
#::logDebug("running profile=$profile tag=$tag");
  my $prof = $Vend::Cfg->{Profile_repository}{$profile};
    if (not $prof) {
    logError( "profile %s (%s) non-existant.", $profile, $tag );
    return $opt->{failure};
  } 
#::logDebug("found profile=$profile");
  $Vend::Cfg->{Profile} = $prof;
  restore_profile();
#::logDebug("restored profile");
  PROFSET: 
  for my $one (keys %$prof) {
#::logDebug("doing profile $one");
    next unless defined $Vend::Cfg->{$one};
    my $string;
    my $val = $prof->{$one};
    if( ! ref $Vend::Cfg->{$one} ) {
      # Do nothing
    }
    elsif( ref($Vend::Cfg->{$one}) eq 'HASH') {
      if( ref($val) ne 'HASH') {
      $string = '{' .  $prof->{$one}  . '}'
        unless  $prof->{$one} =~ /^{/
        and    $prof->{$one} =~ /}\s*$/;
    }
    }
    elsif( ref($Vend::Cfg->{$one}) eq 'ARRAY') {
      if( ref($val) ne 'ARRAY') {
      $string = '[' .  $prof->{$one}  . ']'
        unless  $prof->{$one} =~ /^\[/
        and    $prof->{$one} =~ /]\s*$/;
    }
    }
    else {
      logError( "profile: cannot handle object of type %s.",
            $Vend::Cfg->{$one},
            );
      logError("profile: profile for $one not changed.");
      next;
    }

#::logDebug("profile value=$val, string=$string");
    undef $@;
    $val = $ready_safe->reval($string) if $string;

    if($@) {
      logError( "profile: bad object %s: %s", $one, $string );
      next;
    }
    $Vend::Session->{Profile_save}{$one} = $Vend::Cfg->{$one}
      unless defined $Vend::Session->{Profile_save}{$one};

#::logDebug("set $one to value=$val, string=$string");
    $Vend::Cfg->{$one} = $val;
  }
  return $opt->{success}
    unless $opt->{set};
}

#::logDebug("setting profile=$profile tag=$tag");
my $al;
if(! $Vend::Session->{Autoload}) {
  # Do nothing....
}
elsif(ref $Vend::Session->{Autoload}) {
  $al = $Vend::Session->{Autoload};
}
else {
  $al = [ $Vend::Session->{Autoload} ];
}

if($al) {
  @$al = grep $_ !~ m{^$tag-\w+$}, @$al;
}
$al = [] if ! $al;
push @$al, "$tag-$profile";
#::logDebug("profile=$profile Autoload=" . uneval_it($al));
$Vend::Session->{Autoload} = $al;

return $opt->{success};
}

SEE ALSO


Name

if-mm — check permissions for UI tasks

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ function | key ] yes yes function to check permissions for
name yes
table
prefix
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

This tag performs various checks on behalf of the UI:

logged_in

Checks whether the current user is logged into the UI.

[if-mm !logged_in]
[set ui_error]Not authorized[/set]
[bounce page="admin/error"]
[/if-mm]

tables

Checks for access to database tables.

[if-mm !tables content]
[set ui_error]Not authorized for content editor.[/set]
[bounce page="admin/error"]
[/if-mm]

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: MV_PAGE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

if-mm is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/if_mm.coretag
Lines: 195


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: if_mm.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag if-mm Order      function name
UserTag if-mm addAttr
UserTag if-mm attrAlias  key name
UserTag if-mm hasEndTag
UserTag if-mm Version    $Revision: 1.6 $
UserTag if-mm Routine    <<EOR
sub {
my($func, $field, $opt, $text) = @_;

my $record;
my $status;

my $reverse;
$reverse = $func =~ s/^\s*!\s*//;

my $extended = '';
$extended = $1 if $field =~ s/(=.*)//;

my ($group, @groups);
$text = 1 if ! $text;
CHECKIT: {
if ($group or ! ($record = $Vend::UI_entry) ) {
  $record = ui_acl_enabled($group);
  if ( ! ref $record) {
    $status = $record;
    last CHECKIT;
  }
}
($status = 0, last CHECKIT) if ! UI::Primitive::is_logged();
($status = 1, last CHECKIT) if $record->{super};
$func = lc $func;
($status = 1, last CHECKIT) if $func eq 'logged_in';

my %acl_func = qw/
          fields  fields
          field  fields
          columns  fields
          column  fields
          col     fields
          row    keys
          rows  keys
          key    keys
          keys  keys
          owner_field  owner_field
          owner  owner_field
        /;

my %file_func = qw/
          page  pages
          file  files
          pages  pages
          files  files
        /;

my %bool_func = qw/
          config   1
          reconfig 1
        /;

my %paranoid = qw/
          mml             1
          sql             1
          report          1
          add_delete      1
          add_field       1
          journal_update  1
        /;
my %yesno_func = qw/
          functions  functions
          advanced  functions
          tables  tables
          table   tables
        /;
my %prefix_func = qw/
          filematch  files
          pagematch  pages
        /;

my $table = $CGI::values{mv_data_table} || $::Values->{mv_data_table};

if($yesno_func{$func} eq 'tables') {
  $opt->{table} = $field if ! $opt->{table};
  $opt->{table} =~ s/^=/$table/;
}
elsif($yesno_func{$func} eq 'functions') {
$opt->{table} = $field;
}

$table = $opt->{table} || $table;

my $acl;
my $check;
$status = 0, last CHECKIT if $func eq 'super';
if($check = $file_func{$func}) {
$status = 1, last CHECKIT unless $record->{$check};
my $file = $field || $Global::Variable->{MV_PAGE};
# strip trailing slashes for checks on directories
$file =~ s%/+$%%;                     
#::logDebug("check=$check file=$file record=$record->{$check} prefix=$opt->{prefix}");
my @files =  UI::Primitive::list_glob($record->{$check}, $opt->{prefix});
#::logDebug("check yielded files=" . join(",", @files));
  if(! @files) {
    $status = '';
    last CHECKIT;
  }
  $status = ui_check_acl("$file$extended", join(" ", @files));
#::logDebug("check status=$status");
  last CHECKIT;
}
if($check = $prefix_func{$func}) {
  $status = '', last CHECKIT unless $record->{$check};
  my $file = $field;
  # strip trailing slashes for checks on directories
#::logDebug("check=$check file=$file record=$record->{$check}");
  my @allow =  split /\s+/, $record->{$check};
  $status = '';
  for(@allow) {
#::logDebug("check file=$file against allow=$_");
    if(s/^\!//) {
      if ($file =~ /^$_/) {
#::logDebug("denied based on $_");
        $status = '';
        last CHECKIT;
      }
    }
    else {
      next unless $file =~ /^$_\b/;
      $status = 1; 
    }
  }
#::logDebug("check Yielded status=$status");
  last CHECKIT;
}
if($bool_func{$func} ) {
  $status = $record->{$func};
  last CHECKIT;
}
if($check = $yesno_func{$func} ) {
  my $v;
  if($v = $record->{"yes_$check"}) {
    $status = ui_check_acl("$table$extended", $v);
  }
  else {
    $status = 1;
  }
  if($v = $record->{"no_$check"}) {
    $status &&= ! ui_check_acl("$table$extended", $v);
  }
  last CHECKIT;
}
if(! ($check = $acl_func{$func}) ) {
  my $default = $func =~ /^no_/ ? 0 : 1;
  $status = $default, last CHECKIT unless $record->{$func};
  $status = ui_check_acl("$table$extended", $record->{$func});
  last CHECKIT;
}

# Now it is definitely a job for table_control;
$acl = UI::Primitive::get_ui_table_acl($table);

$status = 1, last CHECKIT unless $acl;
my $val;
if($acl->{owner_field} and $check eq 'keys') {
  $status = ::tag_data($table, $acl->{owner_field}, $field)
        eq $Vend::username;
  last CHECKIT;
}
elsif ($check eq 'owner_field') {
  $status = length $acl->{owner_field};
  last CHECKIT;
}
$status = UI::Primitive::ui_acl_atom($acl, $check, $field);
}
if(! $status and $record and (@groups or $record->{groups}) ) {
  goto CHECKIT if $group = shift @groups;
  (@groups) = grep /\S/, split /[\0,\s]+/, $record->{groups};
  ($group, @groups) = map { s/^/:/; $_ } @groups;
  goto CHECKIT;
}
return $status
  ? (
    Vend::Interpolate::pull_if($text, $reverse)
    )
  : Vend::Interpolate::pull_else($text, $reverse);
}
EOR


Name

if_not_volatile

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

if_not_volatile is available in Interchange versions:

5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/if_not_volatile.tag
Lines: 10


UserTag if_not_volatile HasEndTag 1
UserTag if_not_volatile Interpolate 0
UserTag if_not_volatile NoReparse 0
UserTag if_not_volatile Routine <<EOF
sub {
my $body = shift;
return $body unless $::Instance->{Volatile};
return '';
}
EOF

SEE ALSO


Name

image — general purpose tag for generating HTML <img> tags

ATTRIBUTES

AttributePos.Req.DefaultDescription
src YesYes  Image source. Can be a plain product SKU, or just the image basename (so Interchange would probe for existing file formats), or a literal (relative or absolute) URL. If Interchange is let to search for file extensions, it will check for .jpg, .gif, .png and .jpeg in the same order as specified here.
alt    The description value from the products database if SKU is specified instead of a literal image filename. Otherwise, none. Text to use in the <img>'s alt attribute. By default, this will be filled with the description from the product database if a SKU (not a filename) is provided.
default    [scratch mv_imagedefault], if set. Image filename (relative or absolute URL) that will be used if no image for the SKU was found.
descriptionfields    DESCRIPTIONFIELDS catalog variable Whitespace-separated list of fields in the products database to pull the description from. This is used for the default alt and title attributes.
dir_only   0 Only return the value of ImageDir or ImageDirSecure config directives? This is primarily used in js code to discover the appropriate path to prepend to image files.
exists_only   0 Only return true if the image exists?
src_only   0 Only return the would-be image location, without the surrounding link and metadata (alts, titles, etc.)?
force   0 Skip any checks on image file (existence, extension, etc.)?
getsize   1 Use Image::Size Perl module to determine image dimensions and specify them in the img tag?
imagesubdir   [scratch mv_imagesubdir], if set. Look for the image files in only one subdirectory of the ImageDir or ImageDirSecure config directives.
[ makesize | resize | geometry ]    If ImageMagick is installed, you can display an arbitrary size of the image, creating it if necessary. This would create a subdirectory corresponding to the size, (i.e. "64x48") and copy the source image to it. It would then use the mogrify command to resize. This requires a writable image directory, of course. If not found in the PATH, the location of the mogrify can be defined with the IMAGE_MOGRIFY variable. This would also temporarily set umask to 2 during the creation of files and directories. The value is specified as AxB, A or xB, followed by up to two +- offset specifications, followed by none or one of %@!<>. For a complete syntax, see mogrify -geometry parameter.
check_date   0 Track original file's modification time and rebuild the resized image when the source file changes? (This only makes sense with makesize .)
secure    Same delivery method as for the current page. Value of 0 forces http:// link to the file. Value of 1 forces https://.
sku    Specify this attribute explicitly if you want to first try an image from the image field in the products database. If it does not exist, then a fallback to SKU-derived image filenames is performed.
title    Value of the alt attribute. Text to use for the img's title attribute. This is supported by newer browsers to provide things like rollover tips.
ui  0 Set to a true value to use Admin UI image prefixes. In other words, this uses the values of UI_IMAGE_DIR and UI_IMAGE_DIR_SECURE variables instead of the ImageDir and ImageDirSecure config directives. This option does honor locale settings.
name , id , class , style    The standard HTML attributes.
border , height , width , hspace , vspace , align , title , alt    The usual HTML attributes.
extra   None. Extra HTML attributes. Passed verbatim.

DESCRIPTION

image is a general-purpose tag for generating HTML <img> tags based on various settings.

It can test whether an image exists, predetermine dimensions, retrieve image names from the product database (the image field), automatically pull product descriptions from the database (for alt and title attributes).

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: DESCRIPTIONFIELDS, IMAGEFIELDS, UI_IMAGE_DIR, DOCROOT
Global Variables: UI_IMAGE_DIR, IMAGE_MOGRIFY

EXAMPLES

Example: Simple image

Let's suppose there's a product SKU os29000 present in your products database and the image field contains value os29000.png. Place the image on a test page:

[image os29000]

The tag would produce something like:

<img src="/standard/images/os29000.png"
      width="120"
      height="150"
      alt="3' Step Ladder"
      title="3' Step Ladder">

NOTES

This tag makes a lot of assumptions about your setup, and sometimes it might not be the best tool for the job.

AVAILABILITY

image is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/image.tag
Lines: 281


# Copyright 2002-2016 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag image Order     src
UserTag image AttrAlias geometry makesize
UserTag image AttrAlias resize makesize
UserTag image AddAttr
UserTag image Version   1.26
UserTag image Routine   <<EOR
sub {
my ($src, $opt) = @_;
my ($image, $path, $secure, $sku);
my ($imagedircurrent, $imagedir, $imagedirsecure);

my @descriptionfields = grep /\S/, split /\s+/,
$opt->{descriptionfields} || $::Variable->{DESCRIPTIONFIELDS} || $Vend::Cfg->{DescriptionField};
@descriptionfields = qw( description ) if ! @descriptionfields;

my @imagefields = grep /\S/, split /\s+/,
$opt->{imagefields} || $::Variable->{IMAGEFIELDS};
@imagefields = qw( image ) if ! @imagefields;

my @imagesuffixes = qw( jpg gif png jpeg );
my $filere = qr/\.\w{2,4}$/;
my $absurlre = qr!^(?i:https?)://!;

if ($opt->{ui}) {
# unless no image dir specified, add locale string
my $locale = $Scratch->{mv_locale} ? $Scratch->{mv_locale} : 'en_US';
$imagedir    = $::Variable->{UI_IMAGE_DIR}
|| $Global::Variable->{UI_IMAGE_DIR};
$imagedirsecure  = $::Variable->{UI_IMAGE_DIR}
|| $Global::Variable->{UI_IMAGE_DIR};
for ($imagedir, $imagedirsecure) {
if ($_) {
$_ .= '/' if substr($_, -1, 1) ne '/';
  $_ .= $locale . '/';
    }
  }
} else {
  $imagedir    = $Vend::Cfg->{ImageDir};
  $imagedirsecure  = $Vend::Cfg->{ImageDirSecure} || $imagedir ;
}

# make sure there's a trailing slash on directories
for ($imagedir, $imagedirsecure) {
  $_ .= '/' if $_ and substr($_, -1, 1) ne '/';
}

if (defined $opt->{secure}) {
  $secure = $opt->{secure} ? 1 : 0;
} else {
  $secure = $CGI::secure;
}

$imagedircurrent = $secure ? $imagedirsecure : $imagedir;

return $imagedircurrent if $opt->{dir_only};

$opt->{getsize} = 1 unless defined $opt->{getsize}
  or (defined($opt->{height}) and defined($opt->{width}));
$opt->{imagesubdir} ||= $::Scratch->{mv_imagesubdir}
  if defined $::Scratch->{mv_imagesubdir};
$opt->{default} ||= $::Scratch->{mv_imagedefault}
  if defined $::Scratch->{mv_imagedefault};

if ($opt->{sku}) {
  $sku = $opt->{sku};
} else {
  # assume src option is a sku if it doesn't look like a filename
  if ($src !~ /$filere/) {
    $sku = $src;
    undef $src;
  }
}

if($opt->{name_only} and $src) {
  my $ret = $src =~ /$absurlre/ ? $src : "$imagedircurrent$src";
  $ret =~ s/%(?!25)/%25/g;
  return $ret;
}

if ($src =~ /$absurlre/) {
  # we have no way to check validity or create/read sizes of full URLs,
  # so we just assume they're good
  $image = $src;
} else {

  my @srclist;
  push @srclist, $src if $src;
  if ($sku) {
    # check all products tables for image fields
    for ( @{$Vend::Cfg->{ProductFiles}} ) {
      my $db = Vend::Data::database_exists_ref($_)
        or die "Bad database $_?";
      $db = $db->ref();
      my $view = $db->row_hash($sku)
        if $db->record_exists($sku);
      if (ref $view eq 'HASH') {
        for (@imagefields) {
          push @srclist, $view->{$_} if $view->{$_};
        }
        # grab product description for alt attribute
        unless (defined $opt->{alt}) {
          for (@descriptionfields) {
            ($opt->{alt} = $view->{$_}, last)
              if $view->{$_};
          }
    }
  }
}
}
push @srclist, $sku if $sku;
push @srclist, $opt->{default} if $opt->{default};

if ($opt->{imagesubdir}) {
$opt->{imagesubdir} .= '/' unless $opt->{imagesubdir} =~ m:/$:;
}
my $dr = $::Variable->{DOCROOT};
my $id = $imagedircurrent;
$id =~ s:/+$::;
$id =~ s:/~[^/]+::;

  IMAGE_EXISTS:
  for my $try (@srclist) {
    ($image = $try, last) if $try =~ /$absurlre/;
    $try = $opt->{imagesubdir} . $try;
    my @trylist;
    if ($try and $try !~ /$filere/) {
      @trylist = map { "$try.$_" } @imagesuffixes;
      push @trylist, map { $try . '.' . uc($_) } @imagesuffixes;
      my %uniq = map { $_ => undef } @trylist;
      @trylist = sort keys %uniq;
    } else {
      @trylist = ($try);
    }
    for (@trylist) {
      if ($id and m{^[^/]}) {
        if ($opt->{force} or ($dr and -f "$dr$id/$_")) {
          $image = $_;
          $path = "$dr$id/$_";
        }
      } elsif (m{^/}) {
        if ($opt->{force} or ($dr and -f "$dr/$_")) {
          $image = $_;
          $path = "$dr/$_";
        }
      }
      last IMAGE_EXISTS if $image;
    }
  }

  return unless $image;
  return 1 if $opt->{exists_only};

  my $mask;

  if($opt->{makesize} and $path) {
    my $dir = $path;
    $dir =~ s:/([^/]+$)::;
    my $fn = $1;
    my $siz = $opt->{makesize};
    MOGIT: {
      # Support complete mogrify -geometry syntax
      # This matches: AxB, A or xB, followed by 0, 1, or 2 [+-]number
      # specs, followed by none or one of @!%><.
      $siz =~ m{^(()|\d+())(x\d+\3|x\d+\2|\3)([+-]\d+){0,2}([@!%><])?$}
        or do {
          logError("%s: Unable to make image with bad size '%s'", 'image tag', $siz);
          last MOGIT;
        };

      (my $siz_path = $siz) =~ s:[^\dx]::g;
      $dir .= "/$siz_path";
      
      my $newpath = "$dir/$fn";
      if(-f $newpath) {
        if($opt->{check_date}) {
          my $mod1 = -M $newpath;
          my $mod2 = -M $path;
          unless ($mod2 < $mod1) {
            $image =~ s:(/?)([^/]+$):$1$siz_path/$2:;
            $path = $newpath;
            last MOGIT;
          }
        }
        else {
          $image =~ s:(/?)([^/]+$):$1$siz_path/$2:;
          $path = $newpath;
          last MOGIT;
        }
      }

      $mask = umask(02);

      unless(-d $dir) {
        File::Path::mkpath($dir);
      }

my $mgkpath = $newpath;
my $ext;
$mgkpath =~ s/\.(\w+)$/.mgk/
and $ext = $1;

File::Copy::copy($path, $newpath)
or do {
logError("%s: Unable to create image '%s'", 'image tag', $newpath);
last MOGIT;
};
my $exec = $Global::Variable->{IMAGE_MOGRIFY};
if(! $exec) {
my @dirs = split /:/, "/usr/X11R6/bin:$ENV{PATH}";
for(@dirs) {
next unless -x "$_/mogrify";
         $exec = "$_/mogrify";
         $Global::Variable->{IMAGE_MOGRIFY} = $exec;
        last;
      }
    }
    last MOGIT unless $exec;
      system qq{$exec -geometry "$siz" '$newpath'};
      if($?) {
        logError("%s: Unable to mogrify image '%s'", 'image tag', $newpath);
        last MOGIT;
      }

      if(-f $mgkpath) {
        rename $mgkpath, $newpath
          or die "Could not overwrite image with new one!";
      }
      $image =~ s:(/?)([^/]+$):$1$siz_path/$2:;
      $path = $newpath;
    }
  }

  umask($mask) if defined $mask;

  if ($opt->{getsize} and $path) {
    eval {
      require Image::Size;
      my ($width, $height) = Image::Size::imgsize($path);
      $opt->{height} = $height
        if defined($height) and not exists($opt->{height});
      $opt->{width} = $width
        if defined($width) and not exists($opt->{width});
      if ($opt->{size_scratch_prefix}) {
        Vend::Interpolate::set_tmp($opt->{size_scratch_prefix} . '_' . $_, $opt->{$_})
          for qw/width height/;
      }
    };
  }
}

$image = $imagedircurrent . $image unless
  $image =~ /$absurlre/ or substr($image, 0, 1) eq '/';

$image =~ s/%(?!25)/%25/g;
return $image if $opt->{src_only};

$opt->{title} = $opt->{alt} if ! defined $opt->{title} and $opt->{alt};

my $opts = '';
for (qw: width height alt title border hspace vspace align valign style class name id :) {
  if (defined $opt->{$_}) {
    my $val = $opt->{$_};
    $val = HTML::Entities::encode($val) if $val =~ /\W/;
    $opts .= qq{ $_="$val"};
  }
}
if($opt->{extra}) {
  $opts .= " $opt->{extra}";
}
$image =~ s/"/&quot;/g;
return qq{<img src="$image"$opts$Vend::Xtrailer>};
}
EOR


SEE ALSO


Name

import — import records into database

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ table | base | database ] YesYes .
type Yes  
continue    
separator    
file    .
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

The import tag is used to import records into a database.

The table (database) must already be registered with Interchange using the Database directive; tables cannot be created on the fly.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

import is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/import.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: import.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag import              Order        table type
UserTag import              addAttr
UserTag import              attrAlias    base table
UserTag import              attrAlias    database table
UserTag import              hasEndTag
UserTag import              Interpolate
UserTag import              PosNumber    2
UserTag import              Version      $Revision: 1.5 $
UserTag import              MapRoutine   Vend::Data::import_text

Source: lib/Vend/Data.pm
Lines: 325

sub import_text {
my ($table, $type, $options, $text) = @_;
#::logDebug("Called import_text: table=$table type=$type opt=" . Data::Dumper::Dumper \
($options) . " text=$text");
my ($delimiter, $record_delim) = find_delimiter($type);
my $db = $Vend::Database{$table}
  or die ("Non-existent table '$table'.\n");
$db = $db->ref();

my @columns;
@columns = ($db->columns());

if($options->{'continue'}) {
  $options->{CONTINUE} = uc $options->{'continue'};
  $options->{NOTES_SEPARATOR} = uc $options->{separator}
    if defined $options->{separator};
}

my $sub = sub { return $db };
my $now = time();
my $fn = $Vend::Cfg->{ScratchDir} . "/import.$$.$now";
$text =~ s/^\s+//;
$text =~ s/\s+$//;

if($delimiter eq 'CSV') {
  my $add = '"';
  $add .= join '","', @columns;
  $add .= '"';
  $text = "$add\n$text";
}
else {
  $options->{field_names} = \@columns;
  $options->{delimiter} = $options->{DELIMITER} = $delimiter;
}

if($options->{file}) {
  $fn = $options->{file};
  Vend::File::allowed_file($fn)
    or die ::errmsg("No absolute file names like '%s' allowed.\n", $fn);
}
else {
  # data is already in memory, do not create a temporary file
  $options->{scalar_ref} = 1;
  $fn = \$text;
}

my $save = $/;
local($/) = $record_delim if defined $record_delim;

$options->{Object} = $db;

## This is where the actual import happens
Vend::Table::Common::import_ascii_delimited($fn, $options);

$/ = $save;
unlink $fn unless $options->{'file'} or $options->{scalar_ref};
return 1;
}

SEE ALSO

export(7ic)


Name

import_fields

ATTRIBUTES

AttributePos.Req.DefaultDescription
'file'
filter_field
multiple
convert
transactions
autonumber
delimiter
fields
quiet
ignore_fields
cleanse
delete
add
'move'
dir
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

import_fields is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/import_fields.coretag
Lines: 468


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: import_fields.coretag,v 1.15 2007-08-03 18:17:24 racke Exp $

UserTag import_fields Order   table
UserTag import_fields addAttr
UserTag import_fields Version $Revision: 1.15 $
UserTag import_fields Routine <<EOR
sub {
my($table, $opt) = @_;
use strict;
my $out;
#::logDebug("options for import_fields: " . ::uneval(\@_) );
local($SIG{__DIE__});
$SIG{"__DIE__"} = sub {
                          my $msg = shift;
                          ::response(<<EOF);
<HTML><HEAD><TITLE>Fatal Administration Error</TITLE></HEAD><BODY>
<H1>FATAL error</H1>
<P>
<PRE>$msg</PRE>
Progress to date:
<P>
$out
</BODY></HTML>
EOF
                          exit 0;
                      };
my $file = $opt->{'file'} || $Vend::Cfg->{ProductDir} . "/$table.update";
my $currdb;
my $tmsg = '';
my $db;

my %filter = ( 
  '' => { mv_credit_card_number => 'encrypt' },
);

if($opt->{filter_field}) {
  my @filt = grep /\S/, split /[\r\n]+/, $opt->{filter_field};
  for(@filt) {
    s/^\s+//;
    s/\s+$//;
    my ($t, $f) = split /\s*:\s*/, $_;
    if(! $f) {
      if ($opt->{multiple}) {
        die "Must specify both table and filter for multiple table filters.\n";

      }
      else {
        $f = $t;
        $t = '';
      }
      $t ||= '';
    }
#::logDebug("found filter: t=$t f=$f");
    my ($field, $filters) = split /\s*=\s*/, $f, 2;
#::logDebug("found filter: t=$t field=$field filters=$filters");
    $filter{$t}{$field} = $filters;
  }
}

CONVERT: {
  last CONVERT if ! $opt->{convert};
  if ($opt->{convert} eq 'auto') {
    if($file =~ /\.(txt|all)$/i) {
      last CONVERT;
    }
    elsif($file =~ /\.xls$/i) {
      $opt->{convert} = 'xls';
      redo CONVERT;
    }
    else {
      $file =~ s:.*\.::
        or $file = 'none';
      return "Failed: unknown file extension ''";
    }
  }
  elsif ($opt->{convert} eq 'xls') {
#::logDebug("doing XLS for file=$file");
    eval {
      require Spreadsheet::ParseExcel;
      import Spreadsheet::ParseExcel;

      my $oBook = Spreadsheet::ParseExcel::Workbook->Parse($file);
#::logDebug("oBook is $oBook");
      if(! $oBook) {
        die errmsg("Failed to parse XLS file %s: %s\n", $file, $!);
      }
      my($iR, $iC, $oWkS, $oWkC);

      my $sheetcount = $oBook->{SheetCount};
#::logDebug("Sheetcount is $sheetcount");
      my $sheets = {};

        for my $oWkS (@{$oBook->{Worksheet}}) {
           next unless defined $oWkS;

           for(qw/MaxCol MaxRow MinCol MinRow/) {
             die "No $_!"           if ! defined $oWkS->{$_};
           }

           my $sname =  $oWkS->{Name} or die "no sheet name.";
#::logDebug("doing sheet $sname");
           $sheets->{$sname} =  "$sname\n";
           my $maxcol;
           my $mincol;

           my $iC;

           my $iR = $oWkS->{MinRow};

           for($iC = $oWkS->{MinCol} ; $iC <= $oWkS->{MaxCol} ; $iC++) {
               $oWkC = $oWkS->{Cells}[$iR][$iC];
               if(! $oWkC or ! $oWkC->Value) {
                $maxcol = $iC;
                $maxcol--;
                last;
               }
               $maxcol = $iC;
           }

           $mincol = $oWkS->{MinCol};
           my @out;

           for( ; $iR <= $oWkS->{MaxRow}; $iR++) {
            my $row = $oWkS->{Cells}[$iR];
            @out = ();
            for($iC = $mincol; $iC <= $maxcol; $iC++) {
            if(! defined $row->[$iC]) {
              push @out, "";
              next;
            }
            push @out, $row->[$iC]->Value;
            }
            $sheets->{$sname} .= join "\t", @out;
            $sheets->{$sname} .= "\n";
           }
        }

        my @print;
        for(sort keys %$sheets) {
          push @print, $sheets->{$_};
        }
        $file =~ s/(\.xls)?$/.txt/i;
        open OUT, ">$file"
          or die "Cannot write $file: $!\n";
        print OUT join "\cL", @print;
        close OUT;
    };
    die "Excel conversion failed: $@\n" if $@;
  }
  else {
    # other types, or assume gnumeric simple text
  }

} # end CONVERT

my $change_sub;
if($opt->{multiple}) {
  undef $table;
  $change_sub = sub {
    my $table = shift;
    $Vend::WriteDatabase{$table} = 1;
    $Vend::TransactionDatabase{$table} = 1 
      if $opt->{transactions};
#::logDebug("changing table to $table");
    $db = Vend::Data::database_exists_ref($table);
#::logDebug("db now=$db");
    die "Non-existent table '$table'\n" unless $db;
    $db = $db->ref();
#::logDebug("db now=$db");
    if($opt->{autonumber} and ! $db->config('_Auto_number') ) {
       $db->config('AUTO_NUMBER', '1000');
    }
#::logDebug("db now=$db");
    $tmsg = "table $table: ";
    return;
  };
}
else {
  $Vend::WriteDatabase{$table} = 1;
  $Vend::TransactionDatabase{$table} = 1 
    if $opt->{transactions};
  $db = Vend::Data::database_exists_ref($table);
  die "Non-existent table '$table'\n" unless $db;
  $db = $db->ref() unless $Vend::Interpolate::Db{$table};
  if($opt->{autonumber} and ! $db->config('_Auto_number') ) {
     $db->config('AUTO_NUMBER', '1000');
  }
}

$out = '<PRE>';
my $delimiter = quotemeta $opt->{delimiter} || "\t";
open(UPDATE, $file)
  or die "read $file: $!\n";

my $fields;

if($opt->{multiple}) {
  # will get fields later
  undef $opt->{fields};
}
elsif($opt->{fields}) {
  $fields = $opt->{fields};
  $out .= "Using fields from parameter: '$fields'\n";
}

my $verbose;
my $quiet;

$verbose = 1 if ! $opt->{quiet};
$quiet = 1   if $opt->{quiet} > 1;

TABLE: {
if(! $table) {
  $table = <UPDATE>;
  $table =~ s/(\015\012|\015|\012)$//;
  $change_sub->($table);
}
#::logDebug("db now=$db");
if(! $opt->{fields}) {
  $fields = <UPDATE>;
  $fields =~ s/(\015\012|\015|\012)$//;
  $fields =~ s/$delimiter/ /g;
  $out .= "${tmsg}Using fields from file: '$fields'\n";
}
$filter{$table} ||= {};
die "No field names." if ! $fields;
my @names;
my $k;
my @f;
@names = split /\s+/, $fields;
my $key = shift @names;
my $i = 0;
my $idx = 0;
my $ignore_sub;

# check key name
if ($key !~ /^[\w_-]+$/) {
  die "Invalid key '$key' for table $table (wrong file format ?)\n";
}

my $multikey = $db->config('COMPOSITE_KEY') ? 1 : 0;


if ($opt->{ignore_fields}) {
  my %fmap;
  for (my $ct = 0; $ct < @names; $ct++) {
    $fmap{$names[$ct]} = $ct;
  }
  for (split(/[\0\s,]+/, $opt->{ignore_fields})) {
    delete $fmap{$_};
  }
  my $code = 'sub {$a = shift; @$a = @$a[' . join(',', values(%fmap)) . '];}';
  $ignore_sub = eval $code;
  die "Routine to ignore fields bad: $@" if $@;
  @names = grep {exists $fmap{$_}} @names;
}

# We skip the whole table if bad field is found
my $skipping;

my @keycols;

if($multikey) {
  my %fmap;
  @fmap{$key,@names} = ($key,@names);
  my $not_all_there;
  for(@{$db->config('_Key_columns')}) {
    push(@keycols, $_);
    next if $fmap{$_};  
    $not_all_there = 1;
  }
  if($not_all_there) {
    $out .= errmsg(
          "Table %s: not all key columns present. Skipping table.",
          $table,
        );

    $skipping = 1;
  }
}

######### Filters
##
## Done with so many data items for speed when empty....
##

## Holds filter subroutines if any
my %change;
## Holds names of filter subroutines if any
my @filters;
## Non-zero if found any filter
my $found_filter = 0;
##
######### Filters

for(@names) {
  my $test = $db->column_index($_);
#::logDebug("checking name=$_");
  if(! defined $test) {
    $out .= errmsg(
          "Table %s: undefined column '%s'. Skipping table.",
          $table,
          $_,
          );
    $skipping = 1;
  }
  elsif ($filter{''}{$_} || $filter{$table}{$_}) {
#::logDebug("found filter for name=$_");
    my @things = grep length($_), $filter{''}{$_}, $filter{$table}{$_};
    my $thing = join " ", @things;
    eval {
      $change{$_} = sub {
        my $ref = shift;
        $$ref = Vend::Interpolate::filter_value($thing, $$ref);
      };
    };
    if($@) {
      $out .= errmsg(
            "Table %s: unrequited filter '%s'. Skipping table.",
            $table,
            $thing,
          );
      $skipping = 1;
    }
    push @filters, $_;
    $found_filter++;
  }
  $idx++;
}
my %keys;
if ($opt->{cleanse}) {
  # record existing columns
  my $recs;
  if ($multikey) {
    $recs = $db->query("select " . join(',', @keycols) . " from $table");
    $keys{join("\0", @$_)} = 1 for @$recs;
  } else {
    $recs = $db->query("select $key from $table");
    $keys{$_->[0]} = 1 for @$recs;
  }
}
my $count = 0;
my $totcount = 0;
my $delcount = 0;
my $addcount = 0;
while(<UPDATE>) {
  s/(\015\012|\015|\012)$//;
  $totcount++;
  ($k, @f) = split /$delimiter/o, $_;
  if(/^\f(\w+)$/) {
    $out .= "${tmsg}$count records processed of $totcount input lines.\n";
    $out .= "${tmsg}$delcount records deleted.\n" if $delcount;
    $out .= "${tmsg}$addcount records added.\n" if $addcount;
    $delcount = $totcount = $addcount = 0;
    $db->commit() if $opt->{transactions};
    $change_sub->($1);
    redo TABLE;
  }
  next if $skipping;
  if(! $k and ! length($k)) {
    if ($f[0] eq 'DELETE') {
      next if ! $opt->{delete};
      next if $multikey;
      $out .= "${tmsg}Deleting record '$f[1]'.\n" if $verbose;
      $db->delete_record($f[1]);
      $count++;
      $delcount++;
      next;
    }
  }
  $ignore_sub->(\@f) if $ignore_sub;
  $out .= "${tmsg}Record '$k' had too many fields, ignored.\n"
    if @f > $idx;

  my %hash;
  @hash{@names} = @f;
  if($found_filter) {
    for(@filters) {
      $change{$_}->(\$hash{$_});
    }
  }

  if($multikey) {
    $hash{$key} = $k;
    if(! $db->record_exists(\%hash)) {
      if($opt->{add}) {
        $out .= "${tmsg}Adding multiple-key record.\n" if $verbose;
      }
      else {
        $out .= "${tmsg}Non-existent record '$k', skipping.\n";
        next;
      }
    }
    $k = undef;
  }
  elsif ( ! length($k) or ! $db->record_exists($k)) {
    if ($opt->{add}) {
      if( ! length($k) and ! $opt->{autonumber}) {
        $out .= "${tmsg}Blank key, no autonumber option, skipping.\n";
        next;
      }
      $k = $db->set_row($k);
      $out .= "${tmsg}Adding record '$k'.\n" if $verbose;
      $addcount++;
    }
    else {
      $out .= "${tmsg}Non-existent record '$k', skipping.\n";
      next;
    }
  }

  if ($opt->{cleanse}) {
    if ($multikey) {
      delete $keys{join("\0", map{$hash{$_}} @keycols)};
    } else {
      delete $keys{$k};
    }
  }

  $db->set_slice($k, \%hash) if @names;

  if($@) {
       my $msg = ::errmsg("error on update: %s", $@);
    ::logError($msg);
       $out .= $msg;
     }
  $count++;
}

$db->commit() if $opt->{transactions};

if ($opt->{cleanse}) {
  # remove any record which hasn't updated
  for (keys(%keys)) {
    $db->delete_record($_);
    $delcount++;
  }
}
$out .= "${tmsg}$count records processed of $totcount input lines.\n";
$out .= "${tmsg}$delcount records deleted.\n" if $delcount;
$out .= "${tmsg}$addcount records added.\n" if $addcount;
}
$out .= "</PRE>";
close UPDATE;
if($opt->{'move'}) {
  my $ext = POSIX::strftime("%Y%m%d%H%M%S", localtime());
  rename $file, "$file.$ext"
    or die "rename $file --> $file.$ext: $!\n";
  if(  $opt->{dir}
    and (-d $opt->{dir} or File::Path::mkpath($opt->{dir}))
    and -w $opt->{dir}
    )
  {
    File::Copy::move("$file.$ext", $opt->{dir})
      or die "move $file.$ext --> $opt->{dir}: $!\n";
  }
}
return $out unless $quiet;
return;
}
EOR

SEE ALSO


Name

include — include file into the current page and reparse contents for tags

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes Yes Filename to include. Can only be a relative filename if NoAbsolute is set.
locale  1Honor locales?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag inserts the contents of the named file, which is searched relative to the catalog root directory or any directories specified by the TemplateDir directive.

The file should normally be relative to the catalog directory. File names beginning with / or .. are not allowed if the Interchange server administrator has enabled NoAbsolute.

The maximum number of circular inclusions is controlled by the Limit directive, using key include_depth.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Simple file include

[include /tmp/test]

Our /tmp/test file could look like this:

Time is [time].

NOTES

File contents are always loaded and interpolated before insertion into the source document. To include file without reparsing contents, use file.

AVAILABILITY

include is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/include.coretag
Lines: 38


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: include.coretag,v 1.8 2007-03-30 23:40:49 pajamian Exp $

UserTag include             Order        file locale
UserTag include             PosNumber    2
UserTag include             Version      $Revision: 1.8 $
UserTag include             Routine      <<EOR
sub {
my ($file, $locale) = @_;
$locale = 1 unless defined $locale;

$::Instance->{include_depth} ||= 0;
my $limit = $Vend::Cfg->{Limit}{include_depth} || 10;

if($::Instance->{include_depth}++ >= $limit) {
  logOnce(
      'error',
      "Depth of include (%s) exceeds limit of %s for file %s.", 
      $::Instance->{include_depth},
      $limit,
      $file,
    );
  return;
}

my $out = Vend::Interpolate::interpolate_html(
        Vend::Util::readfile($file, undef, $locale)
      );
$::Instance->{include_depth}--;
return $out;
}
EOR

SEE ALSO

file(7ic)


Name

index

ATTRIBUTES

AttributePos.Req.DefaultDescription
extension
basefile
type
export_only
spec
fn
fields
col
columns
show_status
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

index is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/index.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: index.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag index               Order        table
UserTag index               addAttr
UserTag index               attrAlias    base table
UserTag index               attrAlias    database table
UserTag index               PosNumber    1
UserTag index               Version      $Revision: 1.5 $
UserTag index               MapRoutine   Vend::Data::index_database

Source: lib/Vend/Data.pm
Lines: 1137

sub index_database {
my($dbname, $opt) = @_;

return undef unless defined $dbname;

my $db;
$db = database_exists_ref($dbname)
  or do {
    logError("Vend::Data export: non-existent database %s", $dbname);
    return undef;
  };

$db = $db->ref();

my $ext = $opt->{extension} || 'idx';

my $db_fn = $db->config('db_file');
my $bx_fn = $opt->{basefile} || $db->config('db_text');
my $ix_fn = "$bx_fn.$ext";
my $type  = $opt->{type} || $db->config('type');

#::logDebug(
#  "dbname=$dbname db_fn=$db_fn bx_fn=$bx_fn ix_fn=$ix_fn\n" .
#  "options: " . uneval($opt) . "\n"
#  );

if(    ! -f $bx_fn
      or 
    file_modification_time($db_fn)
      >
          file_modification_time($bx_fn)    )
{
  export_database($dbname, $bx_fn, $type);
}

return if $opt->{export_only};

if(    -f $ix_fn
      and 
    file_modification_time($ix_fn)
      >=
          file_modification_time($bx_fn)    )
{
  # We didn't need to index if got here
  return;
}

if(! $opt->{spec}) {
  $opt->{fn} = $opt->{fn} || $opt->{fields} || $opt->{col} || $opt->{columns};
  my $key = $db->config('KEY');
  my @fields = grep $_ ne $key, split /[\0,\s]+/, $opt->{fn};
  my $sort = join ",", @fields;
  if(! $opt->{fn}) {
    logError(errmsg("index attempted on table '%s' with no fields, no search spec", $dbname));
    return undef;
  }
  $opt->{spec} = <<EOF;
ra=1
rf=$opt->{fn}
tf=$sort
EOF
}

my $scan = Vend::Interpolate::escape_scan($opt->{spec});
$scan =~ s:^scan/::;

my $c = {
      mv_list_only        => 1,
      mv_search_file    => $bx_fn,
    };

Vend::Scan::find_search_params($c, $scan);

$c->{mv_matchlimit} = 100000
  unless defined $c->{mv_matchlimit};
my $f_delim = $c->{mv_return_delim} || "\t";
my $r_delim = $c->{mv_record_delim} || "\n";

my @fn;
if($c->{mv_return_fields}) {
  @fn = split /\s*[\0,]+\s*/, $c->{mv_return_fields};
}

#::logDebug( "search options: " . uneval($c) . "\n");

open(Vend::Data::INDEX, "+<$ix_fn") or
  open(Vend::Data::INDEX, "+>$ix_fn") or
       die "Couldn't open $ix_fn: $!\n";
lockfile(\*Vend::Data::INDEX, 1, 1)
  or die "Couldn't exclusive lock $ix_fn: $!\n";
open(Vend::Data::INDEX, "+>$ix_fn") or
     die "Couldn't write $ix_fn: $!\n";

if(@fn) {
  print INDEX " ";
  print INDEX join $f_delim, @fn;
  print INDEX $r_delim;
}

my $ref = Vend::Scan::perform_search($c);
for(@$ref) {
  print INDEX join $f_delim, @$_; 
  print INDEX $r_delim;
}

unlockfile(\*Vend::Data::INDEX)
  or die "Couldn't unlock $ix_fn: $!\n";
close(Vend::Data::INDEX)
  or die "Couldn't close $ix_fn: $!\n";
return 1 if $opt->{show_status};
return;
}

SEE ALSO


Name

input-filter — add or remove filters applied to CGI variables

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes
remove
routine
op
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

Add or removes filters applied to CGI variables. The mechanism is similar to the filters specified by the Filter directive, the current settings are stored within the session.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

input-filter is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/input_filter.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: input_filter.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag input-filter        Order        name
UserTag input-filter        addAttr
UserTag input-filter        attrAlias    var name
UserTag input-filter        attrAlias    variable name
UserTag input-filter        attrAlias    ops op
UserTag input-filter        hasEndTag
UserTag input-filter        PosNumber    1
UserTag input-filter        Version      $Revision: 1.5 $
UserTag input-filter        MapRoutine   Vend::Interpolate::input_filter

Source: lib/Vend/Interpolate.pm
Lines: 918

sub input_filter {
my ($varname, $opt, $routine) = @_;
if($opt->{remove}) {
  return if ! ref $Vend::Session->{Filter};
  delete $Vend::Session->{Filter}{$_};
  return;
}
$opt->{routine} = $routine if $routine =~ /\S/;
$Vend::Session->{Filter} = {} if ! $Vend::Session->{Filter};
$Vend::Session->{Filter}{$varname} = $opt->{op} if $opt->{op};
return;
}

SEE ALSO


Name

item-list — iterate through items in the cart

ATTRIBUTES

AttributePos.Req.DefaultDescription
cart main name of cart to iterate through
reverse display items in reverse order
prefix item
more No enable paginating with more_list
ml 50 number of items to display
more_template template for more_list
form form parameters embedded into more links
more_routine custom routine for more_list
interpolate   0interpolate input?
reparse   1interpolate output?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

item-list is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/item_list.coretag
Lines: 38


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: item_list.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $

UserTag item-list           Order        name
UserTag item-list           addAttr
UserTag item-list           attrAlias    cart name
UserTag item-list           attrAlias    space discount_space
UserTag item-list           hasEndTag
UserTag item-list           Version      $Revision: 1.7 $
UserTag item-list           Routine      <<EOR
sub {
my($cart,$opt,$text) = @_;
return if ! $text;
my $items = $cart ? ($::Carts->{$cart} ||= []) : $Vend::Items;

my $oldspace;
$oldspace = Vend::Interpolate::switch_discount_space($opt->{discount_space})
  if defined $opt->{discount_space};

$items = [ reverse @$items ] if $opt->{reverse};
my $obj = { mv_results => $items };
$opt->{prefix} = 'item' unless defined $opt->{prefix};
# LEGACY
list_compat($opt->{prefix}, \$text);
# END LEGACY

# store the output temporarily, as we need to switch back to the old discount space...
my $output = labeled_list($opt, $text, $obj);
Vend::Interpolate::switch_discount_space($oldspace) if defined $oldspace;
return $output;
}
EOR

SEE ALSO


Name

jsonq

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

jsonq is available in Interchange versions:

5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/jsonq.coretag
Lines: 293


UserTag jsonq Order params public query
UserTag jsonq addAttr
UserTag jsonq Routine <<EOR
sub {
my ($params, $public, $query, $opt) = @_;
my $qc = $Vend::Cfg->{QueryCache} or return undef;
my $tab = $qc->{table};
my $db = dbref($tab)
  or do {
    ::logError("%s: missing table %s", 'query-cache', $tab);
    return;
  };
my $intro = $qc->{intro};

## Need to undef it if wrong because of vendURL
my $external = $qc->{external_program} || $opt->{external_program};
undef $external unless $external =~ m{^\w+:};

#::logDebug("External=$external");
# QC Table fields
# code  qid  session  qtext  meta  params  public  secure  update_date  expire_date  results

my $exp_sess = '0';
my $exp_addr = '0';
my $exp_secure = '0';
my $exp_hash = '0';
my $exp_meta = '0';
my $exp_view = '0';
my $exp_term = '0';

$opt->{expire} ||= $public ? $qc->{default_public_expire} : $qc->{default_expire};

$public      or  $exp_sess = $Vend::SessionID;
$opt->{ip}    and $exp_addr = $CGI::remote_addr;
$opt->{secure}  and $exp_secure = 1;
$opt->{params}  and $exp_term = $opt->{params};
$opt->{hash}  and $exp_hash = $opt->{hash};
$opt->{meta}  and $exp_meta = $opt->{meta};
$opt->{meta_view}  and $exp_view = $opt->{meta_view};

#::logDebug("hash=$opt->{hash}");
my $qid = Vend::Util::generate_key(join '|', $query, $exp_sess, $exp_addr, \
 $exp_term, $exp_secure, $exp_hash,$exp_meta,$exp_view);

CHECKEXIST:  {
  if(my $exist = $db->row_hash('qid',$qid) ) {
    if(my $ed = $exist->{expire_date}) {
      $ed =~ s/\D+//g;
      last CHECKEXIST if $ed lt POSIX::strftime('%Y%m%d%H%M%S', localtime());
    }
    return Vend::Util::vendUrl("$intro/$qid", undef, $external, { secure \
 => $exist->{secure}, add_dot_html => 0 });
  }
}

my $rec = { 
  qtext => $query,
  qid => $qid,
  public => $public,
  secure => $opt->{secure},
  hash => $opt->{hash},
  params => $params,
  meta_view => $opt->{meta_view},
  meta => $opt->{meta},
  content_type => $opt->{content_type},
  template => $opt->{template},
};

if($opt->{expire} =~ /\D/ or length($opt->{expire}) < 7) {
  my $add = $opt->{expire} =~ /[a-z]/ ? Vend::Config::time_to_seconds \
($opt->{expire}) : $opt->{expire} ;
  $rec->{expire_date} = POSIX::strftime('%Y%m%d%H%M%S', localtime( time() + $add ));
}
else {
  $rec->{expire_date} = $opt->{expire};
}

$rec->{session} = $Vend::SessionID unless $public;
$rec->{ipaddr} = $CGI::remote_addr if $opt->{ip};
$db->set_slice($qid, $rec);
return Vend::Util::vendUrl("$intro/$qid", undef, $external, { secure \
 => $rec->{secure}, no_session => 1, add_dot_html => 0 });
}
EOR


UserTag jsonq Documentation <<EOD
=head2 NAME

[jsonq] - Ajax query generation with security

=head2 SYNOPSIS

[jsonq
  query="select field1,field2,field3 ..."
  expire="30min|3 days|86400|20170511"
  public="0|1"
  hash="0|1|field"
  meta="option=value"
  meta-view="metaview"
  ip="0|1"
 ]

NOTE: only the query is required

=head2 CONFIGURATION

QueryCache  enabled 1
QueryCache  table  qc
QueryCache  intro  qc
QueryCache  default_expire 30min
QueryCache  default_public_expire 48hours
QueryCache  default_return {}

=head2 PREREQUISITES

Module  JSON
Module  Digest::MD5
Module  SQL::Statement
Module  SQL::Parser

=head2 DESCRIPTION

The [jsonq] tag generates a record in a table (by default C<qc>) that allows \
 users to access JSON records
created by a query. The query associated with the record will be run with \
 any parameters that are specified
being taken either from 1) CGI variables or 2) the path info.

The return value of [jsonq] is a URL to access the query.

The URL used short circuits the usual Interchange session and catalog configuration \
 mechanisms in Dispatch.pm,
allowing fast (up to 3 times faster) access to JSON records. Alternatively, \
 there can be an external handler
for requests that could increase speed dramatically.

The tag is standard, and is in the UserTag code area. It is enabled by \
 specifying any setting for the
QueryCache directive, by default "enabled 1".

=head2 The table

The C<qc> table has the following structure (in MySQL, other databases could be used):

+--------------+--------------+------+-----+-------------------+
| Field        | Type         | Null | Key | Default           |
+--------------+--------------+------+-----+-------------------+
| qid          | varchar(32)  | NO   | PRI | NULL              |
| session      | varchar(64)  | YES  |     | NULL              |
| ipaddr       | varchar(16)  | YES  |     | NULL              |
| qtext        | text         | NO   |     |                   |
| verbatim     | tinyint(1)   | YES  |     |                   |
| meta_view    | varchar(255) | YES  |     | NULL              |
| meta         | text         | YES  |     | NULL              |
| cols         | varchar(255) | YES  |     | NULL              |
| content_type | varchar(128) | YES  |     | NULL              |
| params       | text         | YES  |     | NULL              |
| template     | text         | YES  |     | NULL              |
| public       | char(1)      | YES  |     |                   |
| secure       | char(1)      | YES  |     |                   |
| hash         | varchar(32)  | YES  |     |                   |
| update_date  | timestamp    | NO   |     | CURRENT_TIMESTAMP |
| expire_date  | datetime     | YES  |     | NULL              |
| results      | text         | YES  |     | NULL              |
+--------------+--------------+------+-----+-------------------+

When the [jsonq] tag is run, the parameters act on the table in this way:

=over 4

=item query  

Enters the table as C<qtext>. This is the actual query that will run, and
is possibly affected by CGI paramers C<mv_matchlimit> and C<mv_first_match>.

=item public

Enters table as C<public> field. If this is set, query is accessible to anyone.
Do not use on private data sets.

=item params

The name of the CGI variables that will be inserted in place of any placeholders
in the query. This uses DBI methodology, so it is secure and will not allow 
SQL injection. If you wish to use the parameter in a C<LIKE> query, then append
a C<%> character to the parameter, i.e.

[jsonq params="q%" query="select * from products where description like ?"]

This causes the value of C<$CGI->{q} / [cgi q]> to be inserted surrounded by
the percent signs, causing LIKE to work with partial strings.

If you wish to use the parameter in a C<LIKE> query but only match the beginning
of the string, then I<prepend> a C<^> character to the parameter, i.e.

[jsonq params="^q" query="select * from products where description like ?"]

This causes the value of C<$CGI->{q} / [cgi q]> to be inserted followed by
the percent signs, causing LIKE to work with the first part of the string
anchored.

By default, searches are rejected (returning C<default_return>) until the
search parameter is 3 characters long. This prevents large query returns
early in parameter typing, possibly overloading the database server.
If you wish to start searching at a lower threshold (or a higher one)
then append a colon followed by a digit:

[jsonq params="^q:1" query="select * from products where description like ?"]

This causes the query to be done the moment the C<q> parameter has a single
character. A C<4> would delay return until four characters are reached,
etc.

=item hash

Enters table as C<hash> field. If this is blank, the query when run returns an "array of
arrays" in JSON.  If it is set to digits only, normally 1, then the query will return
an array of hashes. If it is set to a field name, this is the field that will be used
to create a hash of hashes. Normally you would only use a unique key for that.

=item meta_view

Selects the I<meta view> which will operate on the JSON query output. This allows
you, typically, to run Interchange filters on the output which will transform the
output data from the query. 

NOTE: If you are using the external CGI delivery mechanism, this will be ignored.

=item meta

Metadata options which will operate on the JSON query output. This allows
setting other values (such as jui_datagrid to sculpt response).

NOTE: If you are using the external CGI delivery mechanism, this will be ignored.

=item template

If you don't want JSON out, you can iterate over any array that you produce
and output text or HTML based on the Interchange I<attr_list> format. The
special areas

{PRE_TEMPLATE} Pre text {/PRE_TEMPLATE}
{POST_TEMPLATE} Post text {/POST_TEMPLATE}

allow you to add text to the template that will not be iterted over.
This invocation:

[tmpn tpl]
{PRE_TEMPLATE}<ul>{/PRE_TEMPLATE}
<li>{SKU} - {DESCRIPTION}</li>
{POST_TEMPLATE}</ul>{/POST_TEMPLATE}
[/tmpn]
[jsonq
   query="select sku,description from products where description like '%Nails%'"
    template="[scratch tpl]" hash=1 content-type="text/html"
  ]

Will produce something like this when the query is run:

<ul>
<li>os28057a - 16 Penny Nails</li>
<li>os28057b - 10 Penny Nails</li>
<li>os28057c - 8 Penny Nails</li>
</ul>

This will work no matter the state of the C<hash> parameter, as the fields are
determined. (It is probably best to use hash=1 for this query.)

=item content-type

This parameter will allow you to change the MIME type of the output from
the default of C<application/json>.

=back

=head2 URL

Here is a typical URL generated (for a catalog with a VendURL of http://www.perusion.com/c/strap):

http://www.perusion.com/c/strap/qc/059aba1aaee1debb4ecd3c67dd039e80

You can specify the URL intro with the C<intro> configuration parameter.
When it is set to C<qc>, it disables any URLs in the catalog that
begin with /qc/ and short circuits their delivery to the routine which
generates JSON.

You can manage the presentation of the query with the C<mv_matchlimit>
CGI parameter. If you specify C<mv_first_match> in addition, you can 
set up paging. (Note those are remapped to C<ml> and C<fm> in most
standard Interchange catalogs. You should take account of this if
using the external CGI method.)

NOTE: mv_first_match will not work without mv_matchlimit.

=head2 AUTHOR

Mike Heins, <mikeh@perusion.com>

=cut

EOD

SEE ALSO


Name

jsq — return a string for use in JavaScript, quoted and with variables substituted

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

jsq tag quotes (escapes) strings and performs basic variable substitution, for use in JavaScript code blocks.

This is mostly used for long strings which are hard to prepare manually.

jsquote is an alias for jsq.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic example

Here's an example of JavaScript code and the output it would generate, once expanded by Interchange:

<script>
  var astring = 'just an insert';
  var somevar = [jsq] Big long string you don't
  want to have to quote for JS, and you want to
  insert the variable $astring.[/jsq];
</script>

Expands to:

<script>
var astring = 'just an insert';
var somevar = " Big long string you don't" +
  '  want to have to quote for JS, and you want to' +
  '  insert the variable ' + astring + '.';
</script>

NOTES

AVAILABILITY

jsq is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/jsq.coretag
Lines: 31


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: jsq.coretag,v 1.8 2007-03-30 23:40:54 pajamian Exp $

UserTag jsquote Alias jsq
UserTag jsq hasEndTag
UserTag jsq NoReparse
UserTag jsq PosNumber 0
UserTag jsq Version   $Revision: 1.8 $
UserTag jsq Routine   <<EOR
sub {
my $text = shift;
$text =~ s/^[ \t\r]*\n//;
my @lines = split /\r?\n/, $text;

for(@lines) {
( $_ !~ /'/ and s/\r/\\r/g, s/(^|[^\\])\$\{?(\w+)\}?/$1' + $2 + '/g, $_ = qq{'$_'} )
  or
( $_ !~ /"/ and s/\r/\\r/g, s/(^|[^\\])\$\{?(\w+)\}?/$1" + $2 + "/g, $_ = qq{"$_"} )
  or 
( s/'/\\'/g,  s/\r/\\r/g, s/(^|[^\\])\$\{?(\w+)\}?/$1' + $2 + '/g, $_ = qq{'$_'} );
}
@lines = "''" unless @lines;
return join (" +\n", @lines);
}
EOR

AUTHORS

Mike Heins, Interchange Development Group

SEE ALSO

jsqn(7ic)


Name

jsqn — return a string for use in JavaScript, quoted, without variables substituted

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

jsqn tag quotes (escapes) strings (without performing variable substitution), for use in JavaScript code blocks.

This is mostly used for long strings which are hard to prepare manually.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic example

Here's an example of JavaScript code and the output it would generate, once expanded by Interchange:

<script>
  var astring = 'just an insert';
  var somevar = [jsqn] Big long string you don't
  want to have to quote for JS, and you don't want to
  insert the variable $astring.[/jsqn];
</script>

Expands to:

<script>
var astring = 'just an insert';
var somevar = " Big long string you don't" +
  '  want to have to quote for JS, and you don't want to' +
  '  insert the variable $astring.';
</script>

NOTES

AVAILABILITY

jsqn is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/jsqn.coretag
Lines: 30


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: jsqn.coretag,v 1.7 2007-03-30 23:40:54 pajamian Exp $

UserTag jsqn hasEndTag
UserTag jsqn NoReparse
UserTag jsqn PosNumber 0
UserTag jsqn Version   $Revision: 1.7 $
UserTag jsqn Routine   <<EOR
sub {
my $text = shift;
$text =~ s/^[ \t\r]*\n//;
my @lines = split /\r?\n/, $text;

for(@lines) {
  ( $_ !~ /'/ and s/\r/\\r/g, $_ = qq{'$_'} )
    or
  ( $_ !~ /"/ and s/\r/\\r/g, $_ = qq{"$_"} )
    or 
  ( s/'/\\'/g,  s/\r/\\r/g, $_ = qq{'$_'} );
}
@lines = "''" unless @lines;
return join (" +\n", @lines);
}
EOR

AUTHORS

Mike Heins, Interchange Development Group

SEE ALSO

jsq(7ic)


Name

jsquote

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

jsquote is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/jsq.coretag
Lines: 31


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: jsq.coretag,v 1.8 2007-03-30 23:40:54 pajamian Exp $

UserTag jsquote Alias jsq
UserTag jsq hasEndTag
UserTag jsq NoReparse
UserTag jsq PosNumber 0
UserTag jsq Version   $Revision: 1.8 $
UserTag jsq Routine   <<EOR
sub {
my $text = shift;
$text =~ s/^[ \t\r]*\n//;
my @lines = split /\r?\n/, $text;

for(@lines) {
  ( $_ !~ /'/ and s/\r/\\r/g, s/(^|[^\\])\$\{?(\w+)\}?/$1' + $2 + '/g, $_ = qq{'$_'} )
    or
  ( $_ !~ /"/ and s/\r/\\r/g, s/(^|[^\\])\$\{?(\w+)\}?/$1" + $2 + "/g, $_ = qq{"$_"} )
    or 
  ( s/'/\\'/g,  s/\r/\\r/g, s/(^|[^\\])\$\{?(\w+)\}?/$1' + $2 + '/g, $_ = qq{'$_'} );
}
@lines = "''" unless @lines;
return join (" +\n", @lines);
}
EOR

SEE ALSO


Name

l

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

l is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/loc.tag
Lines: 43


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: loc.tag,v 1.7 2007-03-30 23:40:57 pajamian Exp $

# [loc locale*] message [/loc]
#
# This tag is the equivalent of [L] ... [/L] localization, except
# it works with contained tags
#
UserTag loc Order       locale
UserTag l   Alias       loc
UserTag loc hasEndTag   1
UserTag loc Interpolate 1
UserTag loc Version     $Revision: 1.7 $
UserTag loc Routine     <<EOF
sub {
my ($locale, $message) = @_;
if($::Pragma->{no_locale_parse}) {
## Need to do this but might have side-effects in PreFork mode
undef $Vend::Parse::myRefs{Alias}{l};
my $begin = '[L';
$begin .= " $locale" if $locale;
$begin .= ']';
return $begin . $message . '[/L]';
}
return $message unless $Vend::Cfg->{Locale};
my $ref;
if($locale) {
    return $message
        unless defined $Vend::Cfg->{Locale_repository}{$locale};
    $ref = $Vend::Cfg->{Locale_repository}{$locale}
}
else {
    $ref = $Vend::Cfg->{Locale};
}
return defined $ref->{$message} ? $ref->{$message} : $message;
}
EOF

SEE ALSO


Name

labeled_data_row

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

labeled_data_row is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 3593

sub tag_labeled_data_row {
my ($key, $text) = @_;
my ($row, $table, $tabRE);
my $done;
my $prefix;

if(defined $Prefix) {
  $prefix = $Prefix;
  undef $Prefix;
  $LdB = qr(\[$prefix[-_]data$Spacef)i;
  $LdIB = qr(\[if[-_]$prefix[-_]data(\d*)$Spacef(!?)(?:%20|\s)*)i;
  $LdIE = qr(\[/if[-_]$prefix[-_]data)i;
  $LdExpr = qr{ \[(?:$prefix[-_]data|if[-_]$prefix[-_]data(\d*))
                \s+ !?\s* ($Codere) \s
        (?!$All\[(?:$prefix[-_]data|if[-_]$prefix[-_]data\1))  }xi;
  %Data_cache = ();
}
# Want the last one
#::logDebug(<<EOF);
#tag_labeled_data_row:
#  prefix=$prefix
#  LdB   =$LdB
#  LdIB  =$LdIB
#  LdIE  =$LdIE
#  LdD   =$LdD
#  LdI   =$LdI
#  LdExpr=$LdExpr
#EOF

  while($$text =~ $LdExpr) {
  $table = $2;
  $tabRE = qr/$table/;
  $row = $Data_cache{"$table.$key"}
      || ( $Data_cache{"$table.$key"}
          = Vend::Data::database_row($table, $key)
        )
      || {};
  $done = 1;
  $$text =~ s#$LdIB$tabRE$LdI$LdIE\1\]#
        $row->{$3}  ? pull_if($5,$2,$4,$row->{$3})
              : pull_else($5,$2,$4,$row->{$3})#ge
    and undef $done;
#::logDebug("after if: table=$table 1=$1 2=$2 3=$3 $$text =~ s#$LdIB $tabRE $LdI $LdIE#");

  $$text =~ s/$LdB$tabRE$LdD/ed($row->{$1})/eg
    and undef $done;
  last if $done;
}
return $_;
}

SEE ALSO


Name

levies — display total cost of levy charges

ATTRIBUTES

AttributePos.Req.DefaultDescription
recalculate force recalculation of levy charges
cart
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

levies is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/levies.coretag
Lines: 21


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: levies.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag levies            Order        group
UserTag levies            addAttr
UserTag levies            PosNumber    1
UserTag levies            Version      $Revision: 1.5 $
UserTag levies            Routine     <<EOR
sub {
my ($group, $opt) = @_;
my $cost = Vend::Interpolate::levies($opt->{recalculate}, $opt->{cart}, $opt);
return $cost unless $opt->{hide};
return '';
}
EOR


Name

levy-list — display a list of levy charges

ATTRIBUTES

AttributePos.Req.DefaultDescription
prefix levy list prefix
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

You access the levies cart with [levy-list] LIST [/levy-list]. The behavior of the list is exactly the same as with an [item-list] for a shopping cart -- [levy-param description] will access the "description" member of the hash for that levy.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example:

[levies recalculate=1 hide=1]
[levy-list]
<tr>
    <td align=left class=contentbar1>[levy-param label]:</TD>
    <td align=right class=contentbar1>[levy-param cost]</TD>
</tr>
[/levy-list]

NOTES

See levy glossary entry for more information.

AVAILABILITY

levy-list is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/levy_list.coretag
Lines: 28


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: levy_list.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag levy-list           Order        name
UserTag levy-list           addAttr
UserTag levy-list           attrAlias    cart name
UserTag levy-list           hasEndTag
UserTag levy-list           Version      $Revision: 1.5 $
UserTag levy-list           Routine      <<EOR
sub {
my($cart,$opt,$text) = @_;
my $lev = $Vend::Session->{levies} ||= {};
my $obj = {
      mv_results => $cart
              ? ($lev->{$cart} ||= [] )
              : ($lev->{$Vend::CurrentCart || 'main'} ||= [] )
        };
return if ! $text;
$opt->{prefix} = 'levy' unless defined $opt->{prefix};
return labeled_list($opt, $text, $obj);
}
EOR


Name

list-databases

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

list-databases is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/list_databases.coretag
Lines: 48


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: list_databases.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag list-databases Order   nohide extended
UserTag list-databases Version $Revision: 1.5 $
UserTag list-databases routine <<EOR
sub {
my $nohide = shift;
my $extended = shift || '';
$extended = "=$extended" if $extended;
my @dbs;
my $d = $Vend::Cfg->{Database};
@dbs = sort keys %$d;

GENDBLIST: {
  last GENDBLIST if $nohide;
  my @outdb;
  my $record =  ui_acl_enabled();
  last GENDBLIST if $record and $record->{super};
  undef $record
    unless ref($record)
         and $record->{yes_tables} || $record->{no_tables};

  for(@dbs) {
    if($record) {
      next if $record->{no_tables}
        and ui_check_acl($_, $record->{no_tables});
      my $check = "$_$extended";
      next if $record->{yes_tables}
        and ! ui_check_acl($check, $record->{yes_tables});
    }
    push @outdb, $_;
  }

  @dbs = $nohide ? (@dbs) : (@outdb);
}

return @dbs if wantarray;
my $string = join " ", grep /\S/, @dbs;
return $string;
}
EOR

SEE ALSO


Name

list-keys

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: UI_ACCESS_KEY_LIMIT

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

list-keys is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/list_keys.coretag
Lines: 78


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: list_keys.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag list-keys Order    table
UserTag list-keys addAttr
UserTag list-keys Version  $Revision: 1.5 $
UserTag list-keys Routine  <<EOR
sub {
my $table = shift;
#::logDebug("list-keys $table");
$table = $::Values->{mv_data_table}
  unless $table;
#::logDebug("list-keys $table");
my @keys;
my $record;
if(! ($record = $Vend::UI_entry) ) {
  $record =  ui_acl_enabled();
}

my $acl;
my $keys;
if($record) {
#::logDebug("list_keys: record=$record");
  $acl = get_ui_table_acl($table);
#::logDebug("list_keys table=$table: acl=$acl");
  if($acl and $acl->{yes_keys}) {
#::logDebug("list_keys table=$table: yes.keys enabled");
    @keys = grep /\S/, split /\s+/, $acl->{yes_keys};
  }
}
unless (@keys) {
  my $db = Vend::Data::database_exists_ref($table);
  return '' unless $db;
$db = $db->ref() unless $Vend::Interpolate::Db{$table};
my $keyname = $db->config('KEY');
if($db->config('LARGE')) {
return ::errmsg('--not listed, too large--');
}
my $query = "select $keyname from $table order by $keyname";
#::logDebug("list_keys: query=$query");
$keys = $db->query(
      {
        query => $query,
        ml => $::Variable->{UI_ACCESS_KEY_LIMIT} || 500,
        st => 'db',
      }
    );
if(defined $keys) {
    @keys = map {$_->[0]} @$keys;
  }
  else {
    my $k;
    while (($k) = $db->each_record()) {
      push(@keys, $k);
    }
    if( $db->numeric($db->config('KEY')) ) {
      @keys = sort { $a <=> $b } @keys;
    }
    else {
      @keys = sort @keys;
    }
  }
#::logDebug("list_keys: query=returned " . ::uneval(\@keys));
}
if($acl) {
#::logDebug("list_keys acl: ". ::uneval($acl));
  @keys = UI::Primitive::ui_acl_grep( $acl, 'keys', @keys);
}
return @keys if wantarray;
return join("\n", @keys);
}
EOR

SEE ALSO


Name

list_glob — list files matching a pattern

ATTRIBUTES

AttributePos.Req.DefaultDescription
spec Yes
prefix Yes
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: all files in a directory

[list_glob * templates/components/]

NOTES

AVAILABILITY

list_glob is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/list_glob.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: list_glob.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag list_glob Order      spec prefix
UserTag list_glob PosNumber  2 
UserTag list_glob Version    $Revision: 1.4 $
UserTag list_glob Routine    <<EOR
sub {
my @files = UI::Primitive::list_glob(@_);
return (wantarray ? @files : join "\n", @files);
}
EOR

SEE ALSO


Name

list_pages — list pages

ATTRIBUTES

AttributePos.Req.DefaultDescription
options Yes No
keep
ext
base
arrayref
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

list_pages is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/list_pages.coretag
Lines: 28


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: list_pages.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag list_pages Order   options
UserTag list_pages addAttr
UserTag list_pages Version $Revision: 1.4 $
UserTag list_pages Routine <<EOR
sub {
my ($return_options, $opt) = @_;
my $out;
my @pages = UI::Primitive::list_pages($opt->{keep},$opt->{ext},$opt->{base});
if($return_options) {
  $out = "<OPTION> " . (join "<OPTION> ", @pages);
}
elsif ($opt->{arrayref}) {
  return \@pages;
}
else {
  $out = join " ", @pages;
}
}
EOR

SEE ALSO


Name

load_cart — load shopping cart from UserDB

ATTRIBUTES

AttributePos.Req.DefaultDescription
nickname | name YesYes  Cart specification string. The string is colon-separated, and contains three fields: the cart name, time of save, and type. Time of save is measured in seconds since the epoch. Type can be c (cart) or r (recurring).
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag loads a cart from the UserDB. The loaded cart will be merged with the current one.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Merge a saved cart to the current one

Place the following on an Interchange page:

[load_cart nickname="mycart:990102732:c"]

NOTES

AVAILABILITY

load_cart is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/load_cart.tag
Lines: 28


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: load_cart.tag,v 1.5 2007-03-30 23:40:57 pajamian Exp $

UserTag load_cart Order     nickname
UserTag load_cart AttrAlias name nickname
UserTag load_cart Version   $Revision: 1.5 $
UserTag load_cart Routine   <<EOR
sub {
my($nickname) = @_;

my($jn,$updated,$recurring) = split(':',$nickname);

$Tag->userdb({function => 'get_cart', nickname => $nickname, merge => 1});
$Scratch->{just_nickname} = $jn;

if($recurring eq 'c') {
  $Tag->userdb({function => 'delete_cart', nickname => $nickname});
}

return '';
}
EOR


Name

loc — localize provided input

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

The filter uses Interchange locale features to localize received input text.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Pragmas: <pragma>no_locale_parse</pragma>

EXAMPLES

Example: Filter example

[filter loc.fr_FR]January[/filter]

NOTES

In Interchange version 4.6.0, this symbol changed type from Filter to User Tag.

AVAILABILITY

loc is available in Interchange versions:

4.6.0, 4.6.0, 4.8.0, 5.0.0, 5.2.0, 5.4.0, 5.6.0, 5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/loc.tag
Lines: 43


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: loc.tag,v 1.7 2007-03-30 23:40:57 pajamian Exp $

# [loc locale*] message [/loc]
#
# This tag is the equivalent of [L] ... [/L] localization, except
# it works with contained tags
#
UserTag loc Order       locale
UserTag l   Alias       loc
UserTag loc hasEndTag   1
UserTag loc Interpolate 1
UserTag loc Version     $Revision: 1.7 $
UserTag loc Routine     <<EOF
sub {
my ($locale, $message) = @_;
if($::Pragma->{no_locale_parse}) {
## Need to do this but might have side-effects in PreFork mode
undef $Vend::Parse::myRefs{Alias}{l};
my $begin = '[L';
$begin .= " $locale" if $locale;
  $begin .= ']';
  return $begin . $message . '[/L]';
}
  return $message unless $Vend::Cfg->{Locale};
  my $ref;
  if($locale) {
      return $message
          unless defined $Vend::Cfg->{Locale_repository}{$locale};
      $ref = $Vend::Cfg->{Locale_repository}{$locale}
  }
  else {
      $ref = $Vend::Cfg->{Locale};
  }
  return defined $ref->{$message} ? $ref->{$message} : $message;
}
EOF

SEE ALSO


Name

local

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

local is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/local.coretag
Lines: 138


# Copyright 2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: local.coretag,v 1.2 2007-08-09 13:40:52 pajamian Exp $

UserTag local Order scratch
UserTag local attrAlias scratches scratch
UserTag local attrAlias value values
UserTag local posNumber 1
UserTag local hasEndTag
UserTag local addAttr
UserTag local Description Tag to localize scratch and/or values for block
UserTag local Routine <<EOR
sub {
my ($scratch, $opt, $body) = @_;

use Storable qw/ dclone /;
$Storable::forgive_me = 1;

## It may seem simpler just to clone the top-level reference and
## be done with it, but we are going through all these gyrations
## to prevent the problem of overwriting code, which is not
## preserved with a cloning operation.
##
## Obviously (or maybe not) if you pass a top-level array which
## happens to contain a code reference, you are going to lose it.
## But code references which are in non-localized hash keys will
## survive.

my %delete_top;
my %delete;
my %settings;

# Perhaps {extra} is a bad option, but it has to be something. We
# don't have the _ intro for a key, alas. Doubt it will often be
  # used, but discounts could be localized, I suppose.

my @extra = split /[,\s\0]+/, $opt->{extra};

for my $top (qw/ values scratch /, @extra) {

  exists $Vend::Session->{$top}
    or do {
      $delete_top{$top} = 1;
      next;
    };

  my $v = $Vend::Session->{$top};

  unless (ref($v) eq 'HASH') {
    if(! ref $v) {
      $settings{$top} = $v;
    }
    else {
      $settings{$top} = dclone($v);
    }
    next;
  }

  my @values = Text::ParseWords::shellwords($opt->{$top});

  for(@values) {
    if( ! exists $v->{$_}) {
      $delete{$top}{$_} = 1;
    }
    elsif(! ref $v->{$_}) {
      $settings{$top}{$_} = $v->{$_};
    }
    else {
      $settings{$top}{$_} = dclone($v->{$_});
    }
  }
}

my $result = interpolate_html($body);

for my $top (qw/ values scratch /, @extra) {
  if(my $d = $delete_top{$top}) {
    delete $Vend::Session->{$top};
    next;
  }

  unless (ref($settings{$top}) eq 'HASH') {
    $Vend::Session->{$top} = $settings{$top};
    next;
  }

  my $s = $settings{$top};
  my $d = $delete{$top};
  my $v = $Vend::Session->{$top};

  for(keys %$d) {
    delete $v->{$_};
  }

  for(keys %$s) {
    $v->{$_} = $settings{$top}{$_};
  }
}

return $result;

}
EOR

UserTag local Documentation <<EOT
=head1 NAME

local -- localize scratch, values, etc. for code block.

=head1 SYNOPSIS

[set foo]bar[/set]

[local scratch="foo"]
  [set foo]nonbar[/set]
  foo=[scratch foo]
[/local]

[if scratch foo eq bar]
  local worked.
[else]
  local did not work, kept at [scratch foo].
[/else]
[/if]

=head1 DESCRIPTION

The local tag allows you to drop some code using scratch or values settings
in a page without the possibility of affecting the overall operation of the
site.

EOT


SEE ALSO


Name

log — write custom message to arbitrary log file

ATTRIBUTES

AttributePos.Req.DefaultDescription
file | arg Yes LogFile Name of the log file.
create No. Yes if file begins with ">". Create the log file if it doesn't exist?
process Strip leading and trailing whitespace, "normalize" newlines. Special actions to perform on the log message before writing to the log file. By default, this includes removing leading and trailing whitespace, and forcing every \r\n sequence to a single Unix line-feed character (\n). Use a value of "nostrip" to prevent default processing.
type text Log type to produce. Possible options are text (standard), quot (quotes each field, where fields are separated by delimiter), error (formats and logs message like the standard Interchange error message) and debug (formats and logs message like standard Interchange debug message). Options error and debug actually invoke Interchange's logError or logDebug functions in addition to writing to the log file (if any was specified).
record_delim A newline (\n) Line delimiter. Allows the tag to identify multiple "records" in input submitted at once.
delimiter A TAB (\t) Field delimiter. Allows the tag to identify fields within the line.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The log tag can be used to write custom, possibly multiline, log messages to arbitrary log files.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Log message to catalog's error.log

[log type=error]
An error occured.
[/log]

Or the same example that interpolates message text:

[log type=error interpolate=1]
An error occured, inform [value fname] at [value email].
[/log]

Example: Log to custom log

[log file=var/log/custom.log]
Custom log message.
[/log]

NOTES

AVAILABILITY

log is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/log.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: log.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag log                 Order        file
UserTag log                 addAttr
UserTag log                 attrAlias    arg file
UserTag log                 hasEndTag
UserTag log                 PosNumber    1
UserTag log                 Version      $Revision: 1.4 $
UserTag log                 MapRoutine   Vend::Interpolate::log

Source: lib/Vend/Interpolate.pm
Lines: 2048

sub log {
my($file, $opt, $data) = @_;
my(@lines);
my(@fields);

my $status;

$file = $opt->{file} || $Vend::Cfg->{LogFile};
if($file =~ s/^\s*>\s*//) {
  $opt->{create} = 1;
}

$file = Vend::Util::escape_chars($file);
unless(Vend::File::allowed_file($file)) {
  Vend::File::log_file_violation($file, 'log');
  return undef;
}

$file = ">$file" if $opt->{create};

unless($opt->{process} and $opt->{process} =~ /\bnostrip\b/i) {
  $data =~ s/\r\n/\n/g;
  $data =~ s/^\s+//;
  $data =~ s/\s+$/\n/;
}

my ($delim, $record_delim);
for(qw/delim record_delim/) {
  next unless defined $opt->{$_};
  $opt->{$_} = $ready_safe->reval(qq{$opt->{$_}});
}

if($opt->{type}) {
  if($opt->{type} =~ /^text/) {
    $status = Vend::Util::writefile($file, $data, $opt);
  }
  elsif($opt->{type} =~ /^\s*quot/) {
    $record_delim = $opt->{record_delim} || "\n";
    @lines = split /$record_delim/, $data;
    for(@lines) {
      @fields = Text::ParseWords::shellwords $_;
      $status = logData($file, @fields)
        or last;
    }
  }
  elsif($opt->{type} =~ /^(?:error|debug)/) {
    if ($opt->{file}) {
      $data =~ s/\n\z//;
      $data = format_log_msg($data) unless $data =~ s/^\\//;;
      $status = Vend::Util::writefile($file, $data . "\n", $opt);
    }
    elsif ($opt->{type} =~ /^debug/) {
      $status = Vend::Util::logDebug($data);
    }
    else {
      $status = Vend::Util::logError($data);
    }
  }
}
else {
  $record_delim = $opt->{record_delim} || "\n";
  $delim = $opt->{delimiter} || "\t";
  @lines = split /$record_delim/, $data;
  for(@lines) {
    @fields = split /$delim/, $_;
    $status = logData($file, @fields)
      or last;
  }
}

return $status unless $opt->{hide};
return '';
}


Name

logger

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

logger is available in Interchange versions:

5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: dist/strap/config/logger.tag
Lines: 32


UserTag logger Order name file
UserTag logger addAttr
UserTag logger Routine <<EOR
sub {
my ($name, $file, $opt) = @_;
use vars qw/$Tag/;

my $log = sub {
  my $msg = errmsg(@_);
  Log( $msg, { file => $file });
  return;
};
my $die = sub {
  my $msg = errmsg(@_);
  $Tag->error( { name => $name, set => $msg });
  Log( "died: $msg", { file => $file });
  return;
};
my $warn = sub {
  my $msg = errmsg(@_);
  $Tag->warnings( $msg );
  Log( $msg, { file => $file });
  return;
};

return($log, $die, $warn);
}
EOR
UserTag logger Documentation <<EOD
Use like:
my ($log, $die, $warn) = $Tag->logger('munge_mv_order', 'logs/munge.log');
EOD

SEE ALSO


Name

loop — iterate through a list

ATTRIBUTES

AttributePos.Req.DefaultDescription
list Yes list of items to iterate through
prefix loop
list_prefix list changes subtag for list
label
object
more No enable paginating with more_list
ml 50 number of items to display
more_template template for more_list
form form parameters embedded into more links
more_routine custom routine for more_list
mv_first_match
search
file file to read the list from
lr
quoted
extended
table
extended_only
fn
mv_field_names
delimiter
record_delim
acclist
ranges list consists of ranges like 1..4
head_skip
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

loop belongs to the so-called looping tags, see glossary for a complete discussion of this class of tags.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Loop through expiration years

<select name="mv_credit_card_exp_year">
[loop ranges=1 list="2008..2022"]
<option>[loop-code]
[/loop]
</select>

NOTES

AVAILABILITY

loop is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/loop.coretag
Lines: 17


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: loop.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag loop                Order        list
UserTag loop                addAttr
UserTag loop                attrAlias    args list
UserTag loop                attrAlias    arg list
UserTag loop                hasEndTag
UserTag loop                PosNumber    1
UserTag loop                Version      $Revision: 1.4 $
UserTag loop                MapRoutine   Vend::Interpolate::tag_loop_list

Source: lib/Vend/Interpolate.pm
Lines: 5018

sub tag_loop_list {
my ($list, $opt, $text) = @_;

my $fn;
my @rows;

$opt->{prefix} ||= 'loop';
$opt->{label}  ||= "loop" . ++$::Instance->{List_it} . $Global::Variable->{MV_PAGE};

#::logDebug("list is: " . uneval($list) );

## Thanks to Kaare Rasmussen for this suggestion
## about passing embedded Perl objects to a list

# Can pass object.mv_results=$ary object.mv_field_names=$ary
if ($opt->{object}) {
  my $obj = $opt->{object};
  # ensure that number of matches is always set
  # so [on-match] / [no-match] works
  $obj->{matches} = scalar(@{$obj->{mv_results}});
  return region($opt, $text);
}

# Here we can take the direct results of an op like
# @set = $db->query() && return \@set;
# Called with
#  [loop list=`$Scratch->{ary}`] [loop-code]
#  [/loop]
if (ref $list) {
#::logDebug("opt->list in: " . uneval($list) );
  unless (ref $list eq 'ARRAY' and ref $list->[0] eq 'ARRAY') {
    logError("loop was passed invalid list=`...` argument");
    return;
  }
  my ($ary, $fh, $fa) = @$list;
  my $obj = $opt->{object} ||= {};
  $obj->{mv_results} = $ary;
  $obj->{matches} = scalar @$ary;
  $obj->{mv_field_names} = $fa if $fa;
  $obj->{mv_field_hash} = $fh if $fh;
  if($opt->{ml}) {
    $obj->{mv_matchlimit} = $opt->{ml};
    $obj->{mv_no_more} = ! $opt->{more};
    $obj->{mv_first_match} = $opt->{mv_first_match} || 0;
    $obj->{mv_next_pointer} = $opt->{mv_first_match} + $opt->{ml};
  }
  return region($opt, $text);
}

my $delim;

if($opt->{search}) {
#::logDebug("loop resolve search");
  if($opt->{more} and $Vend::More_in_progress) {
    undef $Vend::More_in_progress;
    return region($opt, $text);
  }
  else {
    return region($opt, $text);
  }
}
elsif ($opt->{file}) {
#::logDebug("loop resolve file");
  $list = Vend::Util::readfile($opt->{file});
  $opt->{lr} = 1 unless
          defined $opt->{lr}
          or $opt->{quoted};
}
elsif ($opt->{extended}) {
  ###
  ### This returns
  ###
  my ($view, $tab, $key) = split /:+/, $opt->{extended}, 3;
  if(! $key) {
    $key = $tab;
    $tab = $view;
    undef $view;
  }
  my $id = $tab;
  $id .= "::$key" if $key;
  my $meta = Vend::Table::Editor::meta_record(
              $id,
              $view,
              $opt->{table},
              $opt->{extended_only},
              );
  if(! $meta) {
    $opt->{object} = {
        matches    => 1,
        mv_results  => [],
        mv_field_names => [],
    };
  }
  else {
    $opt->{object} = {
        matches    => 1,
        mv_results  => [ $meta ],
    };
  }
  return region($opt, $text);
}

if ($fn = $opt->{fn} || $opt->{mv_field_names}) {
  $fn = [ grep /\S/, split /[\s,]+/, $fn ];
}

if ($opt->{lr}) {
#::logDebug("loop resolve line");
  $list =~ s/^\s+//;
  $list =~ s/\s+$//;
  if ($list) {
    $delim = $opt->{delimiter} || "\t";
    my $splittor = $opt->{record_delim} || "\n";
    if ($splittor eq "\n") {
      $list =~ s/\r\n/\n/g;
    }

    eval {
      @rows = map { [ split /\Q$delim/, $_ ] } split /\Q$splittor/, $list;
    };
  }
}
elsif($opt->{acclist}) {
#::logDebug("loop resolve acclist");
  $fn = [ qw/option label/ ] unless $fn;
  eval {
    my @items = split /\s*,\s*/, $list;
    for(@items) {
      my ($o, $l) = split /=/, $_;
      $l = $o unless defined $l && $l =~ /\S/;
      push @rows, [ $o, $l ];
    }
  };
#::logDebug("rows:" . uneval(\@rows));
}
elsif($opt->{quoted}) {
#::logDebug("loop resolve quoted");
  my @l = Text::ParseWords::shellwords($list);
  produce_range(\@l) if $opt->{ranges};
  eval {
    @rows = map { [$_] } @l;
  };
}
else {
#::logDebug("loop resolve default");
  $delim = $opt->{delimiter} || '[,\s]+';
  my @l =  split /$delim/, $list;
  produce_range(\@l) if $opt->{ranges};
  eval {
    @rows = map { [$_] } @l;
  };
}

if($@) {
  logError("bad split delimiter in loop list: $@");
#::logDebug("loop resolve error $@");
}

# head_skip pulls rows off the top, and uses the last row to
# set the field names if mv_field_names/fn option was not set
if ($opt->{head_skip}) {
  my $i = 0;
  my $last_row;
  $last_row = shift(@rows) while $i++ < $opt->{head_skip};
  $fn ||= $last_row;
}

$opt->{object} = {
    matches    => scalar(@rows),
    mv_results  => \@rows,
    mv_field_names => $fn,
};

#::logDebug("loop object: " . uneval($opt));
return region($opt, $text);
}

SEE ALSO


Name

loop_list

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

loop_list is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 5018

sub tag_loop_list {
my ($list, $opt, $text) = @_;

my $fn;
my @rows;

$opt->{prefix} ||= 'loop';
$opt->{label}  ||= "loop" . ++$::Instance->{List_it} . $Global::Variable->{MV_PAGE};

#::logDebug("list is: " . uneval($list) );

## Thanks to Kaare Rasmussen for this suggestion
## about passing embedded Perl objects to a list

# Can pass object.mv_results=$ary object.mv_field_names=$ary
if ($opt->{object}) {
  my $obj = $opt->{object};
  # ensure that number of matches is always set
  # so [on-match] / [no-match] works
  $obj->{matches} = scalar(@{$obj->{mv_results}});
  return region($opt, $text);
}

# Here we can take the direct results of an op like
# @set = $db->query() && return \@set;
# Called with
#  [loop list=`$Scratch->{ary}`] [loop-code]
#  [/loop]
if (ref $list) {
#::logDebug("opt->list in: " . uneval($list) );
  unless (ref $list eq 'ARRAY' and ref $list->[0] eq 'ARRAY') {
    logError("loop was passed invalid list=`...` argument");
    return;
  }
  my ($ary, $fh, $fa) = @$list;
  my $obj = $opt->{object} ||= {};
  $obj->{mv_results} = $ary;
  $obj->{matches} = scalar @$ary;
  $obj->{mv_field_names} = $fa if $fa;
  $obj->{mv_field_hash} = $fh if $fh;
  if($opt->{ml}) {
    $obj->{mv_matchlimit} = $opt->{ml};
    $obj->{mv_no_more} = ! $opt->{more};
    $obj->{mv_first_match} = $opt->{mv_first_match} || 0;
    $obj->{mv_next_pointer} = $opt->{mv_first_match} + $opt->{ml};
  }
  return region($opt, $text);
}

my $delim;

if($opt->{search}) {
#::logDebug("loop resolve search");
  if($opt->{more} and $Vend::More_in_progress) {
    undef $Vend::More_in_progress;
    return region($opt, $text);
  }
  else {
    return region($opt, $text);
  }
}
elsif ($opt->{file}) {
#::logDebug("loop resolve file");
  $list = Vend::Util::readfile($opt->{file});
  $opt->{lr} = 1 unless
          defined $opt->{lr}
          or $opt->{quoted};
}
elsif ($opt->{extended}) {
  ###
  ### This returns
  ###
  my ($view, $tab, $key) = split /:+/, $opt->{extended}, 3;
  if(! $key) {
    $key = $tab;
    $tab = $view;
    undef $view;
  }
  my $id = $tab;
  $id .= "::$key" if $key;
  my $meta = Vend::Table::Editor::meta_record(
              $id,
              $view,
              $opt->{table},
              $opt->{extended_only},
              );
  if(! $meta) {
    $opt->{object} = {
        matches    => 1,
        mv_results  => [],
        mv_field_names => [],
    };
  }
  else {
    $opt->{object} = {
        matches    => 1,
        mv_results  => [ $meta ],
    };
  }
  return region($opt, $text);
}

if ($fn = $opt->{fn} || $opt->{mv_field_names}) {
  $fn = [ grep /\S/, split /[\s,]+/, $fn ];
}

if ($opt->{lr}) {
#::logDebug("loop resolve line");
  $list =~ s/^\s+//;
  $list =~ s/\s+$//;
  if ($list) {
    $delim = $opt->{delimiter} || "\t";
    my $splittor = $opt->{record_delim} || "\n";
    if ($splittor eq "\n") {
      $list =~ s/\r\n/\n/g;
    }

    eval {
      @rows = map { [ split /\Q$delim/, $_ ] } split /\Q$splittor/, $list;
    };
  }
}
elsif($opt->{acclist}) {
#::logDebug("loop resolve acclist");
  $fn = [ qw/option label/ ] unless $fn;
  eval {
    my @items = split /\s*,\s*/, $list;
    for(@items) {
      my ($o, $l) = split /=/, $_;
      $l = $o unless defined $l && $l =~ /\S/;
      push @rows, [ $o, $l ];
    }
  };
#::logDebug("rows:" . uneval(\@rows));
}
elsif($opt->{quoted}) {
#::logDebug("loop resolve quoted");
  my @l = Text::ParseWords::shellwords($list);
  produce_range(\@l) if $opt->{ranges};
  eval {
    @rows = map { [$_] } @l;
  };
}
else {
#::logDebug("loop resolve default");
  $delim = $opt->{delimiter} || '[,\s]+';
  my @l =  split /$delim/, $list;
  produce_range(\@l) if $opt->{ranges};
  eval {
    @rows = map { [$_] } @l;
  };
}

if($@) {
  logError("bad split delimiter in loop list: $@");
#::logDebug("loop resolve error $@");
}

# head_skip pulls rows off the top, and uses the last row to
# set the field names if mv_field_names/fn option was not set
if ($opt->{head_skip}) {
  my $i = 0;
  my $last_row;
  $last_row = shift(@rows) while $i++ < $opt->{head_skip};
  $fn ||= $last_row;
}

$opt->{object} = {
    matches    => scalar(@rows),
    mv_results  => \@rows,
    mv_field_names => $fn,
};

#::logDebug("loop object: " . uneval($opt));
return region($opt, $text);
}

SEE ALSO


Name

mail

ATTRIBUTES

AttributePos.Req.DefaultDescription
raw
extra
show
success
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

mail is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/mail.coretag
Lines: 15


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: mail.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag mail                Order        to
UserTag mail                addAttr
UserTag mail                hasEndTag
UserTag mail                PosNumber    1
UserTag mail                Version      $Revision: 1.5 $
UserTag mail                MapRoutine   Vend::Interpolate::tag_mail

Source: lib/Vend/Interpolate.pm
Lines: 2538

sub tag_mail {
  my($to, $opt, $body) = @_;
  my($ok);

my @todo = (
        qw/
          From      
          To       
          Subject   
          Reply-To  
          Errors-To 
        /
);

my $abort;
my $check;

my $setsub = sub {
  my $k = shift;
  return if ! defined $CGI::values{"mv_email_$k"};
  $abort = 1 if ! $::Scratch->{mv_email_enable};
  $check = 1 if $::Scratch->{mv_email_enable};
  return $CGI::values{"mv_email_$k"};
};

my @headers;
my %found;

unless($opt->{raw}) {
  for my $header (@todo) {
    logError("invalid email header: %s", $header)
      if $header =~ /[^-\w]/;
    my $key = lc $header;
    $key =~ tr/-/_/;
    my $val = $opt->{$key} || $setsub->($key); 
    if($key eq 'subject' and ! length($val) ) {
      $val = errmsg('<no subject>');
    }
    next unless length $val;
    $found{$key} = $val;
    $val =~ s/^\s+//;
    $val =~ s/\s+$//;
    $val =~ s/[\r\n]+\s*(\S)/\n\t$1/g;
    push @headers, "$header: $val";
  }
  unless($found{to} or $::Scratch->{mv_email_enable} =~ /\@/) {
    return
      error_opt($opt, "Refuse to send email message with no recipient.");
  }
  elsif (! $found{to}) {
    $::Scratch->{mv_email_enable} =~ s/\s+/ /g;
    $found{to} = $::Scratch->{mv_email_enable};
    push @headers, "To: $::Scratch->{mv_email_enable}";
  }
}

if($opt->{extra}) {
  $opt->{extra} =~ s/^\s+//mg;
  $opt->{extra} =~ s/\s+$//mg;
  push @headers, grep /^\w[-\w]*:/, split /\n/, $opt->{extra};
}

$body ||= $setsub->('body');
unless($body) {
  return error_opt($opt, "Refuse to send email message with no body.");
}

$body = format_auto_transmission($body) if ref $body;

push(@headers, '') if @headers;

return error_opt("mv_email_enable not set, required.") if $abort;
if($check and $found{to} ne $Scratch->{mv_email_enable}) {
  return error_opt(
      "mv_email_enable to address (%s) doesn't match enable (%s)",
      $found{to},
      $Scratch->{mv_email_enable},
    );
}

  SEND: {
  $ok = send_mail(\@headers, $body);
  }

  if (!$ok) {
  close MAIL;
  $body = substr($body, 0, 2000) if length($body) > 2000;
      return error_opt(
        "Unable to send mail using %s\n%s",
        $Vend::Cfg->{SendMailProgram},
        join("\n", @headers, $body),
      );
}

delete $Scratch->{mv_email_enable} if $check;
return if $opt->{hide};
return join("\n", @headers, $body) if $opt->{show};
  return ($opt->{success} || $ok);
}

Source: lib/Vend/Interpolate.pm
Lines: 2538

sub tag_mail {
  my($to, $opt, $body) = @_;
  my($ok);

my @todo = (
        qw/
          From      
          To       
          Subject   
          Reply-To  
          Errors-To 
        /
);

my $abort;
my $check;

my $setsub = sub {
  my $k = shift;
  return if ! defined $CGI::values{"mv_email_$k"};
  $abort = 1 if ! $::Scratch->{mv_email_enable};
  $check = 1 if $::Scratch->{mv_email_enable};
  return $CGI::values{"mv_email_$k"};
};

my @headers;
my %found;

unless($opt->{raw}) {
  for my $header (@todo) {
    logError("invalid email header: %s", $header)
      if $header =~ /[^-\w]/;
    my $key = lc $header;
    $key =~ tr/-/_/;
    my $val = $opt->{$key} || $setsub->($key); 
    if($key eq 'subject' and ! length($val) ) {
      $val = errmsg('<no subject>');
    }
    next unless length $val;
    $found{$key} = $val;
    $val =~ s/^\s+//;
    $val =~ s/\s+$//;
    $val =~ s/[\r\n]+\s*(\S)/\n\t$1/g;
    push @headers, "$header: $val";
  }
  unless($found{to} or $::Scratch->{mv_email_enable} =~ /\@/) {
    return
      error_opt($opt, "Refuse to send email message with no recipient.");
  }
  elsif (! $found{to}) {
    $::Scratch->{mv_email_enable} =~ s/\s+/ /g;
    $found{to} = $::Scratch->{mv_email_enable};
    push @headers, "To: $::Scratch->{mv_email_enable}";
  }
}

if($opt->{extra}) {
  $opt->{extra} =~ s/^\s+//mg;
  $opt->{extra} =~ s/\s+$//mg;
  push @headers, grep /^\w[-\w]*:/, split /\n/, $opt->{extra};
}

$body ||= $setsub->('body');
unless($body) {
  return error_opt($opt, "Refuse to send email message with no body.");
}

$body = format_auto_transmission($body) if ref $body;

push(@headers, '') if @headers;

return error_opt("mv_email_enable not set, required.") if $abort;
if($check and $found{to} ne $Scratch->{mv_email_enable}) {
  return error_opt(
      "mv_email_enable to address (%s) doesn't match enable (%s)",
      $found{to},
      $Scratch->{mv_email_enable},
    );
}

  SEND: {
  $ok = send_mail(\@headers, $body);
  }

  if (!$ok) {
  close MAIL;
  $body = substr($body, 0, 2000) if length($body) > 2000;
      return error_opt(
        "Unable to send mail using %s\n%s",
        $Vend::Cfg->{SendMailProgram},
        join("\n", @headers, $body),
      );
}

delete $Scratch->{mv_email_enable} if $check;
return if $opt->{hide};
return join("\n", @headers, $body) if $opt->{show};
  return ($opt->{success} || $ok);
}

SEE ALSO


Name

menu — displays HTML menu

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes  name of menu file
joiner    HTML code appearing between menu entries
localize    list of fields to localize
logged_in    selection field for authorized users
menu_type  simplemenu type (simple, tree, flyout)
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag reads a tab-separated menu file and display its contents according to the parameters. The template for each menu entry can be passed in the tag body. Selection fields determine which menu entries are displayed. The following columns are recognized in the menu file:

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Simple Menubar

<table><tr>
[menu name=Menubar localize=name joiner='<td><img src="menu_separator.png"></td>']
<td class="menubar" valign="center" align="center">
<a href="{HREF}" class="menubar">{NAME}</a>
</td>
[/menu]
</tr></table>

Example: Simple Menubar with Different Links

[menu name="links"]
<span class="links">
{HREF?}<a href="{HREF}" class="links">{NAME}</a>{/HREF?}
{URL?}<a href="{URL}" class="links">{NAME}</a>{/URL?}
</span>
[/menu]

This menu contains links to external sites (href) and internal pages (url).


Example: Flyout Menu

[menu
	name="Products"
	link-class="barlink"
	flyout-class="flyout_class"
	flyout-style="flyout_style"
	menu-type=flyout
][/menu]

NOTES

uc-attr-list carries out the replacements in the template.

AVAILABILITY

menu is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/menu.coretag
Lines: 20


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: menu.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag menu Order       name
UserTag menu hasEndTag
UserTag menu addAttr
UserTag menu noReparse
UserTag menu Version     $Revision: 1.4 $
UserTag menu Routine     <<EOR
require Vend::Menu;
sub {
return Vend::Menu::menu(@_);
}
EOR


Name

menu-load

ATTRIBUTES

AttributePos.Req.DefaultDescription
type
menu_fields
table
first_field
second_field
desc_field
description_field
key_field
even_large
sort_fields
no_leaves
sku_field
comb_field
sort_string
sort_order
cat_table
sel
html
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

menu-load is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/menu_load.coretag
Lines: 569


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: menu_load.coretag,v 1.9 2007-03-30 23:40:54 pajamian Exp $

UserTag menu-load Order    type
UserTag menu-load addAttr
UserTag menu-load Version  $Revision: 1.9 $
UserTag menu-load Routine  <<EOR
sub old_link {
my ($row, $nrow) = @_;
#Debug("row link_type='$row->{link_type}'");
if($row->{link_type} eq 'external') {
  my $first;
  $first = $row->{url};
  $first =~ s/\s+$//;
  $first =~ s/^\s+//;
  $nrow->{page} = $first;
}
elsif  ($row->{link_type} eq 'internal') {
  my ($page, $form) = split /\s+/, $row->{url}, 2;
  $nrow->{page} = $page;
  $nrow->{form} = $form;
}
elsif  ($row->{link_type} eq 'simple') {
  my (@items) = split /\s*[\n,]\s*/, $row->{selector};
  my @out;
  my $fi = $row->{tab};
  my $sp = $row->{page};
  my $arg = '';
  $nrow->{page} = 'search';
  push @out, "fi=$fi" if $fi;
  push @out, "sp=$sp" if $sp;
  push @out, "st=db";

  if(! @items) {
    push @out, "ra=yes";
    $nrow->{form} = join "&", @out;
  }
  else {
  push @out, "co=yes";
  for(@items) {
    my ($col, $string) = split /\s*=\s*/, $_, 2;
    push @out, "sf=$col";
    push @out, "se=$string";
  }
  push @out, $row->{search}
    if $row->{search} =~ /^\s*\w\w=/;

  push @out, qq{va=banner_image=$row->{banner_image}}
    if $row->{banner_image};
  push @out, qq{va=banner_text=$row->{banner_text}}
    if $row->{banner_text};
  for(@out) {
    s/(.*?=)(.*)/$1 . Vend::Util::hexify($2)/ges;
  }
  $arg = join $Global::UrlJoiner, @out;
  $nrow->{form} = $arg;
  }
}
elsif  ($row->{link_type} eq 'complex') {
  $nrow->{page} = 'search';
  $row->{search} =~ s/[\r\n+]/\n/g;
  $row->{search} .= qq{\nva=banner_text=$row->{banner_text}}
    if $row->{banner_text};
  $row->{search} .= qq{\nva=banner_image=$row->{banner_image}}
    if $row->{banner_image};
  my @items = grep /\S/, split /[\r\n]+/, $row->{search};
  for(@items) {
    s/(.*?=)(.*)/$1 . Vend::Util::hexify($2)/ges;
  }
  $nrow->{form} = join $Global::UrlJoiner, @items;
  $nrow->{form} =~ s/[\r\n]+/&/g;
}
return $nrow;
}

sub {
my ($type, $opt) = @_;
#::logDebug("Called menu_load");
$type ||= $opt->{type} || 'tree';

my @menufields;
if($opt->{menu_fields}) {
  @menufields = grep /\S/, split /[\s,\0]+/, $opt->{menu_fields};
}
else {
  @menufields = qw/
    code mgroup msort next_line indicator exclude_on depends_on page
    form name super inactive description help_name img_dn img_up
    img_sel img_icon url member
  /;
}

my %menuinit = (
      code => 0,
      inactive => 0,
      msort => "'x'",
      );

my @out;

if ($type eq 'tree') {
  $opt->{table} ||= 'products';
  $opt->{first_field} ||= 'prod_group';
  $opt->{second_field} ||= 'category';
  $opt->{desc_field} ||= $opt->{description_field} || 'description';
#::logDebug("menu_load options=" . uneval($opt));
  PRODBUILD: {
    my $tab = $opt->{table};
    my $db = database_exists_ref($tab)
      or do {
        Vend::Tags->error({ set => errmsg(
                  "Failed to open %s table %s.",
                  'products',
                  $tab,
                  ),
                });
        last PRODBUILD;
      };
    my $tname = $db->name();
#::logDebug("LARGE=" . $db->config('LARGE'));
    $opt->{key_field} ||= $db->config('KEY');
    if(! $opt->{even_large} and $db->config('LARGE')) {
      Vend::Tags->error({ set => errmsg(
                  "%s database %s for tree write: %s",
                  'check',
                  $tab,
                  'too large, must override',
                ),
              });
      last PRODBUILD;
    }
    my @somefields = qw/mgroup page name description/;
    my @fields = (
            $opt->{key_field},
            $opt->{first_field},
            $opt->{second_field},
            $opt->{desc_field}
          );
    my $sfields = join ",", @fields;
    my $tfields = $opt->{sort_fields} || join ",", @fields[1..$#fields];
    my $q = qq{SELECT $sfields FROM $tname ORDER BY $tfields};
    my $ary = $db->query($q)
            or do {
              Vend::Tags->error({
                  set => errmsg(
                    "No results from %s table %s.",
                    'products',
                    $tname,
                  ),
                });
        last PRODBUILD;
      };
    my $prev_area = '';
    my $prev_cat = '';
    @out = join "\t", @menufields;
    my @rows;
    my $base_search = "scan/co=yes/fi=$tab";

    for(@$ary) {
      my($sku, $area, $cat, $desc) = @$_;
      for( \$sku, \$area, \$cat, \$desc) {
        $$_ =~ s/\s+$//;
      }
      if($area ne $prev_area) {
        $prev_area = $area;
        $prev_cat = '';
        my $url = join '/',
              $base_search,
              "sf=$opt->{first_field}",
              "se=$area",
              "op=eq",
              "tf=$opt->{second_field},$opt->{desc_field}",
              ;
        push @rows, {
            %menuinit,
            msort => 0,
            page  => $url,
            inactive => 0,
            name => $area,
            };
      }
      if($cat ne $prev_cat) {
        $prev_cat = $cat;
        my $url = join '/',
              $base_search,
              "sf=$opt->{first_field}",
              "se=$area",
              "op=eq",
              "sf=$opt->{second_field}",
              "se=$cat",
              "op=eq",
              "tf=$opt->{desc_field}",
              ;

        push @rows, {
            %menuinit,
            msort => 1,
            page  => $url,
            inactive => 0,
            name => $cat,
            };
      }
      push @rows, {
        %menuinit,
        msort => 2,
        name => $desc,
        inactive => 0,
        page => $sku,
      } unless $opt->{no_leaves};
    }

    for(@rows) {
#::logDebug("pushing out --> " . $_->{name});
      push @out, join "\t", @{$_}{@menufields};
    }
  }
}
elsif ($type eq 'category_file') {
  $opt->{table} ||= 'category';
  $opt->{first_field} ||= 'prod_group';
  $opt->{second_field} ||= 'category';
#::logDebug("menu_load options=" . uneval($opt));
  CATBUILD: {
    my $tab = $opt->{table};
    my $db = database_exists_ref($tab)
      or do {
        Vend::Tags->error({ set => errmsg(
                  "Failed to open %s table %s.",
                  'products',
                  $tab,
                  ),
                });
        last CATBUILD;
      };
    my $tname = $db->name();
#::logDebug("LARGE=" . $db->config('LARGE'));
    $opt->{key_field} ||= $db->config('KEY');
    $opt->{sku_field} ||= 'sku';

    unless ( $db->column_exists($opt->{sku_field}) ) {
      Vend::Tags->error({ set => errmsg(
                  "%s database %s for tree write: %s",
                  'check',
                  $tab,
                  "sku field $opt->{key_field} does not exist",
                ),
              });
      last CATBUILD;

    }

    my @somefields = qw/mgroup page name description/;
    my @fields = (
            $opt->{key_field},
            $opt->{first_field},
            $opt->{second_field},
            );
    push @fields, $opt->{desc_field} if $opt->{desc_field};

    my $sfields = join ",", @fields;
    my $tfields = $opt->{sort_fields};
    if(! $tfields) {
      $tfields = "$opt->{first_field},$opt->{second_field}";
      $tfields .= ",$opt->{desc_field}" if $opt->{desc_field};
    }

    my $q = qq{SELECT $sfields FROM $tname ORDER BY $tfields};
#::logDebug("category_file menu_load query=$q");
    my $ary = $db->query($q)
            or do {
              Vend::Tags->error({
                  set => errmsg(
                    "No results from %s table %s.",
                    'products',
                    $tname,
                  ),
                });
        last CATBUILD;
      };
    my $prev_area = '';
    my $prev_cat = '';
    @out = join "\t", @menufields;
    my @rows;
    my $base_search = "scan/co=yes/fi=$tab/rf=$opt->{sku_field}";
    $base_search .= "/tf=$opt->{desc_field}" if $opt->{desc_field};

    for(@$ary) {
      my($sku, $area, $cat, $desc) = @$_;
      for(\$area, \$cat) {
        $$_ =~ s/\s+$//;
      }
      if($area ne $prev_area) {
        $prev_area = $area;
        $prev_cat = '';
        my $url = join '/',
              $base_search,
              "sf=$opt->{first_field}",
              "se=$area",
              "op=eq",
              "tf=$opt->{second_field}",
              ;
        push @rows, {
            %menuinit,
            msort => 0,
            page  => $url,
            inactive => 0,
            name => $area,
            };
      }
      if($cat ne $prev_cat) {
        $prev_cat = $cat;
        my $url = join '/',
              $base_search,
              "sf=$opt->{first_field}",
              "se=$area",
              "op=eq",
              "sf=$opt->{second_field}",
              "se=$cat",
              "op=eq",
              ;

        push @rows, {
            %menuinit,
            msort => 1,
            page  => $url,
            inactive => 0,
            name => $cat,
            };
      }
    }

    for(@rows) {
#::logDebug("pushing out --> " . $_->{name});
      push @out, join "\t", @{$_}{@menufields};
    }
  }
}
elsif ($type eq 'comb_category') {
  $opt->{table} ||= 'products';
  $opt->{comb_field} ||= 'comb_category';
  $opt->{sort_string} ||= "tf=$opt->{comb_field},$Vend::Cfg->{DescriptionField}";
  $opt->{sort_order} ||= $opt->{comb_field};


  COMB_BUILD: {
      my $tab = $opt->{table};
      my $comb_field = $opt->{comb_field};
      my $db = $Db{$tab}
          or do {
              $Tag->error({ set => errmsg(
                  "Failed to open %s table %s.",
                  'products',
                  $tab,
                  ),
              });
              last COMB_BUILD;
            };

#Debug("LARGE=" . $db->config('LARGE'));
      if(! $opt->{even_large} and $db->config('LARGE')) {
        $Tag->error({ set => errmsg(
                "%s database %s for tree write: %s",
                'check',
                $tab,
                'too large, must override',
                ),
        });
        last COMB_BUILD;
      }
      my @somefields = qw/mgroup page name description/;
      my $q = qq{
          SELECT $comb_field
          FROM $tab
          ORDER BY $comb_field
          };
      my $ary = $db->query($q)
            or do {
              $Tag->error({
                  set => errmsg(
                      "No results from %s table %s.",
                      'products',
                      $tab,
                    ),
                });
                last COMB_BUILD;
              };
      @out = join "\t", @menufields;
      my @rows;
      my @base_search = (  "bs=1", 
            "em=1", 
            "su=1", 
            "fi=$tab", 
            "st=db"
            );  
      my @levels;
      my %seen;

      $seen{$_->[0]}++ for @$ary;
      for(sort keys %seen) {
        my $comb_category = $_;
        $comb_category =~ s/\s+$//;

        my @parts = split /:/, $comb_category;
        my $combname = '';
        for( my $i = 0; $i < @parts; $i++) {
          my $level = $levels[$i] ||= {};
          my $name = $parts[$i];
          my $comb = join ":", @parts[0 .. $i];
          if(! $level->{$name}) {
            $level->{$name}++;

            my $searchterm = "se="; 
            $searchterm .= $Tag->filter('urlencode',$comb);
            my $form = join "&",
                  @base_search,
                  $opt->{sort_string},
                  "sf=$comb_field",
                  $searchterm
                  ;
            push @rows,   {
                  %menuinit,
                  msort  => $i,
                  page  => 'search',
                  inactive  => 0,
                  name  => $name,
                  form  => $form,
                };
          }
        }
      }


    for(@rows) {
#Debug("pushing out --> " . $_->{name});
      push @out, join "\t", @{$_}{@menufields};
    }
#return join("<br>",@out);
  }
}
elsif ($type eq 'cat_menu') {
  AREABUILD: {
    my $tab = $opt->{table} || 'area';
    my $ctab = $opt->{cat_table} || 'cat';
    my $db = database_exists_ref($tab)
      or do {
        Vend::Tags->error({ set => errmsg(
                  "Failed to open %s table %s.",
                  'area',
                  $tab,
                  ),
                });
        last AREABUILD;
      };
#Debug("LARGE=" . $db->config('LARGE'));
    my $q = qq{ SELECT * FROM $tab};
    $q .= qq{ WHERE sel = '$opt->{sel}'}
      if $opt->{sel};
    $q .= qq{ ORDER BY sort };
    my $ary = $db->query({ sql => $q, hashref => 1 } )
            or do {
              Vend::Tags->error({
                  set => errmsg(
                    "No results from %s table %s.",
                    'area',
                    $tab,
                  ),
                });
            last AREABUILD;
          };

    @out = join "\t", @menufields;

    my @rows;
    my $nc = '0000';
    my $cdb = database_exists_ref($ctab)
          or do {
            Vend::Tags->error({
                set => errmsg(
                  "No results from %s table %s.",
                  'category',
                  $tab,
                ),
              });
            last AREABUILD;
          };
    my $ctabname = $cdb->name();
    foreach my $row (@$ary) {
      my $code = $row->{code};
      my $nrow = {
        code => $nc++,
        name => $row->{name},
        img_icon => $row->{image},
        msort => 0,
        mgroup => $row->{set_selector},
      };
      old_link($row, $nrow);
      my $sq = qq{
          SELECT * FROM $ctabname
          WHERE sel = '$code'
          OR    sel like '$code %'
          OR    sel like '% $code'
          OR    sel like '% $code %'
          ORDER BY sort
          };
#Debug("subquery=$sq");
      push @rows, $nrow;
      my $sary = $cdb->query({ sql => $sq, hashref => 1 });
#Debug("subquery returned: " . uneval($sary));
      for my $crow (@$sary) {
        my $nsub = {
          code => $nc++,
          name => $crow->{name},
          img_icon => $crow->{image},
          msort => 1,
          mgroup => $crow->{sel},
        };
        old_link($crow, $nsub);
        push @rows, $nsub;
      }
    }
    for(@rows) {
#Debug("pushing out --> " . $_->{name});
      push @out, join "\t", @{$_}{@menufields};
#Debug("pushing out --> row=" . uneval($_));
    }
  }
}
elsif($type eq 'html') {

  my $text = $opt->{html};
  my $start = '0001';
  @out = join "\t", @menufields;
  while($text =~ s{<a(\s+.*?)</a>}{}is) {
    my $blob = $1;
    my $desc = '';
    $blob =~ m{^[^>]*\s+title=(['"]?)(.*?)\1}
      and $desc = $2;
    $blob =~ s{^.*?\shref\s*=\s*(["'])?(.*?)\1}{}is
      or next;
    my $link = $2;
    $blob =~ s/.*?>//;
    1 while $blob =~ s{<.*?>}{};
    my $anchor = $blob;
    my $sort = $start;
    $sort =~ s/./x/;
    my($href, $parms) = split /\?/, $link, 2;
    my %record = (
      code => $start++,
      msort => $sort,
      page => $href,
      form => $parms,
      name => $anchor,
      description => $desc,
    );

    push @out, join "\t", @record{@menufields};
  }

}
return '' unless @out;
return join "\n", @out, '';
}
EOR

SEE ALSO


Name

meta-info

ATTRIBUTES

AttributePos.Req.DefaultDescription
item
meta_table
specific
view
extended_only
localize
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

meta-info is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/meta_info.coretag
Lines: 52


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: meta_info.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag meta-info Order      table column key
UserTag meta-info attrAlias  col column
UserTag meta-info addAttr
UserTag meta-info Version    $Revision: 1.4 $
UserTag meta-info Routine    <<EOR
sub {
my ($table, $col, $key, $opt) = @_;

my $item;
if($table) {
  $item = $table;
  $item .= "::$col" if $col;
}

$item ||= $opt->{item} or return undef;
my $meta;
my $mdb;

if($opt->{meta_table}) {
  $mdb = dbref($opt->{meta_table});
}

my @tries = $item;

if($opt->{specific}) {
  unshift @tries, $item . "::$opt->{specific}";
}

for(@tries) {
  $meta = Vend::Table::Editor::meta_record(
              $_,
              $opt->{view},
              $mdb,
              $opt->{extended_only},
            )
      and last;
}
return undef unless $meta;
#::logDebug("Got meta record back, looking for $key: " . ::uneval($meta));
return errmsg($meta->{$key}) if $opt->{localize};
return $meta->{$key};
}
EOR

SEE ALSO


Name

meta-record

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

meta-record is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/meta_record.coretag
Lines: 13


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: meta_record.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag meta-record Order      item view source
UserTag meta-record attrAlias  table item
UserTag meta-record Version    $Revision: 1.5 $
UserTag meta-record MapRoutine Vend::Table::Editor::meta_record

Source: lib/Vend/Table/Editor.pm
Lines: 720

sub meta_record {
my ($item, $view, $mdb, $extended_only, $overlay) = @_;

#::logDebug("meta_record: item=$item view=$view mdb=$mdb");
return undef unless $item;

my $mtable;
if(! ref ($mdb)) {
  $mtable = $mdb || $::Variable->{UI_META_TABLE} || 'mv_metadata';
#::logDebug("meta_record mtable=$mtable");
  $mdb = database_exists_ref($mtable)
    or return undef;
}
#::logDebug("meta_record has an item=$item and mdb=$mdb");

my $record;

my $mkey = $view ? "${view}::$item" : $item;

if( ref ($mdb) eq 'HASH') {
  $record = $mdb;
}
else {
  $record = $mdb->row_hash($mkey);
#::logDebug("used mkey=$mkey to select record=$record");
}

$record ||= $mdb->row_hash($item) if $view and $mdb;
#::logDebug("meta_record  record=$record");

return undef if ! $record;

# Get additional settings from extended field, which is a serialized
# hash
my $hash;
if(! $record->{extended}) {
    return undef if $extended_only;
}
else {
  ## From Vend::Util
  $hash = get_option_hash($record->{extended});
  $record = {} if $extended_only;
  if(ref $hash eq 'HASH') {
    @$record{keys %$hash} = values %$hash;
  }
  else {
    undef $hash;
    return undef if $extended_only;
  }
}

# Allow view settings to be placed in the extended area
if($view and $hash and $hash->{view}) {
  my $view_hash = $record->{view}{$view};
  ref $view_hash
    and @$record{keys %$view_hash} = values %$view_hash;
}

# Allow overlay of certain settings
if($overlay and $record->{overlay}) {
  my $ol_hash = $record->{overlay}{$overlay};
  Vend::Util::copyref($ol_hash, $record) if $ol_hash;
}
#::logDebug("return meta_record=" . ::uneval($record) );
return $record;
}

SEE ALSO


Name

mm-value — display UI access control value

ATTRIBUTES

AttributePos.Req.DefaultDescription
field yes
table yes
user
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Display current user

[mm-value user]

NOTES

AVAILABILITY

mm-value is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/mm_value.coretag
Lines: 55


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: mm_value.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag mm-value Order     field table
UserTag mm-value addAttr
UserTag mm-value Version   $Revision: 1.4 $
UserTag mm-value Routine   <<EOR
sub {
my($field, $table, $opt, $text) = @_;

my $record;
my $status;
my $reverse;
my $uid = $opt->{user};
unless ($record = $Vend::UI_entry) {
  return '' unless ref($record = ui_acl_enabled());
}
#::logDebug("mm-value record: " . ::uneval($record));
$table = $opt->{table} || $::Scratch->{ui_data_table};

if($field eq 'user') {
  return $Vend::Session->{ui_username} || $Vend::Session->{username} || $CGI::user;
}

my %hash_field = qw/
          acl_keys      1
          no_fields     1
          yes_fields    1
          no_keys       1
          yes_keys      1
          owner_field   1
        /;

my $acl;
my $check;
if($check = $hash_field{$field}) {
  if ($field eq 'acl_keys') {
    return join "\n", get_ui_table_acl($table, $uid, 1);
  }
  else {
    $acl = get_ui_table_acl($table, $uid);
    return $acl->{$field};
  }
}
else {
  return $record->{$field};
}
}
EOR


Name

mm_locale

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

mm_locale is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/mm_locale.coretag
Lines: 33


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: mm_locale.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag mm_locale Version $Revision: 1.5 $
UserTag mm_locale Routine <<EOR
sub {
my $locale = $Values->{ui_locale} || $Tag->var('UI_LOCALE', 2);
my $lref;

# tell Shadow database to return the unmangled database records
$Tag->tmp('mv_shadowpass', 1);

# first delete locale settings from catalog
$Vend::Cfg->{Locale_repository} = {};

if ($locale && exists $Global::Locale_repository->{$locale}) {
  $lref = $Vend::Cfg->{Locale_repository}{"$locale"} 
    = $Global::Locale_repository->{$locale};
  $Tag->setlocale("$locale");
  $Tag->tmp('mv_locale', $locale);
  if ($lref->{MV_LANG_DIRECTION}) {
    $Tag->tmp('ui_language_direction', qq{ dir="$lref->{MV_LANG_DIRECTION}"});
  }
}  
1;
}
EOR

SEE ALSO


Name

more_list — pagination for Interchange lists

ATTRIBUTES

AttributePos.Req.DefaultDescription
more_routine custom routine for more_list
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

more_list can be used in lists produced by the query, search_region ... tags.

Template for More Lists

The default template for more lists looks like that:

{FIRST_LINK?}{FIRST_LINK} {/FIRST_LINK?}
{PREV_LINK?}{PREV_LINK} {/PREV_LINK?}
{DECADE_PREV?}{DECADE_PREV} {/DECADE_PREV?}
     {MORE_LIST}
{DECADE_NEXT?} {DECADE_NEXT}{/DECADE_NEXT?}
{NEXT_LINK?} {NEXT_LINK}{/NEXT_LINK?}
{LAST_LINK?} {LAST_LINK}{/LAST_LINK?}

The following values will be recognized in the template:

ValueDescription
MATCH_COUNTSame as [match-count], number of matches
MATCHESSame as [matches]
LAST_PAGELast page number
CURRENT_PAGECurrent page number
DECADE_FIRSTFirst page of decade
DECADE_LASTLast page of decade
FIRST_MATCHFirst match displayed on this page
LAST_MATCHLast match displayed on this page
FIRST_LINKLink to first page
PREV_LINKLink to previous page
DECADE_PREVLink to previous decade
MORE_LISTThe page list
DECADE_NEXTLink to next decade
NEXT_LINKLink to next page
LAST_LINKLink to last page

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

more_list is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 3521

sub tag_more_list {
(
  $next_anchor,
  $prev_anchor,
  $page_anchor,
  $border,
  $border_selected,
  $opt,
  $r,
) = @_;

if(my $name = $opt->{more_routine}) {
  my $sub = $Vend::Cfg->{Sub}{$name} || $Global::GlobalSub->{$name};
  return $sub->(@_) if $sub;
}
#::logDebug("more_list: opt=$opt label=$opt->{label}");
return undef if ! $opt;
$q = $opt->{object} || $::Instance->{SearchObject}{$opt->{label}};
return '' unless $q->{matches} > $q->{mv_matchlimit}
  and $q->{mv_matchlimit} > 0;
my($arg,$inc,$last,$m);
my($adder,$pages);
my($first_anchor,$last_anchor);
my %hash;

  ($pretty_url, $incl_pageno) = ();
  if ($r =~ m{\[more[-_]pretty[-_]url\]}i) {
#::logDebug('$r matched on more-pretty-url');
      $r =~ s{\[more[-_]pretty[-_]url\]($All)\[/more[-_]pretty[-_]url\]}{}i
          and $pretty_url = $q->{more_pretty_url} ||= ::interpolate_html($1);
      $r =~ s{\[more[-_]incl[-_]pageno\]($All)\[/more[-_]incl[-_]pageno\]}{}i
          and $incl_pageno = $q->{more_incl_pageno} ||= $1 || '1';
  }

$session = $q->{mv_cache_key};
my $first = $q->{mv_first_match} || 0;
$chunk = $q->{mv_matchlimit};
$perm = $q->{mv_more_permanent} ? ':1' : '';
$total = $q->{matches};
my $next = defined $q->{mv_next_pointer}
      ? $q->{mv_next_pointer}
      : $first + $chunk;
$page = $q->{mv_search_page} || $Global::Variable->{MV_PAGE};
$prefix = $q->{prefix} || '';
my $form_arg = "mv_more_ip=1\nmv_nextpage=$page";
$form_arg .= "\npf=$q->{prefix}" if $q->{prefix};
$form_arg .= "\n$opt->{form}" if $opt->{form};
if($q->{mv_more_id}) {
  $more_id = $q->{mv_more_id};
  $form_arg .= "\nmi=$more_id";
}
else {
  $more_id = undef;
}

my $more_joiner = $opt->{more_link_joiner} || ' ';

if($r =~ s:\[border\]($All)\[/border\]::i) {
  $border = $1;
  $border =~ s/\D//g;
}
if($r =~ s:\[border[-_]selected\]($All)\[/border[-_]selected\]::i) {
  $border = $1;
  $border =~ s/\D//g;
}

undef $link_template;
$r =~ s:\[link[-_]template\]($All)\[/link[-_]template\]::i
  and $link_template = $1;
$link_template ||= q{<a href="$URL$">$ANCHOR$</a>};

if(! $chunk or $chunk >= $total) {
  return '';
}

$border = qq{ border="$border"} if defined $border;
$border_selected = qq{ border="$border_selected"}
  if defined $border_selected;

$adder = ($total % $chunk) ? 1 : 0;
$pages = int($total / $chunk) + $adder;
$current = int($next / $chunk) || $pages;

if($first) {
  $first = 0 if $first < 0;

  # First link may appear when prev link is valid
  if($r =~ s:\[first[-_]anchor\]($All)\[/first[-_]anchor\]::i) {
    $first_anchor = $1;
  }
  else {
    $first_anchor = errmsg('First');
  }
  unless ($first_anchor eq 'none') {
    $arg = $session;
    $arg .= ':0:';
    $arg .= $chunk - 1;
    $arg .= ":$chunk$perm";
    $hash{first_link} = more_link_template($first_anchor, $arg, $form_arg, 1);
  }

  unless ($prev_anchor) {
    if($r =~ s:\[prev[-_]anchor\]($All)\[/prev[-_]anchor\]::i) {
      $prev_anchor = $1;
    }
    else {
      $prev_anchor = errmsg('Previous');
    }
  }
  elsif ($prev_anchor ne 'none') {
    $prev_anchor = qq%<img src="$prev_anchor"$border>%;
  }
  unless ($prev_anchor eq 'none') {
    $arg = $session;
    $arg .= ':';
    $arg .= $first - $chunk;
    $arg .= ':';
    $arg .= $first - 1;
    $arg .= ":$chunk$perm";
    $hash{prev_link} = more_link_template($prev_anchor, $arg, $form_arg, \
 $current && $current - 1);
  }

}
else {
  $r =~ s:\[(prev|first)[-_]anchor\]$All\[/\1[-_]anchor\]::ig;
}

if($next) {

  unless ($next_anchor) {
    if($r =~ s:\[next[-_]anchor\]($All)\[/next[-_]anchor\]::i) {
      $next_anchor = $1;
    }
    else {
      $next_anchor = errmsg('Next');
    }
  }
  else {
    $next_anchor = qq%<img src="$next_anchor"$border>%;
  }
  $last = $next + $chunk - 1;
  $last = $last > ($total - 1) ? $total - 1 : $last;
  $arg = "$session:$next:$last:$chunk$perm";
  $hash{next_link} = more_link_template($next_anchor, $arg, $form_arg, $current && $current + 1);

   # Last link can appear when next link is valid
  if($r =~ s:\[last[-_]anchor\]($All)\[/last[-_]anchor\]::i) {
    $last_anchor = $1;
  }
  else {
    $last_anchor = errmsg('Last');
  }
  unless ($last_anchor eq 'none') {
    $last = $total - 1;
    my $last_beg_idx = $total - ($total % $chunk || $chunk);
    $arg = "$session:$last_beg_idx:$last:$chunk$perm";
    $hash{last_link} = more_link_template($last_anchor, $arg, $form_arg, \
 $chunk && ceil($total / $chunk));
  }
}
else {
  $r =~ s:\[(last|next)[-_]anchor\]$All\[/\1[-_]anchor\]::gi;
}

unless ($page_anchor) {
  if($r =~ s:\[page[-_]anchor\]($All)\[/page[-_]anchor\]::i) {
    $page_anchor = $1;
  }
  else {
    $page_anchor = '__PAGE__';
  }
}
elsif ($page_anchor ne 'none') {
  $page_anchor = qq%<img src="$page_anchor?__PAGE__"__BORDER__>%;
}

$page_anchor =~ s/\$(MIN|MAX)?PAGE\$/__${1}PAGE__/g;

my $more_string = errmsg('more');
my ($decade_next, $decade_prev, $decade_div);
if( $q->{mv_more_decade} or $r =~ m:\[decade[-_]next\]:) {
  $r =~ s:\[decade[-_]next\]($All)\[/decade[-_]next\]::i
    and $decade_next = $1;
  $decade_next = "<small>&#91;$more_string&gt;&gt;&#93;</small>"
    if ! $decade_next;
  $r =~ s:\[decade[-_]prev\]($All)\[/decade[-_]prev\]::i
    and $decade_prev = $1;
  $decade_prev = "<small>&#91;&lt;&lt;$more_string&#93;</small>"
    if ! $decade_prev;
  $decade_div = $q->{mv_more_decade} > 1 ? $q->{mv_more_decade} : 10;
}

my ($begin, $end);
if(defined $decade_div and $pages > $decade_div) {
  if($current > $decade_div) {
    $begin = ( int ($current / $decade_div) * $decade_div ) + 1;
    $hash{decade_prev} = more_link($begin - $decade_div, $decade_prev);
  }
  else {
    $begin = 1;
  }
  if($begin + $decade_div <= $pages) {
    $end = $begin + $decade_div;
    $hash{decade_next} = more_link($end, $decade_next);
    $end--;
  }
  else {
    $end = $pages;
    delete $hash{$decade_next};
  }
#::logDebug("more_list: decade found pages=$pages current=$current begin=$begin \
 end=$end next=$next last=$last decade_div=$decade_div");
}
else {
  ($begin, $end) = (1, $pages);
  delete $hash{$decade_next};
}
#::logDebug("more_list: pages=$pages current=$current begin=$begin end=$end \
 next=$next last=$last decade_div=$decade_div page_anchor=$page_anchor");

my @more_links;
if ($q->{mv_alpha_list}) {
  for my $record (@{$q->{mv_alpha_list}}) {
    $arg = "$session:$record->[2]:$record->[3]:" . ($record->[3] - $record->[2] + 1);
    my $letters = substr($record->[0], 0, $record->[1]);
    push @more_links, more_link_template($letters, $arg, $form_arg);
  }
  $hash{more_alpha} = join $more_joiner, @more_links;
}
else {
  foreach $inc ($begin .. $end) {
    last if $page_anchor eq 'none';
    push @more_links, more_link($inc, $page_anchor);
  }
  $hash{more_numeric} = join $more_joiner, @more_links;
}

if ($r =~ s:\[all[-_]anchor\]($All)\[/all[-_]anchor\]::i and ($first or $next)) {
  my $all_anchor = $1;
  $arg = "$session:0:0:100000";
  push @more_links, more_link_template($all_anchor, $arg, $form_arg);
}

$hash{more_list} = join $more_joiner, @more_links;

$first = $first + 1;
$last = $first + $chunk - 1;
$last = $last > $total ? $total : $last;
$m = $first . '-' . $last;
$hash{matches} = $m;
$hash{first_match} = $first;
$hash{last_match} = $last;
$hash{decade_first} = $begin;
$hash{decade_last} = $end;
$hash{last_page} = $hash{total_pages} = $pages;
$hash{current_page} = $current;
$hash{match_count} = $q->{matches};

if($r =~ /{[A-Z][A-Z_]+[A-Z]}/ and $r !~ $QR{more}) {
  return tag_attr_list($r, \%hash, 1);
}
else {
  my $tpl = qq({FIRST_LINK?}{FIRST_LINK} {/FIRST_LINK?}{PREV_LINK?}{PREV_LINK} \
 {/PREV_LINK?}{DECADE_PREV?}{DECADE_PREV} {/DECADE_PREV?}{MORE_LIST}{DECADE_NEXT \
?} {DECADE_NEXT}{/DECADE_NEXT?}{NEXT_LINK?} {NEXT_LINK}{/NEXT_LINK \
?}{LAST_LINK?} {LAST_LINK}{/LAST_LINK?});
  $tpl =~ s/\s+$//;
  my $list = tag_attr_list($opt->{more_template} || $tpl, \%hash, 1);
  $r =~ s,$QR{more},$list,g;
  $r =~ s,$QR{matches},$m,g;
  $r =~ s,$QR{match_count},$q->{matches},g;
  return $r;
}

}

SEE ALSO


Name

msg

ATTRIBUTES

AttributePos.Req.DefaultDescription
raw
arg
locale
inline
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

msg is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/msg.coretag
Lines: 66


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: msg.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag msg                 Order        key
UserTag msg                 addAttr
UserTag msg                 attrAlias    lc inline
UserTag msg                 hasEndTag
UserTag msg                 Interpolate
UserTag msg                 PosNumber    1
UserTag msg                 Version      $Revision: 1.4 $
UserTag msg                 Routine      <<EOR
sub {
my ($key, $opt, $body) = @_;
my (@args, $message, $out, $startlocale);

unless ($opt->{raw}) {
  if (ref $opt->{arg} eq 'ARRAY') {
    @args = @{ $opt->{arg} };
  } elsif (ref $opt->{arg} eq 'HASH') {
    @args = map { $opt->{arg}->{$_} } sort keys %{ $opt->{arg} };
  } elsif (! ref $opt->{arg}) {
    @args = $opt->{arg};
  }
}

if ($opt->{locale}) {
  # we only mess with scratch mv_locale because
  # Vend::Util::find_locale_bit uses it to determine current locale
  $startlocale = $::Scratch->{mv_locale};
  Vend::Util::setlocale($opt->{locale}, undef, { persist => 1 });
}

if ($opt->{inline}) {
  $message = Vend::Util::find_locale_bit($body);
} else {
  $message = $body;
}

if ($key) {
  if ($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$key}) {
    $message = $Vend::Cfg->{Locale}{$key};
  } elsif ($Global::Locale and defined $Global::Locale->{$key}) {
    $message = $Global::Locale->{$key};
  }
}

if ($opt->{raw}) {
  $out = $message;
} else {
  $out = errmsg($message, @args);
}

if ($opt->{locale}) {
  $::Scratch->{mv_locale} = $startlocale;
  Vend::Util::setlocale();
}

return $out;
}
EOR

SEE ALSO


Name

mvasp

ATTRIBUTES

AttributePos.Req.DefaultDescription
table | tables
no_return
interpolate   0interpolate input?
reparse   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

mvasp is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/mvasp.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: mvasp.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag mvasp               Order        tables
UserTag mvasp               addAttr
UserTag mvasp               attrAlias    table tables
UserTag mvasp               Gobble
UserTag mvasp               hasEndTag
UserTag mvasp               PosNumber    1
UserTag mvasp               NoReparse
UserTag mvasp               Version      $Revision: 1.5 $
UserTag mvasp               MapRoutine   Vend::Interpolate::mvasp

Source: lib/Vend/Interpolate.pm
Lines: 1574

sub mvasp {
my ($tables, $opt, $text) = @_;
my @code;
$opt->{no_return} = 1 unless defined $opt->{no_return};

while ( $text =~ s/(.*?)<%//s || $text =~ s/(.+)//s ) {
  push @code, <<EOF;
; my \$html = <<'_MV_ASP_EOF$^T';
$1
_MV_ASP_EOF$^T
chop(\$html);
  HTML( \$html );
EOF
  $text =~ s/(.*?)%>//s
    or last;;
  my $bit = $1;
  if ($bit =~ s/^\s*=\s*//) {
    $bit =~ s/;\s*$//;
    push @code, "; HTML( $bit );"
  }
  else {
    push @code, $bit, ";\n";
  }
}
my $asp = join "", @code;
#::logDebug("ASP CALL:\n$asp\n");
return tag_perl ($tables, $opt, $asp);
}


Name

newer

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

newer is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/newer.coretag
Lines: 39


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: newer.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag newer Order    source target
UserTag newer Version  $Revision: 1.4 $
UserTag newer Routine  <<EOR
sub {
my ($source, $file2) = @_;
my $file1 = $source;
if(! $file2 and $source !~ /\./) {
  if($Global::GDBM) {
    $file1 .= '.gdbm';
  }
  elsif($Global::DB_File) {
    $file1 .= '.db';
  }
  else {
    return undef;
  }
  $file2 = $Vend::Cfg->{Database}{$source}{'file'}
    or return undef;
  $file1 = $Vend::Cfg->{ProductDir} . '/' . $file1
    unless $file1 =~ m:/:;
  $file2 = $Vend::Cfg->{ProductDir} . '/' . $file2
    unless $file2 =~ m:/:;
}
my $time1 = (stat($file1))[9]
  or return undef;
my $time2 = (stat($file2))[9];
return 1 if $time1 > $time2;
return 0;
}
EOR

SEE ALSO


Name

nitems — return the total number of items in the electronic cart

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes main Cart name.
lines 0 Whether to show the number of lines in the cart instead of the sum of the items.
qualifier An item attribute that must evaluate to a true value, in order for the item to be counted.
compare Instead of counting items based solely on item attribute "trueness" (as qualifier= does by default), perform the specified regular expression pattern matching on the qualifier= attribute.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag returns the total number of items in users' electronic cart.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic example

You have [nitems] items in your cart.

NOTES

AVAILABILITY

nitems is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/nitems.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: nitems.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag nitems              Order        name
UserTag nitems              addAttr
UserTag nitems              PosNumber    1
UserTag nitems              Version      $Revision: 1.5 $
UserTag nitems              MapRoutine   Vend::Util::tag_nitems

Source: lib/Vend/Util.pm
Lines: 1501

sub tag_nitems {
my($ref, $opt) = @_;
  my($cart, $total, $item);

if($ref) {
   $cart = $::Carts->{$ref}
     or return 0;
}
else {
  $cart = $Vend::Items;
}

my ($attr, $sub);
if($opt->{qualifier}) {
  $attr = $opt->{qualifier};
  my $qr;
  eval { 
    $qr = qr{$opt->{compare}} if $opt->{compare};
  };
  if($qr) {
    $sub = sub { 
            $_[0] =~ $qr;
          };
  }
  else {
    $sub = sub { return $_[0] };
  }
}

if($opt->{lines}) {
  return scalar(grep {! $attr or $sub->($_->{$attr})} @$cart);
}

  $total = 0;
  foreach $item (@$cart) {
  next if $attr and ! $sub->($item->{$attr});

              if ($opt->{gift_cert} && $item->{$opt->{gift_cert}}) {
                  $total++;
                  next;
              }

  $total += $item->{'quantity'};
  }
  $total;
}

SEE ALSO


Name

object

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

object is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 3929

sub tag_object {
my ($count, $item, $hash, $opt, $body) = @_;
my $param = delete $hash->{param}
  or return undef;
my $method;
my $out = '';
eval {
  if(not $method = delete $hash->{method}) {
    $out = $item->{$param}->();
  }
  else {
    $out = $item->{$param}->$method();
  }
};
return $out;
}

SEE ALSO


Name

onfly

ATTRIBUTES

AttributePos.Req.DefaultDescription
text
create
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

onfly is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/onfly.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: onfly.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag onfly               Order        code quantity
UserTag onfly               addAttr
UserTag onfly               PosNumber    2
UserTag onfly               Version      $Revision: 1.4 $
UserTag onfly               MapRoutine   Vend::Order::onfly

Source: lib/Vend/Order.pm
Lines: 717

sub onfly {
my ($code, $qty, $opt) = @_;
my $item_text;
if (ref $opt) {
  $item_text = $opt->{text} || '';
}
else {
  $item_text = $opt;
  $opt = {};
}

#  return create_onfly() if $opt->{create};

my $joiner    = $::Variable->{MV_ONFLY_JOINER} || '|';
my $split_fields= $::Variable->{MV_ONFLY_FIELDS} || undef;

$item_text =~ s/\s+$//;
$item_text =~ s/^\s+//;
my @parms;
my @fields;
$joiner = quotemeta $joiner;
@parms = split /$joiner|\0/, $item_text;
my ($k, $v);
my $item = {};
if(defined $split_fields) {
  @fields = split /[,\s]+/, $split_fields;
  @{$item}{@fields} = @parms;
}
else {
  for(@parms) {
    ($k, $v)  = split /=/, $_;
    $item->{$k} = $v;
  }
}
$item->{mv_price} = $item->{price}
  if ! $item->{mv_price};
$item->{code}    = $code  if ! $item->{code};
$item->{quantity} = $qty  if ! $item->{quantity};
return $item;
}

SEE ALSO


Name

options

ATTRIBUTES

AttributePos.Req.DefaultDescription
code Yes Yes
options_type
admin_page
routine_description
admin_page_routine
display_routine
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

options is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/options.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: options.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag options             Order        code
UserTag options             addAttr
UserTag options             PosNumber    1
UserTag options             Version      $Revision: 1.5 $
UserTag options             MapRoutine   Vend::Options::tag_options

Source: lib/Vend/Options.pm
Lines: 233

sub tag_options {
my ($sku, $opt) = @_;
my $item;
if(ref $sku) {
  $item = $sku;
  $sku = $item->{mv_sku} || $item->{code};
}
$item ||= { code => $sku };
$opt = get_option_hash($opt);
find_joiner($opt);

my $module = find_options_type($item, $opt)
  or return '';
$opt->{options_type} = $module;
#::logDebug("tag_options module=$module");

my $loc = $Vend::Cfg->{Options_repository}{$module} || {};
no strict 'refs';
my $routine;
if($opt->{admin_page}) {
  $opt->{routine_description} ||= "admin page";
  $routine = $opt->{admin_page_routine}
    ||= "Vend::Options::${module}::admin_page";
}
else {
  $opt->{routine_description} ||= "display";
  $routine = $opt->{display_routine};
  $routine ||= $loc->{display_routine}
      ||= "Vend::Options::${module}::display_options";
#::logDebug("tag_options display routine=$routine");
}
my $sub = \&{"$routine"};
if(! defined $sub) {
  ::logOnce(
    "Options type %s %s routine %s not found, aborting options for %s.",
    $module,
    $opt->{routine_description},
    $routine,
    $sku,
    );
  return undef;
}
#::logDebug("main tag_options item=" . ::uneval($item) . ", opt=" . ::uneval($opt));
return $sub->($item, $opt, $loc);
}


Name

order — produce an order link

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ code | item | sku ] Yes Yes Item SKU
quantity Yes Quantity to order.
base Ordered list of particular product files to search. If unspecified, all tables defined as ProductFiles will be searched.
cart cart name
[ mv_sku | variant ]
form
page
area
arg
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

order displays an URL which adds an item to the shopping cart upon following the link. The next page is determined by order SpecialPage.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example:

<a href="[order code="IC2008" quantity=10 area=1]">Buy 10 Interchange T-Shirts</a>

NOTES

AVAILABILITY

order is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/order.coretag
Lines: 58


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: order.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $

UserTag order               Order        code quantity
UserTag order               attrAlias    item code
UserTag order               attrAlias    sku code
UserTag order               attrAlias    table base
UserTag order               attrAlias    database base
UserTag order               attrAlias    db base
UserTag order               attrAlias    mv_ib base
UserTag order               attrAlias    href page
UserTag order               attrAlias    variant mv_sku
UserTag order               addAttr
UserTag order               PosNumber    2
UserTag order               Version      $Revision: 1.7 $
UserTag order               Routine      <<EOR
# Returns an href to place an order for the product PRODUCT_CODE.
# If AlwaysSecure is set, goes by the page accessed, otherwise 
# if a secure order has been started (with a call to at least
# one secure_vendUrl), then it will be given the secure URL
sub {
  my($code,$quantity,$opt) = @_;
$opt = {} unless $opt;
my @parms = (
        "mv_action=refresh",
        );

push(@parms, "mv_order_item=$code");
push(@parms, "mv_order_mv_ib=$opt->{base}")
  if($opt->{base});

push(@parms, "mv_cartname=$opt->{cart}")
  if($opt->{cart});

push(@parms, "mv_order_quantity=$quantity")
  if($quantity);

push @parms, "mv_sku=$opt->{mv_sku}" if $opt->{mv_sku};

$opt->{form} .= "\n" . join "\n", @parms;

$opt->{page} = find_special_page('order')
  unless $opt->{page};

if ($opt->{area}) {
  return tag_area($opt->{page}, $opt->{arg}, $opt);
}
else {
  return tag_page($opt->{page}, $opt->{arg}, $opt);
}
}
EOR


Name

output-to — map output

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes No space name
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

output-to allows you to map pieces of a page to different named spaces and unpack them with the unpack tag.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Use space "htmlhead"

[output-to name="htmlhead"]

Example: Return to default space

[output-to name=""]

NOTES

AVAILABILITY

output-to is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/output_to.tag
Lines: 24


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: output_to.tag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag output-to Order      name
UserTag output-to addAttr
UserTag output-to hasEndTag
UserTag output-to Version    $Revision: 1.4 $
UserTag output-to Routine    <<EOR
sub {
my ($name, $opt, $body) = @_;
$name ||= '';
$name = lc $name;
my $nary = $Vend::OutPtr{$name} ||= [];
push @Vend::Output, \$body;
push @$nary, $#Vend::Output;
return;
}
EOR

SEE ALSO

unpack(7ic)


Name

page — produce a hypertext link

ATTRIBUTES

AttributePos.Req.DefaultDescription
Standard options    See options for tag area.
extra   None. Name of a CSS class to insert as class=....
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The page tag expands to a proper hypertext URL link which preserves Interchange session information and arguments passed onto the targeted page or form action. The target page argument you supply is treated relatively to the pages/ directory inside your catalog root directory (CATROOT).

The enclosing <a href=""></a> HTML tag is included. Where this is unwanted, use area.

Besides just producing hypertext links to specific pages, you can also "embed" complete HTML forms in the target link (for say, one-click ordering or searches); see the section called “EXAMPLES”.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Produce the basic hypertext link

Add the following to an Interchange page:

Please visit our [page index]Welcome</a> page.

Example: Pass arguments onto the target page

Add the following link to an Interchange page:

Visit the [page href='test' arg='arg1=value1/arg2=value2']test</a> page.

The relevant part of your test.html page could then look like this:

<p>This is a test page.</p>

[if session arg]
<p>You have passed an argument onto this page:</p>
<p>[data session arg]</p>
[else]
You did not pass any arguments to this page.
[/else]
[/if]

<p>Have a nice day!</p>


Example: Simple item ordering using the page tag

Order a [page order TK112]Toaster</a> today.

Example: Embedding HTML forms in the page tag

[page form="
  mv_order_item=99-102
  mv_order_size=L
  mv_order_quantity=1
  mv_separate_items=1
  mv_todo=refresh"
]Order T-shirt in Large size</a>

Or another example:

[page form="
  mv_todo=refresh
  mv_order_item=000101
  mv_order_fly=description=An on-the-fly item|price=100.01
"]Order item 000101</a>

Which is equivalent to the usual HTML form:

<form action="[area process]" method="post">
  <input type='hidden' name='mv_todo' value="refresh">
  <input type='hidden' name='mv_order_item' value="000101">
  Qty: <input size='2' name='mv_order_quantity' value="1">
  <input type='hidden' name='mv_order_fly' value="description=An on-the-fly item|price=100.00">
  <input type='submit' value="Order button">
</form>

Example: Implementing searches using href=/arg= options

[page scan
    se=Impressionists
    sf=category]
Search for Impressionist Paintings</a>

Or the equivalent, using named parameters and more understandable quoting:

[page href=scan
    arg="se=Impressionists
         sf=category"]
Search for Impressionist Paintings</a>

If the arg parameter is set, it will be available within the search display page as [value mv_arg].


Example: Implementing searches using search= option

The search attribute is a shorthand for the href / arg scheme. When search is used, href will be set to scan and arg to the value of search .

[page search="
    se=Impressionists
    sf=category"]
Search for Impressionist Paintings</a>

NOTES

The page tag examples use some advanced argument-quoting concepts. To minimize confusion, please see the proper and complete quoting explanation in the ITL glossary entry.

Since the page already includes an opening HTML link (the "<a href=...>" part), the only thing left is to close it using "</a>" after typing in the link text. There is a [/page] macro in existence, but it translates directly to </a> — which means typing </a> directly saves parser a little work. The use of this macro is discouraged and you should always insert "</a>" directly.

AVAILABILITY

page is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/page.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: page.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag page                Order        href arg
UserTag page                addAttr
UserTag page                attrAlias    base arg
UserTag page                Implicit     secure secure
UserTag page                PosNumber    2
UserTag page                version      $Revision: 1.4 $
UserTag page                MapRoutine   Vend::Interpolate::tag_page

Source: lib/Vend/Interpolate.pm
Lines: 2685

sub tag_page {
  my ($page, $arg, $opt) = @_;

my $url = tag_area(@_);

my $extra;
if($extra = ($opt ||= {})->{extra} || '') {
  $extra =~ s/^(\w+)$/class=$1/;
  $extra = " $extra";
}
  return qq{<a href="$url"$extra>};
}

Source: lib/Vend/Interpolate.pm
Lines: 2685

sub tag_page {
  my ($page, $arg, $opt) = @_;

my $url = tag_area(@_);

my $extra;
if($extra = ($opt ||= {})->{extra} || '') {
  $extra =~ s/^(\w+)$/class=$1/;
  $extra = " $extra";
}
  return qq{<a href="$url"$extra>};
}


Name

page-meta

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: MV_PAGE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

page-meta is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/page_meta.tag
Lines: 30


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: page_meta.tag,v 1.4 2007-03-30 23:40:57 pajamian Exp $

UserTag page-meta Order   page
UserTag page-meta addAttr
UserTag page-meta Version $Revision: 1.4 $
UserTag page-meta Routine <<EOR
sub {
my ($page, $opt) = @_;
$page ||= $Global::Variable->{MV_PAGE};
$page = "pages/$page";
my $meta = Vend::Table::Editor::meta_record($page)
or return;
while (my ($k, $v) = each %$meta) {
  next if $k eq 'code';
  next unless length $v;
  if($v =~ /\[\w/ or $v =~ /__[A-Z]\w+__/) {
    $v = interpolate_html($v);
  }
  set_tmp($k,$v);
}
return;
}
EOR

SEE ALSO


Name

parse_locale

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

parse_locale is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/parse_locale.coretag
Lines: 13


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: parse_locale.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag parse_locale hasEndTag  
UserTag parse_locale PosNumber  0
UserTag parse_locale Version    $Revision: 1.4 $
UserTag parse_locale MapRoutine Vend::Util::parse_locale

Source: lib/Vend/Util.pm
Lines: 1134

sub parse_locale {
my ($input) = @_;

return if $::Pragma->{no_locale_parse};

# avoid copying big strings
my $r = ref($input) ? $input : \$input;

if($Vend::Cfg->{Locale}) {
  my $key;
  $$r =~ s~\[L(\s+([^\]]+))?\]((?s:.)*?)\[/L\]~
          $key = $2 || $3;    
          defined $Vend::Cfg->{Locale}{$key}
          ?  ($Vend::Cfg->{Locale}{$key})  : $3 ~eg;
  $$r =~ s~\[LC\]((?s:.)*?)\[/LC\]~
          find_locale_bit($1) ~eg;
  undef $Lang;
}
else {
  $$r =~ s~\[L(?:\s+[^\]]+)?\]((?s:.)*?)\[/L\]~$1~g;
}

# return scalar string if one get passed initially
return ref($input) ? $input : $$r;
}

SEE ALSO


Name

pay-cert

ATTRIBUTES

AttributePos.Req.DefaultDescription
code Yes Yes if auth=true
code_scratch
check_scratch
order_number Yes if issue=true
transaction
issue 0 Issue (create) the gift certificate?
amount Yes if issue=true Gift certificate amount.
expires | expire | expiration Validity period, specified as one of X y(ears), mon(ths), m(inutes), h(ours), d(ays) or w(eeks).
no_cookie Do not issue a MV_GIFT_CERT_CODE cookie to the client's browser?
item_pointer
cart
auth
items
tid
capture
new_tid
void
return
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: GIFT_CERT_COUNTER, GIFT_CERT_TABLE, GIFT_CERT_REDEEM_TABLE, GIFT_CERT_LOCK_TABLE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

pay-cert is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: dist/strap/config/pay_cert.tag
Lines: 370


UserTag pay-cert Order code
UserTag pay-cert addAttr
UserTag pay-cert Routine <<EOR
sub {
my ($code, $opt) = @_;

use vars qw/$Tag/;

my ($log, $die2, $warn) = $Tag->logger('pay_cert', 'logs/pay_cert.log');

my $counter_file = $::Variable->{GIFT_CERT_COUNTER} || 'etc/pay_cert.number';
my $cert_table   = $::Variable->{GIFT_CERT_TABLE}     || 'pay_certs';
my $redeem_table = $::Variable->{GIFT_CERT_REDEEM_TABLE} || 'pay_cert_redeem';
my $lock_table   = $::Variable->{GIFT_CERT_LOCK_TABLE}   || 'pay_cert_lock';

my $ldb = dbref($lock_table) 
or return $die2->("cannot open payment certs lock table '%s'", $lock_table);

my $ltab = $ldb->name();
my $ldbh = $ldb->dbh()
  or return $die2->("cannot get handle for certs lock table '%s'", $lock_table);
my $q = "insert into $ltab (code, pid, ip_addr) values (?,?,?)";

my $locked;

my $sth_lock = $ldbh->prepare($q)
  or return $die2->("cannot prepare lock query '%s'", $q);

$q = "delete from $ltab where code = ?";
my $sth_unlock = $ldbh->prepare($q)
  or return $die2->("cannot prepare lock query '%s'", $q);

my $die = sub {
  my $msg = errmsg(@_);
  Log( "died: $msg", { file => 'logs/pay_cert.log' });
  eval {
    $sth_unlock->execute($code) if $locked;
  };
  $Tag->error( { name => 'pay_cert', set => $msg } );
  return undef;
};

$opt->{code_scratch} = 'pay_cert_code'    unless defined $opt->{code_scratch};
$opt->{check_scratch} = 'pay_cert_check'  unless defined $opt->{check_scratch};
$opt->{order_number} ||= $::Values->{mv_order_number};

if($opt->{transaction}) {
  $opt->{$opt->{transaction}} = 1;
}

if($opt->{issue}) {
  if(! $opt->{order_number}) {
    return $die->("Must have order number to issue payment certificate. Not issued.");
  }
  if(! $opt->{amount}) {
    return $die->("Must specify amount to issue payment certificate. Not issued.");
  }
  
  ## Time to issue a certificate
  my $start = int(rand 300000);
  $start .= '0' while length($start) < 6;
  my $base = $Tag->counter({ file => $counter_file, start => $start });
  $base .= int(rand(10));
  for(0 .. 9) {
    $code = $base . $_;
    last if Vend::Order::luhn($code, 8);
  }

  my $now = time;
  my @date_issued = localtime($now);
  my @date_expires;
  my $issue_date = POSIX::strftime('%Y%m%d%H%M%S', @date_issued);
  my $expire_date = '';
  $opt->{expires} ||= $opt->{expire} || $opt->{expiration};
  if($opt->{expires} =~ /^\s*(\d+)\s*y/i) {
    @date_expires = @date_issued;
    $date_expires[5] += $1;
  }
  elsif($opt->{expires} =~ /^\s*(\d+)\s*mon/i) {
    @date_expires = @date_issued;
    $date_expires[4] += $1;
  }
  elsif($opt->{expires} =~ /^\s*(\d+)\s*[mhdwy]/) {
    @date_expires = localtime(adjust_time($opt->{expires}, $now));
  }
  elsif($opt->{expires}) {
    $log->("Expiration date '%s' not understood, ignoring.", $opt->{expires});
  }

  if(@date_expires) {
    $expire_date = POSIX::strftime('%Y%m%d%H%M%S', @date_expires);
  }

$log->("generated code=$code, expires=$opt->{expires} date_expires=$expire_date ");
  my $check = int rand(10);
  $check .= int(rand(10)) while length($check) < 4;
#$log->("generated check=$check");
  my %record = (
    amount => $opt->{amount},
    ip_addr => $CGI::remote_addr,
    order_number => $opt->{order_number},
    date_issued => $issue_date,
    date_expires => $expire_date,
    check_value => $check,
    orig_amount => $opt->{amount},
    process_flag => 0,
  );
  my $db = dbref($cert_table)
    or return $die->("cannot open pay_cert table '%s'", $cert_table);
  $db->set_slice($code, \%record)
    or return $die->("cannot write cert number $code in pay_cert table '%s'", $cert_table);

  ## Create expire date for cookie
  my $edate;
  $edate = POSIX::strftime("%a, %d-%b-%Y %H:%M:%S GMT ", @date_expires)
    unless ! $expire_date or $opt->{no_cookie};

  if($opt->{code_scratch}) {
    $::Scratch->{$opt->{code_scratch}} = $code unless $opt->{no_cookie};
    unless( ! $edate or $opt->{no_cookie}) {
#$log->("setting code cookie");
      my $prior_cookie = $Tag->read_cookie({name => 'MV_GIFT_CERT_CODE'});
      my $cvalue = $code;
      if($prior_cookie) {
        $cvalue = join ",", $prior_cookie, $cvalue;
      }
      $Tag->set_cookie({
              name => 'MV_GIFT_CERT_CODE',
              expire => $edate,
              value => $cvalue,
            });
    }
  }

  if($opt->{check_scratch}) {
    $::Scratch->{$opt->{check_scratch}} = $check unless $opt->{no_cookie};
    my $prior_cookie = $Tag->read_cookie({name => 'MV_GIFT_CERT_CHECK'});
    my $cvalue = $check;
    if($prior_cookie) {
      $cvalue = join ",", $prior_cookie, $cvalue;
    }
    unless( ! $edate or $opt->{no_cookie}) {
#$log->("setting cookie");
      $Tag->set_cookie({
                name => 'MV_GIFT_CERT_CHECK',
                expire => $edate,
                value => $cvalue,
            });
    }
  }

  if(defined $opt->{item_pointer}) {
    my $ptr =  $opt->{item_pointer};
    my $cart  = $opt->{cart}
          ? ($Vend::Session->{carts}{$opt->{cart}})
          : $Vend::Items;
    my $item = $cart->[$ptr];
    $item->{pay_cert_code} = $code;
    $item->{pay_cert_check} = $check;
  }
  return $opt->{admin} ? "$code/$check" : $code;
}

my $cdb = dbref($cert_table)
  or return $die->("cannot open pay_certs table '%s'", $cert_table);

my $status;

my $record;

my $rdb = dbref($redeem_table)
  or return $die->("Cannot open redemption table %s", $redeem_table);
my $rname = $rdb->name();
my $rdbh  = $rdb->dbh()
  or return $die->("Cannot get redemption table %s DBI handle", $redeem_table);

if($opt->{auth}) {
  eval {
    $sth_lock->execute($code, $$, $CGI::remote_addr)
      and $locked = 1;
  };

  not $locked and return $die->("Cannot lock pay cert %s", $code);

  $code or return $die->("Must have payment certificate number.");
  $record = $cdb->row_hash($code)
    or return $die->("Gift certificate %s does not exist.", $code);
  if($opt->{amount} > $record->{amount}) {
    return $die->("Tried to redeem, limit (%s) exceeded.", $record->{amount} );
  }
  my %redeem = (
    pay_id => $code,
    trans_date => POSIX::strftime('%Y%m%d%H%M%S', localtime()),
    ip_addr => $CGI::remote_addr,
    trans_type => 'auth',
    voided => 0,
    captured => 0,
    username => $Vend::username,
    amount => $opt->{amount},
    items => $opt->{items},
    );

  $opt->{tid} = $status = $rdb->set_slice(undef, \%redeem)
    or $die->("Auth redemption of %s failed: %s", $code, $rdb->errstr());
#$log->("Redemption auth tid=$status");
  my $new_amount = $cdb->set_field(
              $code,
              'amount',
              $record->{amount} - $opt->{amount},
            );
#$log->("Redemption amount=$record->{amount} redeeming=$opt->{amount} new_amount=$new_amount");

  defined $new_amount
    or $die->("Auth redemption of %s failed: %s", $code, $rdb->errstr());

}
elsif($opt->{capture}) {
  $opt->{tid}  or return $die->("Must have transaction ID to capture.");
  my $red_record = $rdb->row_hash($opt->{tid}) 
    or return $die->("Unknown transaction ID %s.", $opt->{tid});
  if($red_record->{voided}) {
    return $die->("Cannot capture voided auth %s.", $opt->{tid});
  }

  if($red_record->{captured}) {
    return $die->("Auth %s already captured.", $opt->{tid});
  }

  $code = $red_record->{pay_id};

  eval {
    $sth_lock->execute($code, $$, $CGI::remote_addr)
      and $locked = 1;
  };

  not $locked and return $die->("Cannot lock payment cert %s", $code);

  my %redeem = (
    pay_id => $code,
    trans_date => POSIX::strftime('%Y%m%d%H%M%S', localtime()),
    link_tid => $opt->{tid},
    ip_addr => $CGI::remote_addr,
    trans_type => 'capture',
    voided => 0,
    captured => 0,
    username => $Vend::username,
    amount => $red_record->{amount},
    );

  $opt->{new_tid} = $status = $rdb->set_slice(undef, \%redeem)
    or $die->("Auth redemption of %s failed: %s", $code, $rdb->errstr());
#$log->("Redemption auth tid=$status");

  $rdb->set_field($opt->{tid}, 'captured', 1);
#$log->("Capture amount=$red_record->{amount}");

}
elsif($opt->{void}) {
  $opt->{tid}  or return $die->("Must have transaction ID to void.");

  my $red_record = $rdb->row_hash($opt->{tid}) 
    or return $die->("Unknown transaction ID %s.", $opt->{tid});

  if($red_record->{voided}) {
    return $die->("Cannot void already voided auth %s.", $opt->{tid});
  }

  if($red_record->{captured}) {
    return $die->("Cannot void captured auth %s.", $opt->{tid});
  }

  $code = $red_record->{pay_id};

  $record = $cdb->row_hash($code)
    or return $die->("Gift certificate %s does not exist.", $code);

  eval {
    $sth_lock->execute($code, $$, $CGI::remote_addr)
      and $locked = 1;
  };

  not $locked and return $die->("Cannot lock payment cert %s", $code);

  if( ($red_record->{amount} + $record->{amount}) > $record->{orig_amount}) {
    return $die->(
          "Cannot void to equal more than original_amount %s.",
          $record->{orig_amount},
        );
  }

  my %redeem = (
    pay_id => $code,
    trans_date => POSIX::strftime('%Y%m%d%H%M%S', localtime()),
    link_tid => $opt->{tid},
    ip_addr => $CGI::remote_addr,
    trans_type => 'void',
    voided => 0,
    captured => 1,
    username => $Vend::username,
    amount => $red_record->{amount},
    );

  $opt->{new_tid} = $status = $rdb->set_slice(undef, \%redeem)
    or $die->("Auth redemption of %s failed: %s", $code, $rdb->errstr());
#$log->("Redemption auth tid=$status");

  $rdb->set_field($opt->{tid}, 'voided', 1);
#$log->("Capture amount=$red_record->{amount}");

  my $new_amount = $cdb->set_field($code, 'amount', $record->{amount} + $red_record->{amount});
#$log->("void amount=$red_record->{amount} new_amount=$new_amount");

}
elsif ($opt->{return}) {
  $code or return $die->("Must have payment certificate number for a return.");
  eval {
    $sth_lock->execute($code, $$, $CGI::remote_addr)
      and $locked = 1;
  };

  not $locked and return $die->("Cannot lock payment cert %s", $code);

  $record = $cdb->row_hash($code)
    or return $die->("Gift certificate %s does not exist.", $code);
  if( ($opt->{amount} + $record->{amount}) > $record->{orig_amount}) {
    return $die->(
          "Cannot return more than original_amount %s.",
          $record->{orig_amount},
        );
  }
  my %redeem = (
    pay_id => $code,
    trans_date => POSIX::strftime('%Y%m%d%H%M%S', localtime()),
    ip_addr => $CGI::remote_addr,
    trans_type => 'return',
    voided => 0,
    captured => 1,
    username => $Vend::username,
    amount => $opt->{amount},
    items => $opt->{items},
    );

  $opt->{tid} = $status = $rdb->set_slice(undef, \%redeem)
    or $die->("Auth redemption of %s failed: %s", $code, $rdb->errstr());
#$log->("Redemption auth tid=$status");
  my $new_amount = $cdb->set_field(
              $code,
              'amount',
              $record->{amount} + $opt->{amount},
            );
#$log->("return amount=$record->{amount} redeeming=$opt->{amount} new_amount=$new_amount");

  defined $new_amount
    or $die->("Return of %s failed: %s", $code, $rdb->errstr());
}

if($locked) {
  my $rc = $sth_unlock->execute($code) and $locked = 0;
#$log->("unlock rc=$rc");
  if($locked) {
    undef $locked;
    return $die->("Gift certificate %s lock was not released.", $code);
  }
}
else {
#$log->("Not locked??!!?? THis should not happen.");
}
return $status;
}
EOR


Name

pay-cert-redeem

ATTRIBUTES

AttributePos.Req.DefaultDescription
certs Yes Yes
table pay_certs
set_scratch
capture
die
success
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

pay-cert-redeem is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: dist/strap/config/pay_cert_redeem.tag
Lines: 104


UserTag pay-cert-redeem Order certs
UserTag pay-cert-redeem addAttr
UserTag pay-cert-redeem Routine <<EOR
sub {
my ($certs, $opt) = @_;

my $ctab = $opt->{table} || 'pay_certs';
my $cdb = dbref($ctab) 
      or die errmsg("No payment cert table '%s'", $ctab);

use vars qw/$Tag/;
$opt->{set_scratch} = 'amount_remaining' unless defined $opt->{set_scratch};

my $svar = $opt->{set_scratch};

my @tid;

if($opt->{capture}) {
  $certs ||= $::Scratch->{pay_certs_to_capture};
  return unless $certs;
  my @certs = split /[\s,\0]+/, $certs;
  
  foreach my $code (@certs) {
    my $success = $Tag->pay_cert({ capture => 1, tid => $code });
    if($success) {
      push @tid, $code;
    }
    else {
      for(@tid) {
        my $o = {
          void => 1,
          code => $_,
        };
        $Tag->pay_cert( $o );
        ::logError(
          "Voided capture tid %s due to capture error on %s",
          $_,
          $code,
        );
      }
    }
  }
}
else {
  my $total_cost = round_to_frac_digits($Tag->total_cost( { noformat => 1 }));
  my $remaining = $total_cost;

  $certs ||= $::Values->{use_pay_cert} || $::Scratch->{pay_cert_code};
  return $remaining unless $certs;
  my @certs = split /[\s,\0]+/, $certs;

  foreach my $code (@certs) {
    last if $remaining <= 0;
    my $this = $cdb->field($code, 'amount');
    my $amount;
    if($this < $remaining) {
      $remaining -= $this;
      $amount = $this;
    }
    else {
      $amount = $remaining;
      $remaining = 0;
    }
    my $o = {
      auth => 1,
      amount => $amount,
      code => $code,
    };
    my $tid = $Tag->pay_cert($o);
    if($tid) {
      push @tid, $tid;
#::logDebug("authorized pay_cert=$code amount=$amount tid=$tid");
    }
    else {
#::logDebug("failed to auth pay_cert=$code amount=$amount tid=$tid");
      for(@tid) {
        my $o = {
          void => 1,
          code => $_,
        };
        $Tag->pay_cert( $o );
        my $msg = errmsg(
          "Voided authorization tid %s due to auth error on %s",
          $_,
          $code,
        );
        ::logError($msg);
      }
      die errmsg("failed to authorize pay_cert %s", $code)
        if $opt->{die};
      return $total_cost;
    }
  }

  $::Scratch->{pay_certs_to_capture} = join ",", @tid;
  if($opt->{set_scratch}) {
    $::Scratch->{$svar} = $remaining;
  }
  return $opt->{success} if $opt->{success};
  return $remaining;
}

}
EOR


Name

perl — evaluate embedded Perl code

ATTRIBUTES

AttributePos.Req.DefaultDescription
tables | table Yes No
subs 0 imports subroutines defined by Sub
short_errors 0 log error message only
no_return 0 store result into session key mv_perl_result instead of returning it
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

Evaluate embedded Perl code and return the result.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

The calc tag is lower-overhead variant of perl, because it does not accept arguments, does not try to interpolate tag body, does not pre-open any database tables, and it doesn't do any extra wrapping.

The calc tag will remember variable values inside the page, so you can do the equivalent of a memory store and memory recall for a loop. In other words, variables you initialize or set in one calc block are also visible in all further calc blocks on the same page.

There is no reason to ever use this tag inside perl or mvasp.

AVAILABILITY

perl is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/perl.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: perl.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag perl                Order        tables
UserTag perl                addAttr
UserTag perl                attrAlias    table tables
UserTag perl                hasEndTag
UserTag perl                PosNumber    1
UserTag perl                Version      $Revision: 1.5 $
UserTag perl                MapRoutine   Vend::Interpolate::tag_perl

Source: lib/Vend/Interpolate.pm
Lines: 1743

sub tag_perl {
my ($tables, $opt,$body) = @_;
my ($result,@share);
#::logDebug("tag_perl MVSAFE=$MVSAFE::Safe opts=" . uneval($opt));

if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
  return undef;
}

if ($MVSAFE::Safe) {
#::logDebug("tag_perl: Attempt to call perl from within Safe.");
  return undef;
}

#::logDebug("tag_perl: tables=$tables opt=" . uneval($opt) . " body=$body");
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));
if($opt->{subs} or $opt->{arg} =~ /\bsub\b/) {
  no strict 'refs';
  for(keys %{$Global::GlobalSub}) {
#::logDebug("tag_perl share subs: GlobalSub=$_");
    next if defined $Global::AdminSub->{$_}
      and ! $Global::AllowGlobal->{$Vend::Cat};
    *$_ = \&{$Global::GlobalSub->{$_}};
    push @share, "&$_";
  }
  for(keys %{$Vend::Cfg->{Sub} || {}}) {
#::logDebug("tag_perl share subs: Sub=$_");
    *$_ = \&{$Vend::Cfg->{Sub}->{$_}};
    push @share, "&$_";
  }
}

if($tables) {
  my (@tab) = grep /\S/, split /\s+/, $tables;
  foreach my $tab (@tab) {
    next if $Db{$tab};
    my $db = database_exists_ref($tab);
    next unless $db;
    my $dbh;
    $db = $db->ref();
    if($db->config('type') == 10) {
      my @extra_tabs = $db->_shared_databases();
      push (@tab, @extra_tabs);
      $dbh = $db->dbh();
    } elsif ($db->can('dbh')) {
      $dbh = $db->dbh();
    }

    if($hole) {
      if ($dbh) {
        $Sql{$tab} = $hole->wrap($dbh);
      }
      $Db{$tab} = $hole->wrap($db);
      if($db->config('name') ne $tab) {
        $Db{$db->config('name')} = $Db{$tab};
      }
    }
    else {
      $Sql{$tab} = $db->[$Vend::Table::DBI::DBI]
        if $db =~ /::DBI/;
      $Db{$tab} = $db;
    }
  }
}

$Tag = $hole->wrap($Tag) if $hole and ! $Vend::TagWrapped++;

init_calc() if ! $Vend::Calc_initialized;
$ready_safe->share(@share) if @share;

if($Vend::Cfg->{Tie_Watch}) {
  eval {
    for(@{$Vend::Cfg->{Tie_Watch}}) {
      logGlobal("touching $_");
      my $junk = $Config->{$_};
    }
  };
}

$Items = $Vend::Items;

$body = readfile($opt->{file}) . $body
  if $opt->{file};

# Skip costly eval of code entirely if perl tag was called with no code,
# likely used only for the side-effect of opening database handles
return if $body !~ /\S/;

$body =~ tr/\r//d if $Global::Windows;

$MVSAFE::Safe = 1;
if (
  ( $opt->{global} or (! defined $opt->{global} and $Global::PerlAlwaysGlobal->{$Vend::Cat} ) )
    and
  $Global::AllowGlobal->{$Vend::Cat}
  )
{
  $MVSAFE::Safe = 0 unless $MVSAFE::Unsafe;
}

if(! $MVSAFE::Safe) {
  if ($Global::PerlNoStrict->{$Vend::Cat} || $opt->{no_strict}) {
    no strict;
    $result = eval($body);
  }
  else {
    $result = eval($body);
  }
}
else {
  $result = $ready_safe->reval($body);
}

undef $MVSAFE::Safe;

if ($@) {
#::logDebug("tag_perl failed $@");
  my $msg = $@;
  if($Vend::Try) {
    $Vend::Session->{try}{$Vend::Try} .= "\n" 
      if $Vend::Session->{try}{$Vend::Try};
    $Vend::Session->{try}{$Vend::Try} .= $@;
  }
      if($opt->{number_errors}) {
          my @lines = split("\n",$body);
          my $counter = 1;
          map { $_ = sprintf("% 4d %s",$counter++,$_); } @lines;
          $body = join("\n",@lines);
      }
      if($opt->{trim_errors}) {
          if($msg =~ /line (\d+)\.$/) {
              my @lines = split("\n",$body);
              my $start = $1 - $opt->{trim_errors} - 1;
              my $length = (2 * $opt->{trim_errors}) + 1;
              @lines = splice(@lines,$start,$length);
              $body = join("\n",@lines);
          }
      }
      if($opt->{eval_label}) {
          $msg =~ s/\(eval \d+\)/($opt->{eval_label})/g;
      }
      if($opt->{short_errors}) {
          chomp($msg);
          logError( "Safe: %s" , $msg );
          logGlobal({ level => 'debug' }, "Safe: %s" , $msg );
      } else {
          logError( "Safe: %s\n%s\n" , $msg, $body );
          logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body );
      }
  return $opt->{failure};
}
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));

if ($opt->{no_return}) {
  $Vend::Session->{mv_perl_result} = $result;
  $result = join "", @Vend::Document::Out;
  @Vend::Document::Out = ();
}
#::logDebug("tag_perl succeeded result=$result\nEND");
return $result;
}

Source: lib/Vend/Interpolate.pm
Lines: 1743

sub tag_perl {
my ($tables, $opt,$body) = @_;
my ($result,@share);
#::logDebug("tag_perl MVSAFE=$MVSAFE::Safe opts=" . uneval($opt));

if($Vend::NoInterpolate) {
  logGlobal({ level => 'alert' },
        "Attempt to interpolate perl/ITL from RPC, no permissions."
        );
  return undef;
}

if ($MVSAFE::Safe) {
#::logDebug("tag_perl: Attempt to call perl from within Safe.");
  return undef;
}

#::logDebug("tag_perl: tables=$tables opt=" . uneval($opt) . " body=$body");
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));
if($opt->{subs} or $opt->{arg} =~ /\bsub\b/) {
  no strict 'refs';
  for(keys %{$Global::GlobalSub}) {
#::logDebug("tag_perl share subs: GlobalSub=$_");
    next if defined $Global::AdminSub->{$_}
      and ! $Global::AllowGlobal->{$Vend::Cat};
    *$_ = \&{$Global::GlobalSub->{$_}};
    push @share, "&$_";
  }
  for(keys %{$Vend::Cfg->{Sub} || {}}) {
#::logDebug("tag_perl share subs: Sub=$_");
    *$_ = \&{$Vend::Cfg->{Sub}->{$_}};
    push @share, "&$_";
  }
}

if($tables) {
  my (@tab) = grep /\S/, split /\s+/, $tables;
  foreach my $tab (@tab) {
    next if $Db{$tab};
    my $db = database_exists_ref($tab);
    next unless $db;
    my $dbh;
    $db = $db->ref();
    if($db->config('type') == 10) {
      my @extra_tabs = $db->_shared_databases();
      push (@tab, @extra_tabs);
      $dbh = $db->dbh();
    } elsif ($db->can('dbh')) {
      $dbh = $db->dbh();
    }

    if($hole) {
      if ($dbh) {
        $Sql{$tab} = $hole->wrap($dbh);
      }
      $Db{$tab} = $hole->wrap($db);
      if($db->config('name') ne $tab) {
        $Db{$db->config('name')} = $Db{$tab};
      }
    }
    else {
      $Sql{$tab} = $db->[$Vend::Table::DBI::DBI]
        if $db =~ /::DBI/;
      $Db{$tab} = $db;
    }
  }
}

$Tag = $hole->wrap($Tag) if $hole and ! $Vend::TagWrapped++;

init_calc() if ! $Vend::Calc_initialized;
$ready_safe->share(@share) if @share;

if($Vend::Cfg->{Tie_Watch}) {
  eval {
    for(@{$Vend::Cfg->{Tie_Watch}}) {
      logGlobal("touching $_");
      my $junk = $Config->{$_};
    }
  };
}

$Items = $Vend::Items;

$body = readfile($opt->{file}) . $body
  if $opt->{file};

# Skip costly eval of code entirely if perl tag was called with no code,
# likely used only for the side-effect of opening database handles
return if $body !~ /\S/;

$body =~ tr/\r//d if $Global::Windows;

$MVSAFE::Safe = 1;
if (
  ( $opt->{global} or (! defined $opt->{global} and $Global::PerlAlwaysGlobal->{$Vend::Cat} ) )
    and
  $Global::AllowGlobal->{$Vend::Cat}
  )
{
  $MVSAFE::Safe = 0 unless $MVSAFE::Unsafe;
}

if(! $MVSAFE::Safe) {
  if ($Global::PerlNoStrict->{$Vend::Cat} || $opt->{no_strict}) {
    no strict;
    $result = eval($body);
  }
  else {
    $result = eval($body);
  }
}
else {
  $result = $ready_safe->reval($body);
}

undef $MVSAFE::Safe;

if ($@) {
#::logDebug("tag_perl failed $@");
  my $msg = $@;
  if($Vend::Try) {
    $Vend::Session->{try}{$Vend::Try} .= "\n" 
      if $Vend::Session->{try}{$Vend::Try};
    $Vend::Session->{try}{$Vend::Try} .= $@;
  }
      if($opt->{number_errors}) {
          my @lines = split("\n",$body);
          my $counter = 1;
          map { $_ = sprintf("% 4d %s",$counter++,$_); } @lines;
          $body = join("\n",@lines);
      }
      if($opt->{trim_errors}) {
          if($msg =~ /line (\d+)\.$/) {
              my @lines = split("\n",$body);
              my $start = $1 - $opt->{trim_errors} - 1;
              my $length = (2 * $opt->{trim_errors}) + 1;
              @lines = splice(@lines,$start,$length);
              $body = join("\n",@lines);
          }
      }
      if($opt->{eval_label}) {
          $msg =~ s/\(eval \d+\)/($opt->{eval_label})/g;
      }
      if($opt->{short_errors}) {
          chomp($msg);
          logError( "Safe: %s" , $msg );
          logGlobal({ level => 'debug' }, "Safe: %s" , $msg );
      } else {
          logError( "Safe: %s\n%s\n" , $msg, $body );
          logGlobal({ level => 'debug' }, "Safe: %s\n%s\n" , $msg, $body );
      }
  return $opt->{failure};
}
#::logDebug("tag_perl initialized=$Vend::Calc_initialized: carts=" . uneval($::Carts));

if ($opt->{no_return}) {
  $Vend::Session->{mv_perl_result} = $result;
  $result = join "", @Vend::Document::Out;
  @Vend::Document::Out = ();
}
#::logDebug("tag_perl succeeded result=$result\nEND");
return $result;
}


Name

price — calculate product price

ATTRIBUTES

AttributePos.Req.DefaultDescription
code YesYes product SKU.
quantity   1quantity
discount  NoApply discount.
convert  NoConvert the amount according to the PriceDivide value for the current locale.
noformatYesNoNoOutput plain number instead of formatting it according to the currency locale?
display  symbolDisplay currency as symbol, text or not at all?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag calculates the price for a specified product and returns it formatted.

The price tag will not apply discounts unless you supply the discount=1 parameter.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Displaying price for item 1299, with quantity 1 resp. 10

[price 1299]
[price code=1299 quantity=10]

NOTES

AVAILABILITY

price is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/price.coretag
Lines: 31


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: price.coretag,v 1.10 2007-03-30 23:40:49 pajamian Exp $

UserTag price               Order        code
UserTag price               addAttr
UserTag price               attrAlias    base mv_ib
UserTag price               attrAlias    space discount_space
UserTag price               PosNumber    1
UserTag price               Version      $Revision: 1.10 $
UserTag price               Routine      <<EOR
sub {
my ($code, $ref) = @_;
$ref->{code} ||= $code;

my $oldspace;
$oldspace = Vend::Interpolate::switch_discount_space($ref->{discount_space})
  if defined $ref->{discount_space};

my $amount = Vend::Data::item_price($ref);
$amount = discount_price($code, $amount, $ref->{quantity})
    if $ref->{discount};
Vend::Interpolate::switch_discount_space($oldspace) if defined $oldspace;
return currency( $amount, $ref->{noformat}, undef, $ref );
}
EOR


Name

process

ATTRIBUTES

AttributePos.Req.DefaultDescription
href
download_name
no_session
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

process is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/process.coretag
Lines: 59


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: process.coretag,v 1.13 2007-10-31 11:25:53 kwalsh Exp $

UserTag process-target Alias     process
UserTag process-order  Alias     process

UserTag process        Order     target secure
UserTag process        addAttr
UserTag process        Version   $Revision: 1.13 $
UserTag process        Routine   <<EOR
# Returns the href to process the completed order form or do the search.
sub {
my($target,$secure,$opt) = @_;

$secure = defined $secure ? $secure : $CGI::secure;

my $page = $opt->{href} || $Vend::Cfg->{ProcessPage};
$opt->{add_dot_html} = $::Scratch->{mv_add_dot_html} unless defined $opt->{add_dot_html};

if($opt->{download_name}) {
$page .= "/$opt->{download_name}";
}
elsif (Vend::Util::is_yes($opt->{add_dot_html})) {
$page .= '.html' unless $page =~ m{(?:/|\.html?)$};
}

my $url;
if($secure) {
$url = $Vend::Cfg->{SecurePostURL} || $Vend::Cfg->{SecureURL};
}
else {
$url = $Vend::Cfg->{PostURL} || $Vend::Cfg->{VendURL};
}
$url =~ s,/*$,/,;
$url .= $page;

if($Global::TolerateGet and ! $opt->{no_session}) {
my @args;
push @args, "$::VN->{mv_session_id}=$Vend::SessionID"
unless  $::Scratch->{no_session_id};
push @args, "$::VN->{mv_pc}=" . ++$Vend::Session->{pageCount}
unless  $::Scratch->{no_count};
push @args, "$::VN->{mv_cat}=" . ++$Vend::Cat
if  $Vend::VirtualCat;
if(@args) {
$url .= '?';
$url .= join($Global::UrlJoiner, @args);
}
}
return $url unless $target;
return qq{$url" target="$target};
}
EOR

SEE ALSO


Name

process-order

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

process-order is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/process.coretag
Lines: 59


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: process.coretag,v 1.13 2007-10-31 11:25:53 kwalsh Exp $

UserTag process-target Alias     process
UserTag process-order  Alias     process

UserTag process        Order     target secure
UserTag process        addAttr
UserTag process        Version   $Revision: 1.13 $
UserTag process        Routine   <<EOR
# Returns the href to process the completed order form or do the search.
sub {
my($target,$secure,$opt) = @_;

$secure = defined $secure ? $secure : $CGI::secure;

my $page = $opt->{href} || $Vend::Cfg->{ProcessPage};
$opt->{add_dot_html} = $::Scratch->{mv_add_dot_html} unless defined $opt->{add_dot_html};

if($opt->{download_name}) {
$page .= "/$opt->{download_name}";
}
elsif (Vend::Util::is_yes($opt->{add_dot_html})) {
$page .= '.html' unless $page =~ m{(?:/|\.html?)$};
}

my $url;
if($secure) {
$url = $Vend::Cfg->{SecurePostURL} || $Vend::Cfg->{SecureURL};
}
else {
$url = $Vend::Cfg->{PostURL} || $Vend::Cfg->{VendURL};
}
$url =~ s,/*$,/,;
$url .= $page;

if($Global::TolerateGet and ! $opt->{no_session}) {
my @args;
push @args, "$::VN->{mv_session_id}=$Vend::SessionID"
  unless  $::Scratch->{no_session_id};
push @args, "$::VN->{mv_pc}=" . ++$Vend::Session->{pageCount}
  unless  $::Scratch->{no_count};
push @args, "$::VN->{mv_cat}=" . ++$Vend::Cat
  if  $Vend::VirtualCat;
if(@args) {
  $url .= '?';
  $url .= join($Global::UrlJoiner, @args);
}
}
return $url unless $target;
return qq{$url" target="$target};
}
EOR

SEE ALSO


Name

process-target

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

process-target is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/process.coretag
Lines: 59


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: process.coretag,v 1.13 2007-10-31 11:25:53 kwalsh Exp $

UserTag process-target Alias     process
UserTag process-order  Alias     process

UserTag process        Order     target secure
UserTag process        addAttr
UserTag process        Version   $Revision: 1.13 $
UserTag process        Routine   <<EOR
# Returns the href to process the completed order form or do the search.
sub {
my($target,$secure,$opt) = @_;

$secure = defined $secure ? $secure : $CGI::secure;

my $page = $opt->{href} || $Vend::Cfg->{ProcessPage};
$opt->{add_dot_html} = $::Scratch->{mv_add_dot_html} unless defined $opt->{add_dot_html};

if($opt->{download_name}) {
  $page .= "/$opt->{download_name}";
}
elsif (Vend::Util::is_yes($opt->{add_dot_html})) {
  $page .= '.html' unless $page =~ m{(?:/|\.html?)$};
}

my $url;
if($secure) {
  $url = $Vend::Cfg->{SecurePostURL} || $Vend::Cfg->{SecureURL};
}
else {
  $url = $Vend::Cfg->{PostURL} || $Vend::Cfg->{VendURL};
}
$url =~ s,/*$,/,;
$url .= $page;

if($Global::TolerateGet and ! $opt->{no_session}) {
  my @args;
  push @args, "$::VN->{mv_session_id}=$Vend::SessionID"
    unless  $::Scratch->{no_session_id};
  push @args, "$::VN->{mv_pc}=" . ++$Vend::Session->{pageCount}
    unless  $::Scratch->{no_count};
  push @args, "$::VN->{mv_cat}=" . ++$Vend::Cat
    if  $Vend::VirtualCat;
  if(@args) {
    $url .= '?';
    $url .= join($Global::UrlJoiner, @args);
  }
}
return $url unless $target;
return qq{$url" target="$target};
}
EOR

SEE ALSO


Name

profile — set UserDB profile

ATTRIBUTES

AttributePos.Req.DefaultDescription
name profile name
tag default
restore
joiner
run
set
failure return value in case of failure
success return value in case of success
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Set profile

[profile dealer]

NOTES

AVAILABILITY

profile is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/profile.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: profile.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag profile             Order        name
UserTag profile             addAttr
UserTag profile             PosNumber    1
UserTag profile             Version      $Revision: 1.5 $
UserTag profile             MapRoutine   Vend::Interpolate::tag_profile

Source: lib/Vend/Interpolate.pm
Lines: 1444

sub tag_profile {
my($profile, $opt) = @_;
#::logDebug("in tag_profile=$profile opt=" . uneval_it($opt));

$opt = {} if ! $opt;
my $tag = $opt->{tag} || 'default';

if(! $profile) {
  if($opt->{restore}) {
    restore_profile();
    if(ref $Vend::Session->{Autoload}) {
       @{$Vend::Session->{Autoload}} = 
         grep $_ !~ /^$tag-/, @{$Vend::Session->{Autoload}};
    }
  }
  return if ! ref $Vend::Session->{Autoload};
  $opt->{joiner} = ' ' unless defined $opt->{joiner};
  return join $opt->{joiner},
    grep /^\w+-\w+$/, @{ $Vend::Session->{Autoload} };
}

if($profile =~ s/(\w+)-//) {
  $opt->{tag} = $1;
  $opt->{run} = 1;
}
elsif (! $opt->{set} and ! $opt->{run}) {
  $opt->{set} = $opt->{run} = 1;
}

if( "$profile$tag" =~ /\W/ ) {
  logError(
    "profile: invalid characters (tag=%s profile=%s), must be [A-Za-z_]+",
    $tag,
    $profile,
  );
  return $opt->{failure};
}

if($opt->{run}) {
#::logDebug("running profile=$profile tag=$tag");
  my $prof = $Vend::Cfg->{Profile_repository}{$profile};
    if (not $prof) {
    logError( "profile %s (%s) non-existant.", $profile, $tag );
    return $opt->{failure};
  } 
#::logDebug("found profile=$profile");
  $Vend::Cfg->{Profile} = $prof;
  restore_profile();
#::logDebug("restored profile");
  PROFSET: 
  for my $one (keys %$prof) {
#::logDebug("doing profile $one");
    next unless defined $Vend::Cfg->{$one};
    my $string;
    my $val = $prof->{$one};
    if( ! ref $Vend::Cfg->{$one} ) {
      # Do nothing
    }
    elsif( ref($Vend::Cfg->{$one}) eq 'HASH') {
      if( ref($val) ne 'HASH') {
      $string = '{' .  $prof->{$one}  . '}'
        unless  $prof->{$one} =~ /^{/
        and    $prof->{$one} =~ /}\s*$/;
    }
    }
    elsif( ref($Vend::Cfg->{$one}) eq 'ARRAY') {
      if( ref($val) ne 'ARRAY') {
      $string = '[' .  $prof->{$one}  . ']'
        unless  $prof->{$one} =~ /^\[/
        and    $prof->{$one} =~ /]\s*$/;
    }
    }
    else {
      logError( "profile: cannot handle object of type %s.",
            $Vend::Cfg->{$one},
            );
      logError("profile: profile for $one not changed.");
      next;
    }

#::logDebug("profile value=$val, string=$string");
    undef $@;
    $val = $ready_safe->reval($string) if $string;

    if($@) {
      logError( "profile: bad object %s: %s", $one, $string );
      next;
    }
    $Vend::Session->{Profile_save}{$one} = $Vend::Cfg->{$one}
      unless defined $Vend::Session->{Profile_save}{$one};

#::logDebug("set $one to value=$val, string=$string");
    $Vend::Cfg->{$one} = $val;
  }
  return $opt->{success}
    unless $opt->{set};
}

Source: lib/Vend/Interpolate.pm
Lines: 1444

sub tag_profile {
my($profile, $opt) = @_;
#::logDebug("in tag_profile=$profile opt=" . uneval_it($opt));

$opt = {} if ! $opt;
my $tag = $opt->{tag} || 'default';

if(! $profile) {
  if($opt->{restore}) {
    restore_profile();
    if(ref $Vend::Session->{Autoload}) {
       @{$Vend::Session->{Autoload}} = 
         grep $_ !~ /^$tag-/, @{$Vend::Session->{Autoload}};
    }
  }
  return if ! ref $Vend::Session->{Autoload};
  $opt->{joiner} = ' ' unless defined $opt->{joiner};
  return join $opt->{joiner},
    grep /^\w+-\w+$/, @{ $Vend::Session->{Autoload} };
}

if($profile =~ s/(\w+)-//) {
  $opt->{tag} = $1;
  $opt->{run} = 1;
}
elsif (! $opt->{set} and ! $opt->{run}) {
  $opt->{set} = $opt->{run} = 1;
}

if( "$profile$tag" =~ /\W/ ) {
  logError(
    "profile: invalid characters (tag=%s profile=%s), must be [A-Za-z_]+",
    $tag,
    $profile,
  );
  return $opt->{failure};
}

if($opt->{run}) {
#::logDebug("running profile=$profile tag=$tag");
  my $prof = $Vend::Cfg->{Profile_repository}{$profile};
    if (not $prof) {
    logError( "profile %s (%s) non-existant.", $profile, $tag );
    return $opt->{failure};
  } 
#::logDebug("found profile=$profile");
  $Vend::Cfg->{Profile} = $prof;
  restore_profile();
#::logDebug("restored profile");
  PROFSET: 
  for my $one (keys %$prof) {
#::logDebug("doing profile $one");
    next unless defined $Vend::Cfg->{$one};
    my $string;
    my $val = $prof->{$one};
    if( ! ref $Vend::Cfg->{$one} ) {
      # Do nothing
    }
    elsif( ref($Vend::Cfg->{$one}) eq 'HASH') {
      if( ref($val) ne 'HASH') {
      $string = '{' .  $prof->{$one}  . '}'
        unless  $prof->{$one} =~ /^{/
        and    $prof->{$one} =~ /}\s*$/;
    }
    }
    elsif( ref($Vend::Cfg->{$one}) eq 'ARRAY') {
      if( ref($val) ne 'ARRAY') {
      $string = '[' .  $prof->{$one}  . ']'
        unless  $prof->{$one} =~ /^\[/
        and    $prof->{$one} =~ /]\s*$/;
    }
    }
    else {
      logError( "profile: cannot handle object of type %s.",
            $Vend::Cfg->{$one},
            );
      logError("profile: profile for $one not changed.");
      next;
    }

#::logDebug("profile value=$val, string=$string");
    undef $@;
    $val = $ready_safe->reval($string) if $string;

    if($@) {
      logError( "profile: bad object %s: %s", $one, $string );
      next;
    }
    $Vend::Session->{Profile_save}{$one} = $Vend::Cfg->{$one}
      unless defined $Vend::Session->{Profile_save}{$one};

#::logDebug("set $one to value=$val, string=$string");
    $Vend::Cfg->{$one} = $val;
  }
  return $opt->{success}
    unless $opt->{set};
}

SEE ALSO

Profile(7ic)


Name

query — run SQL query

ATTRIBUTES

AttributePos.Req.DefaultDescription
sql Yes Yes SQL statement
prefix sql
more No enable paginating with more_list
ml 50 number of items to display
more_template template for more_list
form form parameters embedded into more links
more_routine custom routine for more_list
table
failure text to return if query fails
query
wantarray
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Ad-hoc table display

[query sql="select * from products" type=html /]

NOTES

AVAILABILITY

query is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/query.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: query.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag query               Order        sql
UserTag query               addAttr
UserTag query               attrAlias    base table
UserTag query               hasEndTag
UserTag query               PosNumber    1
UserTag query               Version      $Revision: 1.4 $
UserTag query               MapRoutine   Vend::Interpolate::query

Source: lib/Vend/Interpolate.pm
Lines: 4576

sub query {
if(ref $_[0]) {
  unshift @_, '';
}
my ($query, $opt, $text) = @_;
$opt = {} if ! $opt;
$opt->{prefix} = 'sql' unless $opt->{prefix};
if($opt->{more} and $Vend::More_in_progress) {
  undef $Vend::More_in_progress;
  return region($opt, $text);
}
$opt->{table} = $Vend::Cfg->{ProductFiles}[0]
  unless $opt->{table};
my $db = $Vend::Database{$opt->{table}} ;
return $opt->{failure} if ! $db;

$opt->{query} = $query
  if $query;

$opt->{query} =~ s:
    \[\Q$opt->{prefix}\E[_-]quote\](.*?)\[/\Q$opt->{prefix}\E[_-]quote\]
  :
    $db->quote($1)
  :xisge;

if (! $opt->{wantarray} and ! defined $MVSAFE::Safe) {
  my $result = $db->query($opt, $text);
  return (ref $result) ? '' : $result;
}
$db->query($opt, $text);
}


Name

quick_table

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

quick_table is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/quick_table.coretag
Lines: 34


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: quick_table.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag quick_table Order        border
UserTag quick_table HasEndTag
UserTag quick_table Interpolate
UserTag quick_table Version      $Revision: 1.4 $
UserTag quick_table Routine      <<EOR
sub {
my ($border,$input) = @_;
$border = " BORDER=$border" if $border;
my $out = "<TABLE ALIGN=LEFT$border>";
my @rows = split /\n+/, $input;
my ($left, $right);
for(@rows) {
  $out .= '<TR><TD ALIGN=RIGHT VALIGN=TOP>';
  ($left, $right) = split /\s*:\s*/, $_, 2;
  $out .= '<B>' unless $left =~ /</;
  $out .= $left;
  $out .= '</B>' unless $left =~ /</;
  $out .= '</TD><TD VALIGN=TOP>';
  $out .= $right;
  $out .= '</TD></TR>';
  $out .= "\n";
}
$out .= '</TABLE>';
}
EOR

SEE ALSO


Name

rand — return random element from an arbitrarily-separated list

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes  File to load elements from.
separator   [alt]Separator to split elements on.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag read the list of elements, separated by separator , and returns one random element.

The list of elements can be either passed in from the file argument or it can be specified in-place, in the tag body.

If the file argument is specified, it takes precedence over the tag body content. Note that using large files can impact performance, since they are read in to memory before a random element is selected.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Return one random word

Put the following on a test page:

[rand separator=" "]
Foo Bar Baz Quux Toad Stool
[/rand]

NOTES

During the split operation (performed on the list to extract single elements), the whitespace is significant, so make sure you do not have excessive spaces around elements. If you do, and especially if the separator used is a space character itself, you will sometimes get empty elements in return.

AVAILABILITY

rand is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/rand.tag
Lines: 24


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: rand.tag,v 1.5 2007-03-30 23:40:57 pajamian Exp $

UserTag rand Order     file
UserTag rand posNumber 1
UserTag rand addAttr
UserTag rand hasEndTag
UserTag rand Version   $Revision: 1.5 $
UserTag rand Routine   <<EOR
sub {
my ($file, $opt, $inline) = @_;
my $sep = $opt->{separator} || '\[alt\]';
$inline = ::readfile($file)
  if $file;
my @pieces = split /$sep/, $inline;
return $pieces[int(rand(scalar @pieces))] ;
}
EOR

SEE ALSO


Name

read-cookie — reads browser cookie

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes name of the cookie
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

read-cookie returns value of the named cookie.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

read-cookie is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/read_cookie.coretag
Lines: 12


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: read_cookie.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag read-cookie         Order        name
UserTag read-cookie         Version      $Revision: 1.5 $
UserTag read-cookie         MapRoutine   Vend::Util::read_cookie

Source: lib/Vend/Util.pm
Lines: 2101

sub read_cookie {
my ($lookfor, $string) = @_;
$string = $CGI::cookie
  unless defined $string;
  return cookies_hash($string) unless defined $lookfor && length($lookfor);
  return undef unless $string =~ /(?:^|;)\s*\Q$lookfor\E=([^\s;]+)/i;
 return unescape_chars($1);
}


Name

read-shipping

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

read-shipping is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/read_shipping.coretag
Lines: 29


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: read_shipping.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag read-shipping Order      file
UserTag read-shipping PosNumber  1
UserTag read-shipping addAttr
UserTag read-shipping Version    $Revision: 1.4 $
UserTag read-shipping Routine    <<EOR
sub {
my ($file, $opt) = @_;
my $status = read_shipping($file, $opt);
if(
  $Vend::Cfg->{Shipping_line}[0]->[0] eq 'code'
    and
  $Vend::Cfg->{Shipping_line}[0]->[1] eq 'description'
  )
{
  shift (@{ $Vend::Cfg->{Shipping_line} });
  delete $Vend::Cfg->{Shipping_desc}{code};
}
return $status;
}
EOR

SEE ALSO


Name

reconfig

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes
table Yes
file Yes
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

reconfig is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/reconfig.coretag
Lines: 41


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: reconfig.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag reconfig Order   name table file
UserTag reconfig Version $Revision: 1.5 $
UserTag reconfig Routine <<EOR
use strict;
sub {
my ($name, $table, $file) = @_;
$name ||= $Vend::Cfg->{CatalogName};

my $myname = $Vend::Cfg->{CatalogName};
#::logGlobal("Trying to reconfig $name");

if($myname ne '_mv_admin' and $myname ne $name) {
    $::Values{mv_error_tag_restart} =
      "Not authorized to reconfig that catalog.";
    return undef;
}
#::logGlobal("Passed name check on reconfig $name");

my $script = $Global::Catalog{$name}->{script};
unless($script) {
  logGlobal("Attempt to reconfigure catalog without script?");
  logError("Attempt to reconfigure catalog without script?");
  return undef;
}

if($table and $file) {
  $script = join "\t", $script, $table, $file;
}
logData("$Global::RunDir/reconfig", $script);
return 1;
}
EOR


Name

reconfig-time

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

reconfig-time is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/reconfig_time.coretag
Lines: 19


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: reconfig_time.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag reconfig-time Order   name
UserTag reconfig-time Version $Revision: 1.4 $
UserTag reconfig-time Routine <<EOR
sub {
my $name = shift || $Vend::Cfg->{CatalogName};
my $myname = $Vend::Cfg->{CatalogName};
return '' unless $myname eq '_mv_admin' or $myname eq $name;
return Vend::Util::readfile($Global::RunDir . '/status.' . $name);
}
EOR

SEE ALSO


Name

record

ATTRIBUTES

AttributePos.Req.DefaultDescription
table
col
filter
key
show_error
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

record is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/record.coretag
Lines: 58


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: record.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag record              addAttr
UserTag record              attrAlias    column col
UserTag record              attrAlias    code key
UserTag record              attrAlias    field col
UserTag record              PosNumber    0
UserTag record              Version      $Revision: 1.4 $
UserTag record              Routine      <<EOR
sub {
my ($opt) = @_;
my $db = $Vend::Database{$opt->{table}};
return undef if ! $db;
$db = $db->ref();
# This can be called from Perl
my (@cols, @vals);
my $hash   = $opt->{col};
my $filter = $opt->{filter};

return undef unless defined $opt->{key};
my $key = $opt->{key};
return undef unless ref $hash;
undef $filter unless ref $filter;
@cols = keys %$hash;
@vals = values %$hash;

RESOLVE: {
  my $i = -1;
  for(@cols) {
    $i++;
    if(! defined $db->test_column($_) ) {
      splice (@cols, $i, 1);
      my $tmp = splice (@vals, $i, 1);
      ::logError("bad field %s in record update, value=%s", $_, $tmp);
      redo RESOLVE;
    }
    next unless defined $filter->{$_};
    $vals[$i] = filter_value($filter->{$_}, $vals[$i], $_);
  }
}

my $status;
eval {
  my $status = $db->set_slice($key, \@cols, \@vals);
};
if($@) {
  return $@ if $opt->{show_error};
}
return $status;
}
EOR

SEE ALSO


Name

region

ATTRIBUTES

AttributePos.Req.DefaultDescription
object
search
label
more
list_prefix
prefix
ml
md
query
fm
sp
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

region is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/region.coretag
Lines: 17


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: region.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag region              addAttr
UserTag region              attrAlias    args arg
UserTag region              attrAlias    params arg
UserTag region              attrAlias    search arg
UserTag region              hasEndTag
UserTag region              PosNumber    0
UserTag region              Version      $Revision: 1.4 $
UserTag region              MapRoutine   Vend::Interpolate::region

Source: lib/Vend/Interpolate.pm
Lines: 4841

sub region {

my($opt,$page) = @_;

my $obj;

if($opt->{object}) {
  ### The caller supplies the object, no search to be done
  $obj = $opt->{object};
}
else {
  ### We need to run a search to get an object
  my $c;
  if($CGI::values{mv_more_matches} || $CGI::values{MM}) {

    ### It is a more function, we need to get the parameters
    find_search_params(\%CGI::values);
    delete $CGI::values{mv_more_matches};
  }
  elsif ($opt->{search}) {
    ### Explicit search in tag parameter, run just like any
    if($opt->{more} and $::Instance->{SearchObject}{''}) {
      $obj = $::Instance->{SearchObject}{''};
      #::logDebug("cached search");
    }
    else {
      $c = {  mv_search_immediate => 1,
            mv_search_label => $opt->{label} || 'current',
          };
      my $params = escape_scan($opt->{search});
      Vend::Scan::find_search_params($c, $params);
      $c->{mv_no_more} = ! $opt->{more};
      $obj = perform_search($c);
    }
  }
  else {
    ### See if we have a search already done for this label
    $obj = $::Instance->{SearchObject}{$opt->{label}};
  }

  # If none of the above happen, we need to perform a search
  # based on the passed CGI parameters
  if(! $obj) {
    $obj = perform_search();
    $obj = {
      mv_results => [],          
      matches => 0,
      mv_search_error => [ errmsg('No search was found') ],
    } if ! $obj;
  }
  finish_search($obj);

  # Label it for future reference
  $::Instance->{SearchObject}{$opt->{label}} = $opt->{object} = $obj;
}

my $lprefix;
my $mprefix;
if($opt->{list_prefix}) {
  $lprefix = $opt->{list_prefix};
  $mprefix = "(?:$opt->{list_prefix}-)?";
}
elsif ($opt->{prefix}) {
  $lprefix = "(?:$opt->{prefix}-)?list";
  $mprefix = "(?:$opt->{prefix}-)?";
}
else {
  $lprefix = "list";
  $mprefix = "";
}

#::logDebug("region: opt:\n" . uneval($opt) . "\npage:" . substr($page,0,100));

my $save_more;
if($opt->{ml} and ! defined $obj->{mv_matchlimit} ) {
  $obj->{mv_matchlimit} = $opt->{ml};
  $obj->{mv_more_decade} = $opt->{md};
  $obj->{matches} = scalar @{$obj->{mv_results}};
  $obj->{mv_cache_key} = generate_key($opt->{query} || substr($page,0,100));
  $obj->{mv_more_permanent} = $opt->{pm};
  $obj->{mv_first_match} = $opt->{fm} if $opt->{fm};
  $obj->{mv_search_page} = $opt->{sp} if $opt->{sp};
  $obj->{prefix} = $opt->{prefix} if $opt->{prefix};
  $save_more = 1;
}

$opt->{prefix} = $obj->{prefix} if $obj->{prefix};

$Orig_prefix = $Prefix = $opt->{prefix} || 'item';

$B  = qr(\[$Prefix)i;
$E  = qr(\[/$Prefix)i;
$IB = qr(\[if[-_]$Prefix)i;
$IE = qr(\[/if[-_]$Prefix)i;

my $new;
$page =~   s!
        \[ ( $mprefix  more[-_]list )  $Optx$Optx$Optx$Optx$Optx \]
          ($Some)
        \[/\1\]
      !
        tag_more_list($2,$3,$4,$5,$6,$opt,$7)
      !xige;
$page =~   s!
        \[ ( $mprefix  on[-_]match )\]
          ($Some)
        \[/\1\]
      !
        $obj->{matches} > 0 ? opt_region(0,0,1,$2,$opt) : ''
      !xige;
$page =~   s!
        \[ ( $mprefix  no[-_]match )\]
          ($Some)
        \[/\1\]
      !
        $obj->{matches} > 0 ? '' : opt_region(0,0,1,$2,$opt)
      !xige;

$page =~ s:\[($lprefix)\]($Some)\[/\1\]:labeled_list($opt,$2,$obj):ige
  or $page = labeled_list($opt,$page,$obj);
#::logDebug("past labeled_list");
  if ($save_more) {
      my $out = delete $obj->{mv_results};
      Vend::Search::save_more($obj, $out);
      $obj->{mv_results} = $out;
  }

  return $page;
}

SEE ALSO


Name

report-table

ATTRIBUTES

AttributePos.Req.DefaultDescription
columns
row_toggle
reset_horiz
title_horiz
colheaders
query
column_defs
no_results
row_hidden_id
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

report-table is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/report_table.tag
Lines: 650


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: report_table.tag,v 1.5 2007-03-30 23:40:57 pajamian Exp $

UserTag report-table addAttr
UserTag report-table Documentation <<EOD

By Chris Wenham of Synesmedia, Inc. - www.synesmedia.com
This software is distributed under the terms of the GNU Public License.
Version 1.2, November 20, 2003.

Generate an HTML table based on the results of a query, with bells and
whistles. Can do horizontal (colspan) and vertical (rowspan) subheaders,
apply any Interchange filter or widget to any column, add a CSS class to
any column, link cell contents (and add parameters to the link based on
any column in the query results), add virtual columns based on internal
variables (such as the line number), and skip rows based on an array of
toggles you specify.
Good for making quick tables, sophisticated reports, and easy forms.

Synopsis and minimum syntax

 <table>
 [report-table
   query="SELECT * FROM addresses"
   columns="address city state zip"
 ]
 </table>

Or something fancier:

 <form action="[process]">
 <table>
 [report-table
   query="SELECT * FROM addresses"
   columns="state city address sales"
   column_defs="{
     state => {
       header => 'vert',
     },

     city => {
       header => 'vert',
     }

     zip => {
       title  => "Zip code:",
       header => 'horiz',
     }

     address => {
       width  => '40%',
       widget => 'text',
       widget_cols => '20'
     }

     sales => {
       prefix => '$',
     }
   }"
 ]
 <tr>
   <td colspan="4" align="right">
     <input type="hidden" name="rows" value="[scratch report_table_linecount]" $Vend::Xtrailer>
     <input type="submit" value="Save addresses" $Vend::Xtrailer>
   </td>
 </tr>
 </table>
 </form>

This last example could give you something like this:

+-------------------------------------------------------+
| state | city      | address                | sales    |
|-------+-----------+-----------------------------------|
|  NY   | Levittown |          Zip code: 11756          |
|       |           |-----------------------------------|
|       |           | [123 Return Lane_____] | $240.12  |
|       |           | [321 Raspberry Lane__] | $43.52   |
|       |-----------+-----------------------------------|
|       | Bellmore  |          Zip code: 11710          |
|       |           |-----------------------------------|
|       |           | [23 Merrick Road_____] | $354.06  |
|       |           | [43 Bellmore Ave_____] | $11.34   |
|-------+-----------+-----------------------------------|
|  PA   | Anytown   |          Zip code: 23456          |
|       |           |-----------------------------------|
|       |           | [63 Some Street______] | $771.35  |
|-------------------------------------------------------|
|                                    [ Save addresses ] |
+-------------------------------------------------------+


The columns to include in the report are passed in the "columns"
tag parameter.

Column definitions are defined in a perl hash of hash references.
The tag will display only the columns you specify, and in that order.
Pagination is not supported, but you can easily construct the logic for
that outside of the report-table tag, and then use OFFSET and LIMIT in
the query.

Vertical headers (state and city in this example) are always sorted
to the left of the table, but they can be nested to any level. The tag
does not support vertical headers within the scope of a horizontal
header.

Horizontal headers can also be nested to any level. You might want to
pass a "class" value in the column definition so you can style them
later and make it easier to tell them apart.
NOTE: Columns used for horizontal headers should *not* be included in
the "columns" parameter of the report-table tag. Defining them in
column_defs is sufficient.

Advanced column definitions

The following parameters are supported for the column definitions.

 title => 'Column Header'
 The tag will default to the database column name, but you
 can override it with a title. All titles are put in <th>
 tags at the top of each column, or in the case of
 horizontal subheaders they're put just before the value
 (eg: "Zip code: 11756" from above)

 header => 'vert'
 Indicates that this column is a header, and whether it's
 vertical ('vert') or horizontal ('horiz').
 Headers are generated every time the value in that column
 changes between rows. Let's say that the following are
 the rows returned by the query:

 NY,Levittown,11756,123 Return Lane
 NY,Levittown,11756,321 Raspberry Lane
 NY,Bellmore,11710,23 Merrick Road

 If city was a header, then it would spit out "Levittown"
 first, then two rows later spit out "Bellmore".

 NOTE: To make headers work properly, you must sort by those
 columns in your query, or you may get redundant headers.

 prefix => '$', postfix => '%'
 Something to insert just before and after the value. Will
 appear after the title in a horizontal header, and outside any
 widget or link.

 filter => 'digits_dot'
 Any Interchange filter. Will be applied to the cell value
 before it's put into any link or widget.

 widget => 'date'
 Any Interchange form widget. The widget will be passed the
 contents of the cell as the default value. The name of the
 form widget will be the column name plus the line number.
 Eg: "address_1", "address_2", and so-on.
 You can pass any addtional parameter supported by the [widget]
 tag (such as rows and cols) by prefixing them with "widget_".
 EG: "widget_cols => '30'".

 Any column can be a widget, even vertical and horizontal
 headers.

 class => 'currency'
 Will give you <td class="currency"> for each cell in that
 column.

 align => 'right', valign => 'top'
 Sets the alignment of each cell in the column. Vertical headers
 are valign="top" by default, but this can override.

 width => '50%'
 Set the column width.

 link      => 'show_customer'
 link_parm => 'id'
 link_key  => 'cust_id'
 Link a cell's contents using Interchange's [page] tag, and
 optionally passing a parameter based on any column in the
 query results. So let's say "cust_id" is a column returned in
 the database query, but not actually displayed in the result.
 The cells in your customer column could be linked to the
 "show_customer" page, passing the value of "cust_id" in a
 parameter named "id". Like this:
 http://www.store.com/cgi-bin/catalog/show_customer?id=523

 NOTE: You can't use a link and a widget at the same time. If you
 set the 'link' parameter, any widget in the same column def will
 be ignored.

 empty => '&nbsp;'
 What to use instead if the cell is empty for that row. For
 tables with borders set, you might want to use a nonbreaking
 space (&nbsp;), or 0.00 for currency columns, or whatever.
 NOTE: The tag can't tell the difference between an empty cell
 and a NULL cell.

 dynamic => 'linecount'
 Indicates a column that does not draw its data from the query
 results, but from an internal value. Most of these aren't
 terribly useful, but 'linecount' is good for adding line numbers.
 Dynamic values can be used with links, widgets and filters, but
 they can't be used as subheaders. Available dynamic values are:

   realrow
   The absolute current row from the query results. Is not
   affected by the row_toggle parameter (described later).
   Begins at zero.

   rowcount
   The current row, including any used by horizontal
   subheaders.
   Begins at zero.

   linecount
   The current data line. Does not include lines used by
   horizontal subheaders.
   Begins at 1.

   parity
   1 if we're on an odd numbered line, 0 if we're on an
   even numbered line.

Other parameters

 row_toggle="1,1,1,1,1,1,0,1,1,0,1"
 This is a comma separated list of toggles ('1' or '0') that
 can be used to make the report skip individual rows in the
 results. The number of toggles must either equal the number
 of results from the query, or the remainder will be skipped.
 Eg: passing row_toggle="1,1,0,1,1,1" and a query that returns
 six rows will give you a five-row report, where the third
 row from the results had been skipped. If the query returns
 more than six rows, then the remainder will be skipped.

 (Ideally, what you should probably do is just modify your
 query so it doesn't return those rows anyway, but this feature
 was added for a special application.)

 row_hidden_id="address_id"
 The name of a column in the query results to use in a
 type="hidden" form element. This is for forms that need to pass
 the database key's value for each row, and is added just before
 the first data cell, like this:

 <tr><input type="hidden" name="id_1" value="523"/><td...

 The number appended after "id_" in the name is the linecount,
 and will match the number appended to the name of any other
 widgets on the same row.

 title_horiz="0"
 If you want the value of horizontal subheaders to stand on
 their own (without a title), then set title_horiz="0".
 Otherwise the tag will use the database name or title of
 the column.

 reset_horiz="0"
 By default, the scope of a horizontal header does not cross
 the scope of a vertical header. It looks confusing and
 doesn't follow the typical way subheaders are used. So when
 a vertical header goes out of scope, it resets all the
 horizontal headers so they begin anew with the next row.
 Example: Some zip codes cross city boundaries, so the
 "Levittown" vertical header could end, but the next address
 might still be in the "11756" zip code. By default, the
 report table will simply run the "Zip code: 11756" header
 again before the next row.
 If you don't want it to do this, meaning you want the scope of
 horizontal headers to cross the scope of vertical headers,
 then pass reset_horiz="0".

 display_colheaders="0"
 When set to zero, don't bother to display the column headers.

 no_results="<tr><td>Woah dude, nothing to see!</td></tr>"
 Override the default message when there are no results from
 the query.


HTML output

Outputs XHMTL compliant markup*.

This tag will not generate the <table> tags in the final HTML because
it's trivial to add those yourself, and it was designed to be used in
cases where the table might not be "finished" even when the report-table
tag was (such as when you're using it to create a form).

The column headers row will be written with <tr class="headers">.

Every odd-numbered row will be written with <tr class="odd">.

The total number of columns it will use will always be the same as what
you pass in the "columns" parameter*. Even when the query returns no
results, it will still return one complete row with an apropriate
colspan (unless overridden by the no_results parameter).

* Except if you use a widget that doesn't output XHTML.

** Except if you were naughty and listed a column that is later defined
as a horizontal header, then it will get stripped out. You shouldn't list
horizontal headers in the colums="" parameter. Simply defining them in
column_defs is sufficient.


Side-effects

The following temporary scratch variables are set prior to tag completion.

 [scratch report_table_rowcount]
 The total number of rows created by the tag. This includes rows
 used up by horizontal subheaders, and the column header row.

 [scratch report_table_linecount]
 Total number of data rows returned by the tag, NOT including rows
 used by horizontal subheaders or the column headers. Useful if
 you're using widgets and your mv_nextpage needs to know how many
 values there are.

 [scratch report_table_colspan]
 Total number of columns it used.


Tips and Tricks

To get a blank column:

 columns="city state zip x customer"
 column_defs="{
   x => {
     title      => '&nbsp;',
     empty_cell => '&nbsp;'
   }
 }"


EOD
UserTag report-table Version $Revision: 1.5 $
UserTag report-table Routine <<EOR
sub prep_cell {
 my ($def,$datum,$linecount,$record) = @_;

 #Debug("prep_cell datum: $datum");

 my $cell;
 if ($def->{filter}) {
   $datum = $Tag->filter({ op => $def->{filter}, }, $datum);
 }

 if ($def->{link}) {
   my $page_parms = { href => $def->{link}, };
   if ($def->{link_parm}) {
     $page_parms->{form} = $def->{link_parm} .'='. $record->{$def->{link_key}};
   }
   $cell = $Tag->page($page_parms);
   $cell .= $datum;
   $cell .= '</a>';
 } elsif ($def->{widget}) {
   if ($def->{widget} =~ /^checkonly$/) {
     # This was a quick hack to support standalone checkboxes
     # for "delete/edit checked rows" type forms.
     my $checked = '';
     if ($datum) {
       $checked = ' checked="checked"';
     }
     $cell = '<input type="checkbox" name="'. $def->{colname} .'_'. $linecount \
 ."\" value=\"1\"$checked $Vend::Xtrailer>";
   } else {
     my $widget_name = $def->{colname} .'_'. $linecount;
     # We need to bludgeon Interchange over the head with the proper value
     # becuase set,default,value, and passed are ignored when there's an
     # existing value.
     $::Values->{$widget_name} = $datum;
     $cell = $Tag->widget($widget_name, {
       type       => $def->{widget},
       set        => $datum,
       attribute  => $def->{widget_attribute},
       db         => $def->{widget_db},
       field      => $def->{widget_field},
       extra      => $def->{widget_extra},
       cols       => $def->{widget_cols},
       rows       => $def->{widget_rows},
       delimiter  => $def->{widget_delimiter},
       key        => $def->{widget_key},
       year_begin => $def->{widget_year_begin},
       year_end   => $def->{widget_year_end},
       filter     => $def->{widget_filter},
       set        => $def->{widget_set},
       });
   }
 } else {
   $cell = $datum;
 }

 $cell = $def->{prefix} . $cell . $def->{postfix};

 #Debug("prep_cell returning: $cell");

 return $cell;
}

sub cell_open_tag {
 my ($def,$rowspan,$colspan) = @_;

 my @tag_parms;
 push @tag_parms, "colspan=\"$colspan\"" if $colspan;
 push @tag_parms, "rowspan=\"$rowspan\"" if $rowspan;
 push @tag_parms, "class=\"$def->{class}\"" if $def->{class};
 push @tag_parms, "width=\"$def->{width}\"" if $def->{width};
 push @tag_parms, "valign=\"$def->{valign}\"" if $def->{valign};
 push @tag_parms, "align=\"$def->{align}\"" if $def->{align};

 my $type = $def->{header} ? 'th' : 'td';

 if (@tag_parms) {
   return "<$type ". join( ' ', @tag_parms) .'>';
 }

 return '<td>';
}

sub {
 #Debug("Entering report-table");
 # Options gathering ------------------------------------------
 my $opt = shift;

 my @columns           = split ' ', $opt->{columns};
 my @row_toggle        = split ',', $opt->{row_toggle};

 if ($opt->{reset_horiz} eq '') {
   $opt->{reset_horiz} = 1;
 }

 if ($opt->{title_horiz} eq '') {
   $opt->{title_horiz} = 1;
 }

 if ($opt->{colheaders} eq '') {
   $opt->{colheaders} = 1;
 }

 #Debug("Gathered options. Query is: ". $opt->{query});

 # Data structure preparation ---------------------------------
 my @vertheads = ();
 my @subheader_cols = ();

 my (%cols,$column_defs);
 if ($opt->{column_defs}) {
   $column_defs = eval( $opt->{column_defs} );
   %cols = %{$column_defs};
 } else {
   foreach my $col (@columns) {
     $cols{$col}->{title} = $col;
   }
 }

 my @tcols;
 my $headpos = 0;
 foreach my $col (@columns) {
   if ($cols{$col}->{header}) {
     # Horizontal headers should never be in the 'columns' list
     if ($cols{$col}->{header} eq 'vert') {
       $cols{$col}->{pos} = $headpos;
       $headpos++;
       push @subheader_cols, $col;
       push @vertheads, $col;
       $cols{$col}->{valign} ||= 'top';
     }
   } else {
     push @tcols, $col;
   }
 }
 foreach my $col (keys(%cols)) {
   $cols{$col}->{colname} = $col;
   $cols{$col}->{title} ||= $col;
   if ($cols{$col}->{header} =~ /horiz/) {
     push @subheader_cols, $col;
   }
 }
 @columns = @tcols;
 # ----------------------------------------------------------##

 my $output;
 my $db = ::database_exists_ref('products');
 my $results = $db->query({ sql => $opt->{query}, hashref => 'results' });

 # Output column headers --------------------------------------
 if (($results) and (@{$results}) and ($opt->{colheaders})) {
   $output .= '<tr class="headers">';

   foreach my $c (@vertheads) {
     $output .= "<th>$cols{$c}->{title}</th>";
   }
   foreach my $c (@columns) {
     $output .= "<th>$cols{$c}->{title}</th>";
   }
   $output .= "</tr>\n";
 }

 if (!(($results) and (@{$results}))) {
   return $opt->{no_results} || '<tr><td colspan="'. (scalar(@columns) \
 + scalar(@vertheads)) .'">No results</td></tr>';
 }
 # ----------------------------------------------------------##

 # Process results --------------------------------------------
 my @rows = ();
 my @vh_stack = ();   # Stack of vertical headers we're working on
 my $vh;
 my $rowcount = 0;
 my $linecount = 1;
 for (my $i = 0; $i < scalar(@{$results}); $i++) {
   if (@row_toggle) {
     next if !$row_toggle[$i];
   }
   my $record = $results->[$i];
   my $row;

   #Debug("Row: ". ::uneval($record));

   # Dynamic values that can be used as column data
   my %dynamic = (
     realrow    => $i,
     rowcount   => $rowcount,
     rownumber  => $linecount,
     linecount  => $linecount,
     parity     => $linecount % 2 ? 1 : 0,
   );

   $row->{dynamic} = \%dynamic;

   foreach my $subhead (@subheader_cols) {
     if ($record->{$subhead} ne $cols{$subhead}->{value}) {
       if ($cols{$subhead}->{header} ne 'vert') {
       $row->{html} = cell_open_tag($cols{$subhead},0,$#columns + 1);

       if ($opt->{title_horiz}) {
         $row->{html} .= $cols{$subhead}->{title} .' ';
       }
       my $datum = $record->{$subhead};
       $row->{html} .= prep_cell($cols{$subhead},$datum,$linecount,$record) .'</th>';
       $cols{$subhead}->{value} = $record->{$subhead};
       } else {
         # Vertical headers must be inserted at the end, because that's
       # the only time we know what the rowspan is going to be.
       # So we keep track of them with a stack and a notation in the
       # row hash.
       my $old;
       if ($cols{$vh->{column}}->{pos} >= $cols{$subhead}->{pos}) {
         while (($old->{column} ne $subhead) and (@vh_stack)) {
         $old = pop @vh_stack;
         $old->{end} = $rowcount;
         $cols{$old->{column}}->{value} = '';
         #::Debug("Popped vh_stack. Old is: ". ::uneval($old));
         }
       }
       if ($opt->{reset_horiz}) {
         # Don't let horizontal headers apply across vertical headers
         foreach my $tmp (@subheader_cols) {
           if ($cols{$tmp}->{header} eq 'horiz') {
             $cols{$tmp}->{value} = '';
           }
         }
       }
       my $datum = $record->{$subhead};
       my $new = {
         content => prep_cell($cols{$subhead},$datum,$linecount,$record),
         column => $subhead,
         begin => $rowcount,
       };
       push @vh_stack, $new;
       #::Debug("vh_stack now: ". ::uneval(\@vh_stack));
       unshift @{$row->{'vert_headers'}}, $new;
       $cols{$subhead}->{value} = $record->{$subhead};
       $vh = $new;
       }
       if ($row->{html}) {
       push @rows, $row;
       $rowcount++;
       my %newrow = ();
       $row = \%newrow;
       }
     }
   }
   if ($opt->{row_hidden_id}) {
     $row->{id} = $record->{$opt->{row_hidden_id}};
   }
   foreach my $col (@columns) {
     $row->{html} .= cell_open_tag($cols{$col});

     my $datum;
     if ($cols{$col}->{dynamic}) {
       $datum = $dynamic{$cols{$col}->{dynamic}};
     } else {
       $datum = $record->{$col};
     }
     if ((!$datum) and ($cols{$col}->{empty_cell})) {
       $datum = $cols{$col}->{empty_cell};
     }

     $row->{html} .= prep_cell($cols{$col},$datum,$linecount,$record);

     $row->{html} .= '</td>';
   }

   push @rows, $row;
   $rowcount++;
   $linecount++;
 }
 # ----------------------------------------------------------##


 # Do post-processing table assembly --------------------------
 foreach my $row (@rows) {
   my $html = $row->{'html'};
   if ($row->{'vert_headers'}) {
     foreach my $vert (@{$row->{'vert_headers'}}) {
       my $end = $vert->{end} || $rowcount;
       my $cell = cell_open_tag($cols{$vert->{column}},$end - $vert->{begin});
       $cell .= $vert->{content};
       $cell .= '</th>';
       $html = $cell . $html;
     }
   }
   my ($odd,$id);
   if ($row->{dynamic}->{parity}) {
     $odd = ' class="odd"';
   }
   if ($row->{id}) {
     my $name = $opt->{row_hidden_id} .'_'. $row->{dynamic}->{linecount};
     $id = "<input type=\"hidden\" name=\"$name\" value=\"$row->{id}\" $Vend::Xtrailer>";
   }
   $output .= "<tr$odd>$id$html</tr>\n";
 }
 # ----------------------------------------------------------##

 # Set some side-effect scratch variables
 if ($opt->{colheaders}) { $rowcount++; }
 $Tag->tmp('report_table_rowcount',$rowcount);
 $Tag->tmp('report_table_linecount',$linecount - 1);
 $Tag->tmp('report_table_colspan',(scalar(@columns) + scalar(@vertheads)));

 return $output;
}
EOR

SEE ALSO


Name

return_to

ATTRIBUTES

AttributePos.Req.DefaultDescription
page
exclude
stack
scratch
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Global Variables: MV_PAGE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

return_to is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/return_to.coretag
Lines: 103


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: return_to.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag return_to Order    type table_hack
UserTag return_to addAttr 
UserTag return_to Version  $Revision: 1.4 $
UserTag return_to Routine  <<EOR
sub {
use vars qw/$Tag/;
  my ($type, $tablehack, $opt) = @_;

$type = 'form' unless $type;

my ($page, @args) = split /\0/, $CGI::values{ui_return_to};
if($CGI::values{ui_target}) {
  push @args, "ui_target=$CGI::values{ui_target}";
}
my $out = '';
if ($opt->{page}) {
  $page = $opt->{page};
}

    
my $extra;
if($tablehack) {
  my $found;
  for (@args) {
    if(s/^mv_data_table=(.*)//) {
      $extra = "mv_return_table=$1\n";
    }
    elsif (s/^(ui|mv)_return_table=//) {
      $found = "mv_return_table=$_\n";
    }
  }
  $extra = $found if $found;
}

if($type eq 'click') {
  $out .= qq{mv_nextpage=$page\n} if $page;
  for(@args) {
    my ($k, $v) = split /\s*=\s*/, $_, 2;
    next unless length $k;
    next if $k =~ /$opt->{exclude}/;
    $v =~ s/__NULL__/\0/g;
    $out .= qq{$k=$v\n};
  }
if($opt->{stack} or $CGI::values{ui_return_stack}) {
  $type = 'formlink';
}
else {
  $type = 'done';
  $out .= "ui_return_to=\n";
}
}

if($type eq 'formlink') {
$page = $Global::Variable->{MV_PAGE} if ! $page;
$out .= qq{ui_return_to=$page\n};
for(@args) {
tr/\n/\r/;
$out .= qq{ui_return_to=$_\n}
}
}
elsif($type eq 'url') {
$page = $Global::Variable->{MV_PAGE} if ! $page;
$out .= $Tag->area( {
          href => $page,
          form => join("\n", @args),
        });
}
elsif ($type eq 'form') {
$page = $Global::Variable->{MV_PAGE} if ! $page;
$out .= qq{<INPUT TYPE=hidden NAME=ui_return_to VALUE="$page">\n};
for(@args) {
s/"/&quot;/g;
$out .= qq{<INPUT TYPE=hidden NAME=ui_return_to VALUE="$_">\n}
}
}
elsif ($type eq 'regen') {
$page = $Global::Variable->{MV_PAGE} if ! $page;
$out .= qq{<INPUT TYPE=hidden NAME=ui_return_to VALUE="ui_return_to=$page">\n};
for(@args) {
  s/"/&quot;/g;
  $out .= qq{<INPUT TYPE=hidden NAME=ui_return_to VALUE="ui_return_to=$_">\n}
  }
}

$out .= $extra if $extra;

  $::Scratch->{ui_location} = $Tag->area({
                                  href => $page,
                                  form => join "\n", @args,
                              })
  if $opt->{scratch};
  return $out;
}
EOR

SEE ALSO


Name

rotate-table

ATTRIBUTES

AttributePos.Req.DefaultDescription
rotate Yes
interpolate   1interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

rotate-table is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/rotate_table.coretag
Lines: 67


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: rotate_table.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag rotate-table Order        rotate
UserTag rotate-table PosNumber    1
UserTag rotate-table Interpolate  1
UserTag rotate-table HasEndTag    1
UserTag rotate-table Version      $Revision: 1.4 $
UserTag rotate-table Routine      <<EOR
sub {
my ($rotate, $text) = @_;
return $text unless $rotate;
my $rotated = '';
$text =~ s/(.*<TABLE.*?>)//si;
my $out = $1 || '';
$text =~ s:(.*?)</table\s*>:</TABLE>:si;
my $table = $1;

my @cols;

while ($table =~ m:<TR.*?>(.*?)</TR>:sig) {
  push @cols, $1;
}

my $i = 0;
my @rows;
my @meta;
my $rows = 0;
my @r; my @c; my @m;
my ($r,$c);

for (@cols) {
  while(m:<T([HD])(.*?)>(.*?)</T\1>:sig) {
    my $meta = $1 . $2;
    push @r, $3;
    if($meta =~ /SPAN/i) {
      $meta =~ s/\bcolspan\s*=/ROWMETASPAN=/ig;
      $meta =~ s/\browspan\s*=/COLMETASPAN=/ig;
      $meta =~ s/(ROW|COL)META/$1/g;
    }
    push @m, $meta;
  }
  $meta[$i] = [@m];
  $rows[$i] = [@r];
  $i++;
  $rows = $rows < $#r ? $#r : $rows;
  undef @m;
  undef @r;
}
foreach $r (0 .. $rows) {
  $rotated .= "<TR>\n";
  foreach $c (0 .. $#cols) {
    $rotated .= "<T" . $meta[$c]->[$r] . ">";
    $rotated .= "$rows[$c]->[$r]";
    $rotated .= "</TD>\n"
  }
  $rotated .= "</TR>\n";
}
return $out . $rotated . $text;
}
EOR

SEE ALSO


Name

row

ATTRIBUTES

AttributePos.Req.DefaultDescription
width Yes
interpolate   1interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

row is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/row.coretag
Lines: 208


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: row.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag row                 Order        width
UserTag row                 hasEndTag
UserTag row                 Interpolate
UserTag row                 PosNumber    1
UserTag row                 Version      $Revision: 1.4 $
UserTag row                 Routine      <<EOR
sub tag_column {
my($spec,$text) = @_;
my($append,$f,$i,$line,$usable);
my(%def) = qw(
        width 0
        spacing 1
        gutter 2
        wrap 1
        html 0
        align left
      );
my(%spec)  = ();
my(@out)  = ();
my(@lines)  = ();

$spec =~ s/\n/ /g;
$spec =~ s/^\s+//;
$spec =~ s/\s+$//;
$spec = lc $spec;

$spec =~ s/\s*=\s*/=/;
$spec =~ s/^(\d+)/width=$1/;
%spec = split /[\s=]+/, $spec;

for(keys %def) {
  $spec{$_} = $def{$_} unless defined $spec{$_};
}

if($spec{'html'} && $spec{'wrap'}) {
  ::logError("tag_column: can't have 'wrap' and 'html' specified at same time.");
  $spec{wrap} = 0;
}

if(! $spec{align} or $spec{align} !~ /^n/i) {
  $text =~ s/\s+/ /g;
}

my $len = sub {
  my($txt) = @_;
  if (1 or $spec{html}) {
    $txt =~
    s{ <
         (
         [^>'"] +
          |
         ".*?"
          |
         '.*?'
        ) +
      >
    }{}gsx;
  }
  return length($txt);
};

$usable = $spec{'width'} - $spec{'gutter'};
return "BAD_WIDTH" if  $usable < 1;

if($spec{'align'} =~ /^[ln]/i) {
  $f = sub {
        $_[0] .
        ' ' x ($usable - $len->($_[0])) .
        ' ' x $spec{'gutter'};
        };
}
elsif($spec{'align'} =~ /^r/i) {
  $f = sub {
        ' ' x ($usable - $len->($_[0])) .
        $_[0] .
        ' ' x $spec{'gutter'};
        };
}
elsif($spec{'align'} =~ /^i/i) {
  $spec{'wrap'} = 0;
  $usable = 9999;
  $f = sub { @_ };
}
else {
  return "BAD JUSTIFICATION SPECIFICATION: $spec{'align'}";
}

$append = '';
if($spec{'spacing'} > 1) {
  $append .= "\n" x ($spec{'spacing'} - 1);
}

if($spec{'align'} =~ /^n/i) {
  @lines = split(/\r?\n/, $text);
}
elsif(is_yes($spec{'wrap'}) and length($text) > $usable) {
  @lines = wrap($text,$usable);
}
elsif($spec{'align'} =~ /^i/i) {
  $lines[0] = ' ' x $spec{'width'};
  $lines[1] = $text . ' ' x $spec{'gutter'};
}
elsif (! $spec{'html'}) {
  $lines[0] = substr($text,0,$usable);
}

foreach $line (@lines) {
  push @out , &{$f}($line);
  for($i = 1; $i < $spec{'spacing'}; $i++) {
    push @out, '';
  }
}
@out;
}

sub wrap {
  my ($str, $width) = @_;
  my @a = ();
  my ($l, $b);

  for (;;) {
      $str =~ s/^ +//;
      $l = length($str);
      last if $l == 0;
      if ($l <= $width) {
          push @a, $str;
          last;
      }
      $b = rindex($str, " ", $width - 1);
      if ($b == -1) {
          push @a, substr($str, 0, $width);
          $str = substr($str, $width);
      }
      else {
          push @a, substr($str, 0, $b);
          $str = substr($str, $b + 1);
      }
  }
  return @a;
}

sub {
  my($width,$text) = @_;
my($col,$spec);
my(@lines);
my(@len);
my(@out);
my($i,$j,$k);
my($x,$y,$line);

$i = 0;
while( $text =~ s!\[col(?:umn)?\s+
           ([^\]]+)
           \]
           ((?s:.)*?)
           \[/col(?:umn)?\] !!ix    ) {
  $spec = $1;
  $col = $2;
  $lines[$i] = [];
  @{$lines[$i]} = tag_column($spec,$col);
  # Discover X dimension
  $len[$i] = length(${$lines[$i]}[0]);
  if(defined ${$lines[$i]}[1] and ${$lines[$i]}[1] =~ /^<\s*input\s+/i) {
    shift @{$lines[$i]};
  }
  $i++;
}
my $totlen = 0;
for(@len) { $totlen += $_ }
if ($totlen > $width) {
  return " B A D   R O W  S P E C I F I C A T I O N - columns too wide.\n"
}

# Discover y dimension
$j = $#{$lines[0]};
for ($k = 1; $k < $i; $k++) {
  $j = $#{$lines[$k]} > $j ? $#{$lines[$k]} : $j;
}

for($y = 0; $y <= $j; $y++) {
  $line = '';
  for($x = 0; $x < $i; $x++) {
    if(defined ${$lines[$x]}[$y]) {
      $line .= ${$lines[$x]}[$y];
      $line =~ s/\s+$//
        if ($i - $x) == 1;
    }
    elsif (($i - $x) > 1) {
        $line  .= ' ' x $len[$x];
    }
    else {
      $line =~ s/\s+$//;
    }
  }
  push @out, $line;
}
join "\n", @out;
}
EOR

SEE ALSO


Name

row-edit

ATTRIBUTES

AttributePos.Req.DefaultDescription
key Yes
table Yes
size Yes
columns Yes
view
extra
meta_extra
textarea_extra
pointer
stacker
textarea
blank
ui_meta_specific
height
interpolate   1interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: UI_META_TABLE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

row-edit is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/row_edit.coretag
Lines: 176


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: row_edit.coretag,v 1.12 2007-03-30 23:40:54 pajamian Exp $

UserTag row-edit Order       key table size columns
UserTag row-edit HasEndTag
UserTag row-edit addAttr
UserTag row-edit Interpolate 1
UserTag row-edit Version     $Revision: 1.12 $
UserTag row-edit Routine     <<EOR
sub {
my ($key,$table,$size,$columns,$opt) = @_;
use vars qw/$CGI $Values $Variable/;
#::logDebug("row_edit options=" . ::uneval($opt));
$table = $table || $CGI::values{mv_data_table} || return "BLANK DB";
my $db = ::database_exists_ref($table);
my $mtab = $::Variable->{UI_META_TABLE} || 'mv_metadata';
my $mdb = ::database_exists_ref($mtab);
$opt->{view} ||= $CGI->{ui_meta_view};

my $view = Vend::Table::Editor::meta_record($table, $opt->{view}) || {};

my $tm_extra = '';
my $ta_extra = '';
my $tf_extra = '';
if($opt->{extra}) {
  $tf_extra = " $opt->{extra}";
}
if($opt->{meta_extra}) {
  $tm_extra .= " $opt->{meta_extra}";
}
if($opt->{textarea_extra}) {
  $tm_extra .= " $opt->{textarea_extra}";
}

$ta_extra ||= $tf_extra;
$tm_extra ||= $tf_extra;

my $prependor = '';
if($opt->{pointer}) {
  $prependor = $opt->{pointer};
  $prependor =~ s/\D+//;
  $prependor = $prependor ? $prependor . '_' : '';
#::logDebug("setting prependor to $prependor");
}

my $appendor = '';
if($opt->{stacker}) {
  $appendor = "__$opt->{stacker}";
#::logDebug("setting appendor to $appendor");
}
return errmsg("non-existent table '%s' for row-edit", $table)
  unless $db;
$db = $db->ref();

my $acl = UI::Primitive::get_ui_table_acl();

my $record;
my $bad;
if ($key) {
  eval {
    $bad = ! $db->record_exists($key);
    $bad = errmsg('DELETED') if $bad;
  };
  $bad = errmsg('ERROR') if $@;
  if($bad) {
    # Do nothing, we are already bad
  }
  elsif($acl) {
    $bad = errmsg('Not available')
      if ! UI::Primitive::ui_acl_atom($acl, 'keys', $key);
  }
  else {
    $record = $db->row_hash($key);
  }
}

$record ||= {};

my @cols;

if($columns ||= $view->{spread_cols} || $view->{attribute}) {
  @cols = split /[\s,\0]+/, $columns;
  my %col;
  for($db->columns()) {
    $col{$_} = 1;
  }
  @cols = grep defined $col{$_}, @cols;
}
else {
  @cols = $db->columns();
}

if($acl) {
  @cols = UI::Primitive::ui_acl_grep( $acl, 'fields', @cols);
}

# See if we have a textarea reference
my %ta;
if($opt->{textarea}) {
  my @tmp = split /[\s,\0]+/, $opt->{textarea};
  for(@tmp) {
    $ta{$_} = 1;
  }
}

my $out = '';

my $meta   = $CGI->{ui_no_meta_display} ? '' : $view->{spread_meta};
my %do_ta;
my %do_meta;
if($meta) {
  my @metas = grep /\S/, split /[\0,\s]+/, $meta;
  @do_meta{@metas} = @metas;
}

if($view->{spread_textarea}) {
  my @tas = grep /\S/, split /[\0,\s]+/, $view->{spread_textarea};
  @do_ta{@tas} = @tas;
}
my $tmp;

$size = $size || $view->{spread_width} || $view->{width} || 12;
if($bad) {
  for(@cols) {
    $out .= "<TD$tf_extra>$bad</TD>";
  }
}
elsif($key or $opt->{blank}) {
  for(@cols) {
    my $text = $opt->{blank} ? '' : $record->{$_} || '';
    my $msg = '';
    if($do_meta{$_}) {
      my $tmp = Vend::Tags->display( {
                    table => $table,
                    column => $_,
                    name => "$prependor$_$appendor",
                    value => $text,
                    template => ' $WIDGET$ ',
                    specific => $opt->{ui_meta_specific},
                    key => $key,
                  });
      $out .= "<TD$tm_extra>$tmp</TD>";
      next;
    }
    elsif($do_ta{$_}) {
      my $rows = $opt->{height} || 4;
      HTML::Entities::encode($text, $ESCAPE_CHARS::std);
      $out .= <<EOF;
<TD$ta_extra><TEXTAREA NAME="$prependor$_$appendor" COLS="$size" ROWS="$rows">$text \
</TEXTAREA>$msg</TD>
EOF
    }
    else {
      $text =~ s/"/&quot;/g;
      $out .= <<EOF;
<TD$tf_extra><INPUT NAME="$prependor$_$appendor" SIZE=$size VALUE="$text">$msg</TD>
EOF
    }
  }
}
else {
  for(@cols) {
      $out .= <<EOF;
<TH ALIGN=left>$_</TH>
EOF
  }
}
return $out;

}
EOR

SEE ALSO


Name

run-profile — runs form profile

ATTRIBUTES

AttributePos.Req.DefaultDescription
check Yes
cgi Yes
profile Yes
name Yes
no_error
overwrite_error
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tags validates form input against a given form profile.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

run-profile is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/run_profile.coretag
Lines: 60


# Copyright 2002-2009 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: run_profile.coretag,v 1.7 2009-01-26 09:49:11 racke Exp $

UserTag run-profile Order   check cgi profile name
UserTag run-profile addAttr
UserTag run-profile Version $Revision: 1.7 $
UserTag run-profile Routine <<EOR
sub {
my ($check, $cgi, $profile, $name, $opt) = @_;
#::logDebug("call check $check");
my $ref;
my $pname = $name;

if ($opt->{ref}) {
  if (ref($opt->{ref}) eq 'HASH') {
    $ref = $opt->{ref};
  }
  else {
    # error message
    ::logError("Invalid ref parameter provided for profile %s", $pname || $check);
  }
}
elsif ($cgi) {
  $ref = \%CGI::values;
}
else {
  $ref = $::Values;
}

unless ($pname) {
    # check scratch for profile if none specified
    $profile = $Scratch->{"profile_$check"} unless $profile;

  #::logDebug("PROFILE(" . $Tag->var('MV_PAGE',1) . "):***$profile***");
    # test passes if no profile exists
    return 1 if ! $profile;

    $opt->{no_error} = 1 unless defined $opt->{no_error};

    $pname = 'tmp_profile.' . $Vend::Session->{id};
  #Debug("running check $check, pname=$pname profile=$profile");
    $profile .= "\n&fatal=1\n";
    $profile = "&noerror=1\n$profile" if $opt->{no_error};
    $profile = "&overwrite=1\n$profile" if $opt->{overwrite_error};
    $::Scratch->{$pname} = $profile;
}

my ($status) = ::check_order($pname, $ref);

delete $::Scratch->{$pname} unless $name;

return is_yes($opt->{hide}) ? undef : $status;
}
EOR

SEE ALSO


Name

salestax — display salestax for products within cart

ATTRIBUTES

AttributePos.Req.DefaultDescription
name YesNomaincart name
convert  NoConvert the amount according to the PriceDivide value for the current locale.
noformatYesNoNoOutput plain number instead of formatting it according to the currency locale?
display  symbolDisplay currency as symbol, text or not at all?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

salestax is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/salestax.coretag
Lines: 21


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: salestax.coretag,v 1.8 2007-03-30 23:40:49 pajamian Exp $

UserTag salestax            Order        name noformat
UserTag salestax            attrAlias    cart name
UserTag salestax            attrAlias    space discount_space
UserTag salestax            addAttr
UserTag salestax            PosNumber    2
UserTag salestax            Version      $Revision: 1.8 $
UserTag salestax            Routine      <<EOR
sub {
my($cart, $noformat, $opt) = @_;
return currency( salestax($cart, $opt), $noformat, undef, $opt);
}
EOR


Name

save_cart — save shopping cart to UserDB

ATTRIBUTES

AttributePos.Req.DefaultDescription
nickname | name YesYes  Cart specification string. The string is colon-separated, and contains three fields: the cart name, time of save, and type. Time of save is measured in seconds since the epoch. Type can be c (cart) or r (recurring).
recurring Yes  
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag saves current cart to UserDB.

Note that the cart name does not have to be unique. If there are more carts with the same nickname, an index will be added.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Save cart to UserDB

Place the following on an Interchange page:

[save_cart mycart]

NOTES

AVAILABILITY

save_cart is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/save_cart.tag
Lines: 50


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: save_cart.tag,v 1.7 2007-12-16 10:15:09 kwalsh Exp $

UserTag save_cart Order     nickname recurring keep
UserTag save_cart AttrAlias name nickname
UserTag save_cart Version   $Revision: 1.7 $
UserTag save_cart Routine   <<EOR
sub {
my($nickname,$recurring,$keep) = @_;

my $add = 0;
my %names = ();

$nickname =~ s/://g;
$recurring = ($recurring?"r":"c");

foreach(split("\n",$Tag->value('carts'))) {
  my($n,$t,$r) = split(':',$_);
  $names{$n} = $r;
  if($r eq $recurring) {
    if($n eq $nickname) {
      #$Tag->userdb({function => 'delete_cart', nickname => $_});
      $add = 1;
    }
  }
}
if($add) {
  while($names{"$nickname,$add"} eq $recurring) {
    $add++;
  }
  $nickname .= ",$add";
}

my $nn = join(':',$nickname,time(),$recurring);

unless ($Tag->userdb({function => 'set_cart', nickname => $nn})) {
  return '';
}

$Carts->{main} = [] unless is_yes($keep);

return '';
}
EOR


Name

scratch — return content of the named scratch variable

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Name of the scratch variable.
filter Filter to apply to the value.
keep 0 Keep variable value in memory intact, and only apply filter for display?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag returns value of the named scratch variable.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

Scratch variables cannot be set using the scratch tag; see scratch glossary entry for a complete discussion.

AVAILABILITY

scratch is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/scratch.coretag
Lines: 24


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: scratch.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag scratch             Order        name
UserTag scratch             PosNumber    1
UserTag scratch             addAttr
UserTag scratch             Version      $Revision: 1.6 $
UserTag scratch             Routine      <<EOR
sub {
my ($var, $opt) = @_;
my $value = $::Scratch->{$var};
if($opt->{filter}) {
  $value = filter_value($opt->{filter}, $value, $var);
  $::Scratch->{$var} = $value unless $opt->{keep};
}
  return $value;
}
EOR


Name

scratchd — return value of scratch variable, then delete the variable

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Name of the scratch variable.
filter Filter to apply to the value.
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag returns value of the named scratch variable, and then deletes the variable.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

Scratch variables cannot be set using the scratch tag; see scratch glossary entry for a complete discussion.

AVAILABILITY

scratchd is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/scratchd.coretag
Lines: 23


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: scratchd.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag scratchd            Order        name
UserTag scratchd            PosNumber    1
UserTag scratchd            addAttr
UserTag scratchd            Version      $Revision: 1.6 $
UserTag scratchd            Routine      <<EOR
sub {
my ($var, $opt) = @_;
my $value = delete $::Scratch->{$var};
if ($opt->{filter}) {
  $value = filter_value($opt->{filter}, $value, $var);
}
return $value;
}
EOR

SEE ALSO

scratch(7ic)


Name

search

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

search is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/search.coretag
Lines: 11


# Copyright 2002-2009 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag search              Order        search
UserTag search              addAttr
UserTag search              Version      $Revision: 1.5 $
UserTag search              MapRoutine   Vend::Page::do_search

Source: lib/Vend/Page.pm
Lines: 219

sub do_search {
my($c) = @_;
::update_user();

# If search parameters not passed in via function, then safely pull them from
# the CGI values.
if (!is_hash($c)) {
  $c = find_search_params(\%CGI::values);
  _check_search_file($c);
}

if ($c->{mv_more_matches}) {
  $Vend::Session->{last_search} = "scan/MM=$c->{mv_more_matches}";
  $c->{mv_more_matches} =~ m/([a-zA-Z0-9])+/;
  $c->{mv_cache_key} = $1;
}
else {
  create_last_search($c);
}

$c->{mv_cache_key} = generate_key($Vend::Session->{last_search})
    unless defined $c->{mv_cache_key};

my $retval = perform_search($c);

if (ref($retval)) {
  $::Instance->{SearchObject}{''} = $retval;
  $CGI::values{mv_nextpage}  = $retval->{mv_search_page}
    || find_special_page('search')
      if ! $CGI::values{mv_nextpage};
}
return 1;
}

SEE ALSO


Name

search-region — container for search results

ATTRIBUTES

AttributePos.Req.DefaultDescription
arg Yes
search search specification
prefix item
list_prefix search-list
more No enable paginating with more_list
ml 50 number of items to display
more_template template for more_list
form form parameters embedded into more links
more_routine custom routine for more_list
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

search-region is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/search_region.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: search_region.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag search-region       Order        arg
UserTag search-region       addAttr
UserTag search-region       attrAlias    args arg
UserTag search-region       attrAlias    params arg
UserTag search-region       attrAlias    search arg
UserTag search-region       hasEndTag
UserTag search-region       PosNumber    0
UserTag search-region       Version      $Revision: 1.4 $
UserTag search-region       MapRoutine   Vend::Interpolate::tag_search_region

Source: lib/Vend/Interpolate.pm
Lines: 3155

sub tag_search_region {
my($params, $opt, $text) = @_;
$opt->{search} = $params if $params;
$opt->{prefix}      ||= 'item';
$opt->{list_prefix} ||= 'search[-_]list';
# LEGACY
list_compat($opt->{prefix}, \$text) if $text;
# END LEGACY
return region($opt, $text);
}

SEE ALSO


Name

search_region

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

search_region is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 3155

sub tag_search_region {
my($params, $opt, $text) = @_;
$opt->{search} = $params if $params;
$opt->{prefix}      ||= 'item';
$opt->{list_prefix} ||= 'search[-_]list';
# LEGACY
list_compat($opt->{prefix}, \$text) if $text;
# END LEGACY
return region($opt, $text);
}

SEE ALSO


Name

selected — identicate selected status of HTML options

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes variable name
value Yes
cgi
default
case
delimiter
multiple
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

selected is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/selected.coretag
Lines: 58


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: selected.coretag,v 1.9 2007-03-30 23:40:49 pajamian Exp $

UserTag selected            Order        name value
UserTag selected            addAttr
UserTag selected            PosNumber    2
UserTag selected            Version      $Revision: 1.9 $
UserTag selected            Routine      <<EOR
# Returns ' SELECTED' when a value is present on the form
# Must match exactly, but NOT case-sensitive
sub {
my ($field,$value,$opt) = @_;
$value = '' unless defined $value;
my $ref = $opt->{cgi} ? $CGI::values{$field} : $::Values->{$field};
return ' selected="selected"' if ! length($ref) and $opt->{default};

if(! $opt->{case}) {
  $ref = lc($ref);
  $value = lc($value);
}

my $r = '';

return ' selected="selected"' if $ref eq $value;

if ($opt->{delimiter}) {
  $opt->{multiple} = 1;
}

if ($opt->{multiple}) {
    
    my $be;
    my $ee;
    $opt->{delimiter} = "\0" unless defined $opt->{delimiter};

    if (length $opt->{delimiter}) {
  my $del = Vend::Interpolate::get_joiner($opt->{delimiter}, "\0");
  $be = '(?:^|' . $del . ')'; ;
  $ee = '(?:$|' . $del . ')'; ;
    }
    else {
  $be = '';
  $ee = '';
    }

    my $regex = qr/$be\Q$value\E$ee/;
    return ' selected="selected"' if $ref =~ $regex;
}

return '';
}
EOR

SEE ALSO

checked(7ic)


Name

self_contained_if

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

self_contained_if is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source:
Lines: 0

No extracted context

SEE ALSO


Name

set — set value of scratch variable, without interpolation

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Name of the scratch variable.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag sets value of the named scratch variable.

By default, the provided value is not interpolated before assignment. To interpolate contents, use seti or provide interpolate=1 attribute to this tag.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

See scratch glossary entry for a complete discussion.

AVAILABILITY

set is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/set.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: set.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag set                 Order        name
UserTag set                 hasEndTag
UserTag set                 PosNumber    1
UserTag set                 Version      $Revision: 1.5 $
UserTag set                 MapRoutine   Vend::Interpolate::set_scratch

Source: lib/Vend/Interpolate.pm
Lines: 5242

sub set_scratch {
my($var,$val) = @_;
  $::Scratch->{$var} = $val;
return '';
}

SEE ALSO

scratch(7ic)


Name

set-cookie — sets browser cookie

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes name of the cookie
value Yes value of the cookie
expire Yes
domain Yes
path Yes
secure Yes 0 cookie is sent only over SSL connections
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

set-cookie is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/set_cookie.coretag
Lines: 12


# Copyright 2002-2008 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: set_cookie.coretag,v 1.7 2008-09-13 04:28:56 jon Exp $

UserTag set-cookie          Order        name value expire domain path secure
UserTag set-cookie          Version      $Revision: 1.7 $
UserTag set-cookie          MapRoutine   Vend::Util::set_cookie

Source: lib/Vend/Util.pm
Lines: 2091

sub set_cookie {
  my ($name, $value, $expire, $domain, $path, $secure) = @_;

  # Set expire to now + some time if expire string is something like
  # "30 days" or "7 weeks" or even "60 minutes"
if($expire =~ /^\s*\d+[\s\0]*[A-Za-z]\S*\s*$/) {
    $expire = adjust_time($expire);
}

if (! $::Instance->{Cookies}) {
  $::Instance->{Cookies} = []
}
else {
  @{$::Instance->{Cookies}} =
    grep $_->[0] ne $name, @{$::Instance->{Cookies}};
}
  push @{$::Instance->{Cookies}}, [$name, $value, $expire, $domain, $path, $secure];
  return;
}


Name

seti — set value of scratch variable, with interpolation

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Name of the scratch variable.
interpolate   1interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag sets value of the named scratch variable.

By default, the provided value is interpolated before assignment. To not interpolate contents, use set or provide interpolate=0 attribute to this tag.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

See scratch glossary entry for a complete discussion.

AVAILABILITY

seti is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/seti.coretag
Lines: 15


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: seti.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag seti                Order        name
UserTag seti                hasEndTag
UserTag seti                Interpolate
UserTag seti                PosNumber    1
UserTag seti                Version      $Revision: 1.5 $
UserTag seti                MapRoutine   Vend::Interpolate::set_scratch

Source: lib/Vend/Interpolate.pm
Lines: 5242

sub set_scratch {
my($var,$val) = @_;
  $::Scratch->{$var} = $val;
return '';
}

SEE ALSO

scratch(7ic)


Name

setlocale — Change current locale

ATTRIBUTES

AttributePos.Req.DefaultDescription
locale Yes
currency Yes 0 change currency settings only
get
persist 0 change locale for complete session
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag changes the current locale. By default the change is only in effect for the current page.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Use German locale for current page

[setlocale de_DE]

Example: Use Croatian locale for complete session

[setlocale locale=hr_HR persist=1]

NOTES

AVAILABILITY

setlocale is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/setlocale.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: setlocale.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag setlocale           Order        locale currency
UserTag setlocale           addAttr
UserTag setlocale           PosNumber    2
UserTag setlocale           Version      $Revision: 1.4 $
UserTag setlocale           MapRoutine   Vend::Util::setlocale

Source: lib/Vend/Util.pm
Lines: 459

sub setlocale {
  my ($locale, $currency, $opt) = @_;
#::logDebug("original locale " . (defined $locale ? $locale : 'undef') );
#::logDebug("default locale  " . (defined $::Scratch->{mv_locale} ? $::Scratch->{mv_locale} \
 : 'undef') );

if($opt->{get}) {
    my $loc     = $Vend::Cfg->{Locale_repository} or return;
    my $currloc = $Vend::Cfg->{Locale} or return;
    for(keys %$loc) {
    return $_ if $loc->{$_} eq $currloc;
    }
    return;
}

  $locale = $::Scratch->{mv_locale} unless defined $locale;
#::logDebug("locale is now   " . (defined $locale ? $locale : 'undef') );

  if ( $locale and not defined $Vend::Cfg->{Locale_repository}{$locale}) {
      ::logError( "attempt to set non-existant locale '%s'" , $locale );
      return '';
  }

  if ( $currency and not defined $Vend::Cfg->{Locale_repository}{$currency}) {
      ::logError("attempt to set non-existant currency '%s'" , $currency);
      return '';
  }

  if($locale) {
      my $loc = $Vend::Cfg->{Locale} = $Vend::Cfg->{Locale_repository}{$locale};

      for(@Vend::Config::Locale_directives_scalar) {
          $Vend::Cfg->{$_} = $loc->{$_}
              if defined $loc->{$_};
      }

      for(@Vend::Config::Locale_directives_ary) {
          @{$Vend::Cfg->{$_}} = split (/\s+/, $loc->{$_})
              if $loc->{$_};
      }

      for(@Vend::Config::Locale_directives_code) {
    next unless $loc->{$_->[0]};
    my ($routine, $args) = @{$_}[1,2];
    if($args) {
      $routine->(@$args);
    }
    else {
      $routine->();
    }
      }

  no strict 'refs';
  for(qw/LC_COLLATE LC_CTYPE LC_TIME/) {
    next unless $loc->{$_};
    POSIX::setlocale(&{"POSIX::$_"}, $loc->{$_});
  }
  }

  if ($currency) {
      my $curr = $Vend::Cfg->{Currency_repository}{$currency};

      for(@Vend::Config::Locale_directives_currency) {
          $Vend::Cfg->{$_} = $curr->{$_}
              if defined $curr->{$_};
      }

      for(@Vend::Config::Locale_keys_currency) {
          $Vend::Cfg->{Locale}{$_} = $curr->{$_}
              if defined $curr->{$_};
      }
  }

if(my $ref = $Vend::Cfg->{CodeDef}{LocaleChange}) {
  $ref = $ref->{Routine};
  if($ref->{all}) {
    $ref->{all}->($locale, $opt);
  }
  if($ref->{lc $locale}) {
    $ref->{lc $locale}->($locale, $opt);
  }
}

  if($opt->{persist}) {
  $::Scratch->{mv_locale}   = $locale    if $locale;
  delete $::Scratch->{mv_currency_tmp};
  delete $::Scratch->{mv_currency};
  $::Scratch->{mv_currency} = $currency if $currency;
}
elsif($currency) {
  Vend::Interpolate::set_tmp('mv_currency_tmp')
    unless defined $::Scratch->{mv_currency_tmp};
  $::Scratch->{mv_currency_tmp} = $currency;
}
else {
  delete $::Scratch->{mv_currency_tmp};
  delete $::Scratch->{mv_currency};
}

  return '';
}

SEE ALSO


Name

shipping — display shipping cost for items in electronic cart

ATTRIBUTES

AttributePos.Req.DefaultDescription
mode Yes shipping mode
possible list available shipping modes
resolve resolve shipping mode
check_validity 0 whether to check shipping mode is valid or not
widget
label
handling
free text for free shipping
reset_modes
add
file
default
output_options
country_var country name of country variable in value namespace
state_var state name of state variable in value namespace
noformat
display  symbolDisplay currency as symbol, text or not at all?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

Without any parameters, shipping displays the shipping cost for the items in the cart.

List currently available shipping modes and shipping parameters

[shipping possible=1]

This can be used to display custom parameters for the currently available shipping modes with the shipping-desc tag:

[loop list="[shipping possible=1]"]
Shipping Mode:   [shipping-desc mode="[loop-code]"]
Processing time: [shipping-desc mode="[loop-code]" key=p_time]
Shipping time:   [shipping-desc mode="[loop-code]" key=s_time]
Cost:            [shipping mode="[loop-code]"]
[/loop]

Check and resolve shipping modes

The availability of shipping modes depends on shipping parameters, usually the shipping country. [shipping check_validity=1] checks whether the shipping mode in the mv_shipmode variable is still valid. [shipping resolve=1] updates this variable if necesssary.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example:

<select name="mv_shipmode">
[shipping free="Free!" label=1 
    format=|<option value="%M"%S>%D</option>| 
    mode=|[shipping possible=1]|
]
</select>

NOTES

AVAILABILITY

shipping is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/shipping.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: shipping.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag shipping            Order        mode
UserTag shipping            addAttr
UserTag shipping            attrAlias    tables table
UserTag shipping            attrAlias    carts cart
UserTag shipping            attrAlias    modes mode
UserTag shipping            attrAlias    name mode
UserTag shipping            PosNumber    1
UserTag shipping            Version      $Revision: 1.5 $
UserTag shipping            MapRoutine   Vend::Ship::tag_shipping

Source: lib/Vend/Ship.pm
Lines: 1101

sub tag_shipping {
my($mode, $opt) = @_;
$opt = { noformat => 1, convert => 1 } unless $opt;

return resolve_shipmode($mode, $opt)
  if $opt->{possible} || $opt->{resolve} || $opt->{check_validity};

$Ship_its = 0;
if(! $mode) {
  if($opt->{widget} || $opt->{label}) {
    $mode = resolve_shipmode(undef, { no_set => $opt->{no_set}, possible => 1});
  }
  else {
    $mode = $opt->{handling}
        ? ($::Values->{mv_handling})
        : ($::Values->{mv_shipmode} || 'default');
  }
}

my $loc = $Vend::Cfg->{Shipping_repository}
    && $Vend::Cfg->{Shipping_repository}{default};
$loc ||= {};

$Vend::Cfg->{Shipping_line} = [] 
  if $opt->{reset_modes};
read_shipping(undef, $opt) if $Vend::Cfg->{SQL_shipping};
read_shipping(undef, $opt) if $opt->{add};
read_shipping($opt->{file}) if $opt->{file};
my $out;

#::logDebug("Shipping mode(s) $mode");
my (@modes) = grep /\S/, split /[\s,\0]+/, $mode;
if($opt->{default}) {
  undef $opt->{default}
    if tag_shipping($::Values->{mv_shipmode});
}
if($opt->{label} || $opt->{widget}) {
  my @out;
  if($opt->{widget}) {
    $opt->{label} = 1;
    $opt->{output_options} = 1;
  }
  for(@modes) {
    my $return = shipping($_, $opt);
#::logDebug("pushing $return");
    #push @out, shipping($_, $opt);
    push @out, $return;
  }
  @out = grep /=.+/, @out;

  if(! @out and ! $opt->{hide_error}) {
    my $message = $loc->{no_modes_message} || 'Not enough information';
    @out = "=" . errmsg($message);
  }

  if($opt->{widget}) {
    my $o = { %$opt };
    $o->{type} = delete $o->{widget};
    $o->{passed} = join ",", @out;
    $o->{name} ||= 'mv_shipmode';
    $o->{value} ||= $::Values->{mv_shipmode};
    $out = Vend::Form::display($o);
  }
  else {
    $out = join "", @out;
  }
}
else {
  ### If the user has assigned to shipping or handling,
  ### we use their value
  if($Vend::Session->{assigned}) {
    my $tag = $opt->{handling} ? 'handling' : 'shipping';
    $out = $Vend::Session->{assigned}{$tag} 
      if defined $Vend::Session->{assigned}{$tag} 
      && length( $Vend::Session->{assigned}{$tag});
  }
  ### If no assignment has been made, we read the shipmodes
  ### and use their value
  unless (defined $out) {
    $out = 0;
    for(@modes) {
      $out += shipping($_, $opt) || 0;
    }
  }
  $out = Vend::Util::round_to_frac_digits($out);
  ## Conversion would have been done above, force to 0, as
  ## found by Frederic Steinfels
  $out = currency($out, $opt->{noformat}, 0, $opt);
}
return $out unless $opt->{hide};
return;
}


Name

shipping-desc — displays shipping mode description

ATTRIBUTES

AttributePos.Req.DefaultDescription
mode Yes shipping mode
key Yes description
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

shipping-desc allows access to arbitrary keys in the shipping configuration.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Display shipping modes and corresponding information

The following snippet out of shipping.asc contains additional information which can be displayed with shipping-desc.

usps: USPS 1st class
        crit        [onlyitems]
        min         0
        max         0
        cost        e No shipping needed!
        at_least    0
        adder       0
        p_time      1-2 business days
        s_time      3-7 business days

        min         1
        max         6
        cost        4.00

        min         7
        max         12
        cost        7.00

[loop list="[shipping possible=1]"]
Shipping Mode:   [shipping-desc mode="[loop-code]"]
Processing time: [shipping-desc mode="[loop-code]" key=p_time]
Shipping time:   [shipping-desc mode="[loop-code]" key=s_time]
Cost:            [shipping mode="[loop-code]"]
[/loop]

NOTES

AVAILABILITY

shipping-desc is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/shipping_desc.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: shipping_desc.coretag,v 1.6 2007-09-21 16:15:48 kwalsh Exp $

UserTag shipping-description Alias       shipping-desc

UserTag shipping-desc        Order       mode key
UserTag shipping-desc        Version     $Revision: 1.6 $
UserTag shipping-desc        MapRoutine  Vend::Ship::tag_shipping_desc

Source: lib/Vend/Ship.pm
Lines: 1286

sub tag_shipping_desc {
my $mode =   shift;
my $key = shift || 'description';
$mode = $mode || $::Values->{mv_shipmode} || 'default';
return errmsg($Vend::Cfg->{Shipping_hash}{$mode}{$key});
}


Name

shipping-description

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

shipping-description is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/shipping_desc.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: shipping_desc.coretag,v 1.6 2007-09-21 16:15:48 kwalsh Exp $

UserTag shipping-description Alias       shipping-desc

UserTag shipping-desc        Order       mode key
UserTag shipping-desc        Version     $Revision: 1.6 $
UserTag shipping-desc        MapRoutine  Vend::Ship::tag_shipping_desc

SEE ALSO


Name

soap

ATTRIBUTES

AttributePos.Req.DefaultDescription
call Yes
uri Yes
proxy Yes
param
trace_transport
object
result
init
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

soap is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/soap.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: soap.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag soap                Order        call uri proxy
UserTag soap                addAttr
UserTag soap                PosNumber    3
UserTag soap                Version      $Revision: 1.6 $
UserTag soap                MapRoutine   Vend::SOAP::tag_soap

UserTag soap_entity      addAttr
UserTag soap_entity      Version      $Revision: 1.6 $
UserTag soap_entity      MapRoutine   Vend::SOAP::tag_soap_entity

Source: lib/Vend/SOAP.pm
Lines: 170

sub tag_soap {
my ($method, $uri, $proxy, $opt) = @_;
my @args;
if($opt->{param}) {
  if (ref($opt->{param}) eq 'ARRAY') {
    @args = @{$opt->{param}};
  }
  elsif (ref($opt->{param}) eq 'HASH') {
    @args = %{$opt->{param}};
  }
  else {
    @args = $opt->{param};
  }
}
else {
  @args = $opt;
}

if($opt->{trace_transport}) {
  if (exists $Vend::Cfg->{Sub}->{$opt->{trace_transport}}) {
    SOAP::Trace->import('transport' => $Vend::Cfg->{Sub}->{$opt->{trace_transport}});
  } else {
    ::logError (qq{no such subroutine "$opt->{trace_transport}" for SOAP transport tracing});
  }
}

my $result;
#::logDebug("to method call, uri=$uri proxy=$proxy call=$method args=" . ::uneval(\@args));
eval {
  if(! $method ) {
    $result = SOAP::Lite
        -> uri($uri)
        -> proxy($proxy)
        -> call ('init');
  }
  elsif(ref $opt->{object}) {
    $result = $opt->{object}
        -> uri($uri)
        -> proxy($proxy)
        -> call( $method => @args )
        -> result;
  }
  else {
    $result = SOAP::Lite
        -> uri($uri)
        -> proxy($proxy)
        -> call( $method => @args )
        -> result;
  }
};
if($@) {
  ::logError("error on SOAP call: %s", $@);
}
#::logDebug("after method call, uri=$uri proxy=$proxy call=$method result=$result");

$::Scratch->{$opt->{result}} = $result if $opt->{result};
return '' if $opt->{init};
return $result;
}

SEE ALSO


Name

soap_entity

ATTRIBUTES

AttributePos.Req.DefaultDescription
tree
value
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

soap_entity is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/soap.coretag
Lines: 18


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: soap.coretag,v 1.6 2007-03-30 23:40:49 pajamian Exp $

UserTag soap                Order        call uri proxy
UserTag soap                addAttr
UserTag soap                PosNumber    3
UserTag soap                Version      $Revision: 1.6 $
UserTag soap                MapRoutine   Vend::SOAP::tag_soap

UserTag soap_entity      addAttr
UserTag soap_entity      Version      $Revision: 1.6 $
UserTag soap_entity      MapRoutine   Vend::SOAP::tag_soap_entity

Source: lib/Vend/SOAP.pm
Lines: 186

sub tag_soap_entity {
my ($opt) = @_;
my ($obj);

if ($opt->{tree}) {
  my @values = map {tag_soap_entity($_)} @{$opt->{value}};
  $opt->{value} = \@values;
}
eval {$obj = new SOAP::Data (%$opt);};
if ($@) {
  logError ("soap_entity failed: $@");
  return;
}
return $obj;
}

SEE ALSO


Name

sort_ary

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

sort_ary is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 3016

sub tag_sort_ary {
  my($opts, $list) = (@_); 
  $opts =~ s/^\s+//; 
  $opts =~ s/\s+$//; 
#::logDebug("tag_sort_ary: opts=$opts list=" . uneval($list));
my @codes;
my $key = 0;

my ($start, $end, $num);
my $glob_opt = 'none';

  my @opts =  split /\s+/, $opts;
  my @option; my @bases; my @fields;

  for(@opts) {
      my ($base, $fld, $opt) = split /:/, $_;

  if($base =~ /^(\d+)$/) {
    $key = $1;
    $glob_opt = $fld || $opt || 'none';
    next;
  }
  if($base =~ /^([-=+])(\d+)-?(\d*)/) {
    my $op = $1;
    if    ($op eq '-') { $start = $2 }
    elsif ($op eq '+') { $num   = $2 }
    elsif ($op eq '=') {
      $start = $2;
      $end = ($3 || undef);
    }
    next;
  }
  
      push @bases, $base;
      push @fields, $fld;
      push @option, (defined $Vend::Interpolate::Sort_field{$opt} ? $opt : 'none');
  }

if(defined $end) {
  $num = 1 + $end - $start;
  $num = undef if $num < 1;
 }

  my $i;
  my $routine = 'sub { ';
for( $i = 0; $i < @bases; $i++) {
    $routine .= '&{$Vend::Interpolate::Sort_field{"' .
          $option[$i] .
          '"}}(' . "\n";
    $routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[0]->[$key]),\n";
    $routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[1]->[$key]) ) or ";
}
$routine .= qq!0 or &{\$Vend::Interpolate::Sort_field{"$glob_opt"}}!;
$routine .= '($_[0]->[$key],$_[1]->[$key]); }';
#::logDebug("tag_sort_ary routine: $routine\n");

  my $code = eval $routine;  
  die "Bad sort routine\n" if $@;

#Prime the sort? Prevent variable suicide??
#&{$Vend::Interpolate::Sort_field{'n'}}('31', '30');

use locale;
if($::Scratch->{mv_locale}) {
  POSIX::setlocale(POSIX::LC_COLLATE(),
    $::Scratch->{mv_locale});
}

@codes = sort {&$code($a, $b)} @$list;

if($start > 1) {
  splice(@codes, 0, $start - 1);
}

if(defined $num) {
  splice(@codes, $num);
}
#::logDebug("tag_sort_ary routine returns: " . uneval(\@codes));
return \@codes;
}

SEE ALSO


Name

sort_hash

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

sort_hash is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 3102

sub tag_sort_hash {
  my($opts, $list) = (@_); 
  $opts =~ s/^\s+//; 
  $opts =~ s/\s+$//; 
#::logDebug("tag_sort_hash: opts=$opts list=" . uneval($list));
my @codes;
my $key = 'code';

my ($start, $end, $num);
my $glob_opt = 'none';

  my @opts =  split /\s+/, $opts;
  my @option; my @bases; my @fields;

  for(@opts) {

  if(/^(\w+)(:([flnr]+))?$/) {
    $key = $1;
    $glob_opt = $3 || 'none';
    next;
  }
  if(/^([-=+])(\d+)-?(\d*)/) {
    my $op = $1;
    if    ($op eq '-') { $start = $2 }
    elsif ($op eq '+') { $num   = $2 }
    elsif ($op eq '=') {
      $start = $2;
      $end = ($3 || undef);
    }
    next;
  }
      my ($base, $fld, $opt) = split /:/, $_;
  
      push @bases, $base;
      push @fields, $fld;
      push @option, (defined $Vend::Interpolate::Sort_field{$opt} ? $opt : 'none');
  }

if(defined $end) {
  $num = 1 + $end - $start;
  $num = undef if $num < 1;
 }

if (! defined $list->[0]->{$key}) {
  logError("sort key '$key' not defined in list. Skipping sort.");
  return $list;
}

  my $i;
  my $routine = 'sub { ';
for( $i = 0; $i < @bases; $i++) {
    $routine .= '&{$Vend::Interpolate::Sort_field{"' .
          $option[$i] .
          '"}}(' . "\n";
    $routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[0]->{$key}),\n";
    $routine .= "tag_data('$bases[$i]','$fields[$i]', \$_[1]->{$key}) ) or ";
}
$routine .= qq!0 or &{\$Vend::Interpolate::Sort_field{"$glob_opt"}}!;
$routine .= '($a->{$key},$_[1]->{$key}); }';

#::logDebug("tag_sort_hash routine: $routine\n");
  my $code = eval $routine;  
  die "Bad sort routine\n" if $@;

#Prime the sort? Prevent variable suicide??
#&{$Vend::Interpolate::Sort_field{'n'}}('31', '30');

use locale;
if($::Scratch->{mv_locale}) {
  POSIX::setlocale(POSIX::LC_COLLATE(),
    $::Scratch->{mv_locale});
}

@codes = sort {&$code($a,$b)} @$list;

if($start > 1) {
  splice(@codes, 0, $start - 1);
}

if(defined $num) {
  splice(@codes, $num);
}
#::logDebug("tag_sort_hash routine returns: " . uneval(\@codes));
return \@codes;
}

SEE ALSO


Name

sql_list

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

sql_list is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 4700

sub tag_sql_list {
  my($text,$ary,$nh,$opt,$na) = @_;
$opt = {} unless defined $opt;
$opt->{prefix}      = 'sql' if ! defined $opt->{prefix};
$opt->{list_prefix} = 'sql[-_]list' if ! defined $opt->{prefix};

my $object = {
        mv_results => $ary,
        mv_field_hash => $nh,
        mv_return_fields => $na,
        mv_more_id => $opt->{mv_more_id},
        matches => scalar @$ary,
      };

# Scans the option hash for more search settings if mv_more_alpha
# is set in [query ...] tag....
if($opt->{ma}) {
  # Find the sort field and alpha options....
  Vend::Scan::parse_profile_ref($object, $opt);
  # We need to turn the hash reference into a search object
  $object = new Vend::Search (%$object);
  # Delete this so it will meet conditions for creating a more
  delete $object->{mv_matchlimit};
}

$opt->{object} = $object;
  return region($opt, $text);
}

SEE ALSO


Name

strip — trim leading and trailing whitespace

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

The filter eliminates whitespace appearing at the beginning or end of input.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Filter example

"[filter strip]  XX  [/filter]"

NOTES

In Interchange version 4.6.0, this symbol changed type from Filter to System Tag.

AVAILABILITY

strip is available in Interchange versions:

4.6.0, 4.6.0, 4.8.0, 5.0.0, 5.2.0, 5.4.0, 5.6.0, 5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/strip.coretag
Lines: 20


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: strip.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag strip               hasEndTag
UserTag strip               PosNumber    0
UserTag strip               Version      $Revision: 1.4 $
UserTag strip               Routine      <<EOR
sub {
local($_) = shift;
s/^\s+//;
s/\s+$//;
return $_;
}
EOR


Name

su

ATTRIBUTES

AttributePos.Req.DefaultDescription
username | user
profile
admin
create_user
exit
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

su is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/su.coretag
Lines: 188


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: su.coretag,v 1.8 2007-03-30 23:40:54 pajamian Exp $

UserTag su Description  Switch User Tag for catalog superuser
UserTag su Order        username
UserTag su attrAlias    user username
UserTag su addAttr
UserTag su Version      $Revision: 1.8 $
UserTag su Routine      <<EOR
sub {
my ($user, $opt) = @_;
use vars qw/$Session $Tag $ready_safe $Scratch/;

# Note: If adding any new %$opt keys, make sure to also add them to
# the list of options to be stripped before passing the remainder
# to tag userdb; search below for $new_user.

$opt->{profile} = 'ui'     if $opt->{admin} and ! $opt->{profile};

my $u;
if($opt->{profile}) {
  $u = $Vend::Cfg->{UserDB_repository}{$opt->{profile}};
}
else {
  $u = $Vend::Cfg->{UserDB};
}

if(! $u) {
  my $place = $opt->{profile} || 'default';
  ::logError("Can't find UserDB repository, profile '%s'", $place);
  return undef;
}
my $table  = $u->{database} || 'userdb';
my $ufield = $u->{user_field} || 'username';
my $going_to_admin = $u->{admin} || $opt->{admin};
#::logDebug("user table=$table ufield=$ufield");

if ($opt->{create_user}) {
  # these settings must be done before any access to the table
  $Vend::WriteDatabase{$table} = 1;
}

my $super  = $Tag->if_mm('super');
my $former = $Vend::username;

if($user and $going_to_admin and ! $super) {
  ::logError("attempt to su to admin user %s by non-super user %s",
          $user,
          $former,
        );
  return undef;
}
elsif($user and ! $Vend::admin) {
  ::logError("attempt to su to user %s by non-admin user %s",
          $user,
          $former,
        );
  return undef;
}

my $dir = "$Global::ConfDir/tmp";
if (! -d $dir) {
  if(-e $dir) {
    logGlobal("Global tmp directory exists as file, aborting su");
    return undef;
  }
  File::Path::mkpath($dir);
}

if($opt->{exit}) {
  if(! $Session->{su}) {
    logError("attempt to return to superuser without saved session.");
    return;
  }
  my $string = delete $Session->{su};
  my $key = $Tag->read_cookie({ name => 'MV_SU_KEY'})
    or do {
      logError("no session key in cookie, cannot exit");
      return;
    };
  my $fn = "$dir/$Session->{id}";
  open(MDCHECK, "< $fn")
    or do {
      logError("no saved session key in %s, cannot exit", $fn);
      return;
    };
  my $rand = <MDCHECK>;
  close MDCHECK;
  if(generate_key($rand . $string) ne $key) {
    logError("mismatched session key with saved session, cannot exit");
    return;
  }

  my $former = $Session->{username};
  ## Authenticated
  undef $Vend::Session;
  undef $Session;
  $Vend::Session = $ready_safe->reval($string);
  $Session = $Vend::Session;
  delete $Session->{su};
  $Vend::admin = $Vend::Session->{admin};
  $Vend::username = $Vend::Session->{username};
  $Tag->if_mm('logged_in')
    and logError(
        "Admin user %s returned from login as %s",
        $Session->{username},
        $former,
      )
    and return 1;
  return;
}
elsif ($user) {
  my $new_user;
  if(! $Tag->data($table, $ufield, $user) ) {
    if ($opt->{create_user}) {
      $new_user = 1;
    }
    else {
      $Scratch->{ui_error} = errmsg("attempt to su to non-existent user %s", $user);
      return undef;
    }
  }

  my $rand  = random_string();
  my $sess  = uneval_it($Session);
#::logDebug("sess is $sess");
  my $sesskey  = generate_key($rand . $sess);

  open(MDIT, "> $dir/$Session->{id}")
    or die errmsg("Can't create check file for su: %s\n", $!);
  print MDIT $rand;
  close MDIT;
  $Tag->set_cookie( { name => 'MV_SU_KEY', value => $sesskey } );
  my $former = $Session->{username};

  undef $Vend::admin;
  undef $Vend::superuser;
  undef $Vend::UI_entry;

  Vend::Session::init_session();
  $Session = $Vend::Session;

  if ($new_user) {
    # pass on any non-su options to userdb tag
    my $newopt = { %$opt };
    delete @{$newopt}{qw( admin exit create_user )};
    $newopt->{username} = $user;
    my $result = $Tag->userdb('new_account', $newopt);
    unless ($result) {
      my $error = errmsg("Failed to create new user '%s' in su tag", $user);
      logError($error);
      $Scratch->{ui_error} = $error;
      return undef;
    }
    $Session->{su} = $sess;
  }
  else {
    $Vend::username = $Session->{username} = $user;
    $Vend::admin    = $Session->{admin}    = $going_to_admin;
    $Session->{logged_in} = 1;
    $Session->{su} = $sess;
    $Tag->userdb('load');
  }

  ## Reconnect session variables
  Vend::Interpolate::init_calc;

  my $dest = $Tag->if_mm('logged_in') ? 'admin user' : 'regular user';
  logError(
    "superuser %s switched user to %s %s",
    $former,
    $dest,
    $Session->{username},
    );
  return 1;
}
else {
  ::logError("unknown su operation: " . uneval_it($opt));
  return undef;
}
}
EOR

SEE ALSO


Name

substitute_file

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes
content
begin
end
newline
scratch
greedy
replace
case
global
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

substitute_file is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/substitute_file.coretag
Lines: 116


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: substitute_file.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag substitute_file Order      file
UserTag substitute_file addAttr
UserTag substitute_file hasEndTag
UserTag substitute_file Version    $Revision: 1.4 $
UserTag substitute_file Routine    <<EOR
## This is a stupid thing to make 5.6.1 and File::Copy
## compatible with Safe
require File::Copy;
package File::Copy;
require File::Basename;
import File::Basename 'basename';
package Vend::Interpolate;
sub {
my ($file, $opt, $replace) = @_;
my $die = sub {
  my @args = @_;
  $::Scratch->{ui_failure} = errmsg(@args);
  return undef;
};

return $die->("substitute_file - %s: file does not exist", $file)
  if ! -f $file;
return $die->("substitute_file - %s: file not writeable", $file)
  if ! -w $file;

if($opt->{content}) {
  $opt->{begin} = '<!--+\s*begin\s+content\s*--+>';
  $opt->{end} = '<!--+\s*end\s+content\s*--+>';
  $opt->{newline} = 1 if ! defined $opt->{newline};
}

if($opt->{scratch}) {
  $opt->{begin} = '\[(?:tmp|seti?)\s*' . $opt->{scratch} . '\]';
  $opt->{end} = '\[/(?:tmp|seti?)\]';
  $opt->{greedy} = 0 if ! defined $opt->{greedy};
  $opt->{newline} = 1 if ! defined $opt->{newline};
}

if (! length($opt->{begin}) or ! length($opt->{end})) {
  return $die->("missing begin or end marker");
}

my $bak = POSIX::tmpnam();
File::Copy::copy($file, $bak)
  or return $die->(
        "substitute_file - %s: unable to backup to %s",
        $file, $bak,
        );
my $data = Vend::Util::readfile($file);
return $die->("substitute_file - %s: file has no data", $file)
  unless length $data;

my $exist;
if(defined $opt->{greedy} and ! Vend::Util::is_yes($opt->{greedy}) ) {
  $exist = $opt->{newline} ? '[\s\S]*?' : '.*?';
}
else {
  $exist = $opt->{newline} ? '[\s\S]*' : '.*';
}

my $begin = $opt->{begin};
my $end = $opt->{end};
my $subbed;

my $sub = sub {
    my ($begin, $replace, $end) = @_;
    return $replace if $opt->{replace};
    return $begin . $replace . $end;
};

if($opt->{case} and $opt->{global}) {
  $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ge;
}
elsif($opt->{global}) {
  $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ige;
}
elsif($opt->{case}) {
  $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}e;
}
else {
  $subbed = $data =~ s{($begin)$exist($end)}{$sub->($1, $replace, $2)}ie;
}

if( $subbed ) {
  open(SUBFILE, ">$file")
    or return $die->(
          "substitute_file: cannot write %s, backup in %s",
          $file, $bak,
          );
  print SUBFILE $data
    or return $die->(
          "substitute_file: error writing %s, backup in %s",
          $file, $bak,
          );
  close SUBFILE
    or return $die->(
          "substitute_file: error closing %s, backup in %s",
          $file, $bak,
          );
  unlink $bak;
}
else {
  unlink $bak;
  return 0;
}
}
EOR

SEE ALSO


Name

subtotal — display total cost of products within cart

ATTRIBUTES

AttributePos.Req.DefaultDescription
[ name | cart ] YesNomaincart name
noformatYesNoNoOutput plain number instead of formatting it according to the currency locale?
nodiscount   Whether to disregard discounts in subtotal calculation.
display  symbolDisplay currency as symbol, text or not at all?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

subtotal returns the total cost of the products within a cart.

Any discounts are applied to the total cost and the return value is formatted according to the currency settings. This can be prevented by the nodiscount and noformat attributes, respectively.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic example

[subtotal]

Example: Subtotal without discounts

[subtotal nodiscount=1]

NOTES

AVAILABILITY

subtotal is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/subtotal.coretag
Lines: 22


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: subtotal.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $

UserTag subtotal            Order        name noformat
UserTag subtotal            attrAlias    cart name
UserTag subtotal            attrAlias    space discount_space
UserTag subtotal            addAttr
UserTag subtotal            PosNumber    2
UserTag subtotal            Version      $Revision: 1.7 $
UserTag subtotal            Routine      <<EOR
sub {
my($cart, $noformat, $opt) = @_;
return currency( subtotal($cart, $opt->{discount_space}, $opt->{nodiscount}),
  $noformat, undef, $opt);
}
EOR


Name

summary

ATTRIBUTES

AttributePos.Req.DefaultDescription
amount Yes
name
reset
total
hide
format
currency
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

summary is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/summary.tag
Lines: 44


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: summary.tag,v 1.5 2007-03-30 23:40:57 pajamian Exp $

# [summary  amount=n.nn
#           name=label*
#           hide=1*
#           total=1*
#           reset=1*
#           format="%.2f"*
#           currency=1* ]
#
# Calculates column totals (if used properly. 8-\)
# 
#
UserTag summary Order     amount
UserTag summary PosNumber 1
UserTag summary addAttr
UserTag summary Version   $Revision: 1.5 $
UserTag summary Routine   <<EOF
sub {
  my ($amount, $opt) = @_;
my $summary_hash = $::Instance->{tag_summary_hash} ||= {};
my $name;
unless ($name = $opt->{name} ) {
  $name = 'ONLY0000';
  %$summary_hash = () if Vend::Util::is_yes($opt->{reset});
}
else {
  $summary_hash->{$name} = 0 if Vend::Util::is_yes($opt->{reset});
}
$summary_hash->{$name} += $amount if length $amount;
$amount = $summary_hash->{$name} if Vend::Util::is_yes($opt->{total});
return '' if $opt->{hide};
return sprintf($opt->{format}, $amount) if $opt->{format};
  return Vend::Util::currency($amount) if $opt->{currency};
  return $amount;
}
EOF

SEE ALSO


Name

tabbed-display

ATTRIBUTES

AttributePos.Req.DefaultDescription
titles
contents
interpolate   1interpolate input?
reparse   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

tabbed-display is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/tabbed_display.coretag
Lines: 211


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: tabbed_display.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag tabbed-display PosNumber     0
UserTag tabbed-display addAttr 
UserTag tabbed-display hasEndTag 
UserTag tabbed-display Interpolate 
UserTag tabbed-display NoReparse 
UserTag tabbed-display Version       $Revision: 1.6 $
UserTag tabbed-display Documentation <<EOD
=head1 NAME

tabbed-display -- DHTML tabbed display

=head1 SYNOPSIS

  [tabbed-display OPTIONS]
      [tabbed-panel The title of one]
      The contents of one
      [/tabbed-panel]
      [tabbed-panel The contents of two]
      The contents of two
      [/tabbed-panel]
  [/tabbed-display]

=head1 DESCRIPTION

The [tabbed-display] ITL tag breaks text into a tabbed DHTML display.
There are many options which can change the size of the display,
colors, and styles.

NOTE: All sizes are in pixels to allow size calculation.

=head2 OPTIONS

=over 4

=item tab_bgcolor_template

Default #xxxxxx. A template where each "x" will be broken into
descending-brightness colors. The default value will cause
the selected tab to have a color of #eeeeee, the first unselected
tab will have #dddddd, the next #cccccc, etc. To create a yellow
series, use #ffffxx.

=item tab_height

Sets the height of the title tab. Default 30.

=item tab_width

Sets the width of the title tab. Default is 100.

=item panel_height

Sets the height of the panel display. Default 600.

=item panel_width

Sets the width of the panel display. Default is 800.

=item panel_id

To account for multiple tabbed displays in a page, the second
one should have a unique ID assigned to it. Default is "mvpan".

=item tab_horiz_offset

The amount that the tab will be offset from tabs in multi-row
displays to allow view of all tabs.  Default 10.

=item tab_vert_offset

The amount that the tab will be offset from tabs in multi-row
displays to allow view of all tabs.  Default 8.

=item tab_style

The style items which will be set for the title tab portion.
Default:

  text-align:center;
  font-family: sans-serif;
  line-height:150%;
  border:2px;
  border-color:#999999;
  border-style:outset;
  border-bottom-style:none;


=item panel_style

The style items which will be set for the panel portion.  Default:

  font-family: sans-serif;
  font-size: smaller;
  border: 2px;
  border-color:#999999;
  border-style:outset;

=item panel_prepend

A string which will be prepended to every panel content.
A typical value might be "<table>", which allows table rows to
be sent as content. This is the value used in Interchange's
table editor.


=item panel_append

A string which will be appended to every panel content.
A typical value might be "</table>", which allows table rows to
be sent as content. This is the value used in Interchange's
table editor.

=item contents

If you have an array set with the value of each panel's content,
you can send it as an array reference in the contents option.
This option will also accept a null-separated string as might
be found in a form input.

If there are contents in an array, the body text of the tag
is ignored.

=item titles

If you have an array set with the value of each tab's title,
you can send it as an array reference in the C<titles> option.
This option will also accept a null-separated string as might
be found in a form input.

If the title for a panel is set in the array, the title found in the
body text of the tag is ignored.

=back

=head2 Use in embedded Perl

The tabbed_display tag can be used in embedded Perl as well.

  my @titles = ( 'Title 1', 'Title 2' );
  my @contents = ( 'Content of panel 1: foo', 'Content of 2' );

  return $Tag->tabbed_display({
      titles => \@titles,
      contents => \@contents,
      panel_width => 600,
      panel_height => 400,
      tab_bgcolor_template => '#ffffxx',
  });

=cut
EOD
UserTag tabbed-display Routine       <<EOR
sub {
my $opt = shift;
my $body = shift;
#::logDebug("opt is $opt, body is $body");
my $tit; my $cont;

if($opt->{titles}) {
  if(ref($opt->{titles}) eq 'ARRAY') {
    $tit = delete $opt->{titles};
  }
  elsif($opt->{titles} =~ /\0/) {
    $tit = [ split /\0/, delete $opt->{titles} ];
  }
  elsif($opt->{titles} =~ /\n/) {
    $tit = [ split /\n/, delete $opt->{titles} ];
  }
  else {
    $tit = [ map { $::Scratch->{$_} } split /[\s,]+/, delete $opt->{titles}];
  }
}

if($opt->{contents}) {
  if(ref($opt->{contents}) eq 'ARRAY') {
    $cont = delete $opt->{contents};
  }
  elsif($opt->{contents} =~ /\0/) {
    $cont = [ split /\0/, delete $opt->{contents} ];
  }
}

$tit ||= [];
if(! $cont) {
  $cont = [];
  while($body =~ s{
            \[tabbed[-_]panel (.*?) \]
                (.*?)
            \[/tabbed[-_]panel\]}
          {}xis
        )
  {
    push @$cont, $2;
    my $t = $1;
    if($t and $t =~ /\S/) {
      $tit->[$#$cont] ||= $t;
    }
  }
}
return Vend::Table::Editor::tabbed_display($tit, $cont, $opt);
}
EOR

SEE ALSO


Name

table-editor — table editor

ATTRIBUTES

AttributePos.Req.DefaultDescription
mv_data_table | table Yes table name
item_id | key Yes key
[ ui_data_fields | mv_data_fields | fields ] Yes No All fields. Fields to edit.
[ ui_meta_view | view ]
cgi
ui_multi_key
item_id_left
ui_sequence_edit
notable
ui_clone_id | clone clone existing record
ui_profile | profile form profile
all_opts
save_meta
no_meta None Turns off meta editor link.
across
cell_span
default_ref
append
check
class
database
hidden None hidden form variables
default None default values
disabled
error
extra
field
filter
form
height
help inline help
help_url
label
wid_href
lookup
lookup_query
meta
js_check
maxlength
options
outboard
override
passed
pre_filter
prepend
template
widget
widget_class HTML class for all widgets
width
colspan
blabel
elabel
hidden_all
next_text OK Label for "OK" button.
cancel_text Cancel Label for "Cancel" button.
back_text Back Label for "Back" button.
no_top None Whether to hide buttons at the top or not.
ok_button_style font-weight: bold; width: 40px; text-align: center HTML style attribute for "OK" button.
wizard
nosave
action_click
wizard_next
wizard_cancel
mv_cancelpage
mv_prevpage
output_map
no_table_meta
tabbed
auto_secure
keep_errors
ui_profile_success
mv_failpage
orig_cancel_text
orig_back_text
action
message_label
all_errors
color_fail
[ ui_display_only | email_fields ]
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

table-editor is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/table_editor.coretag
Lines: 30


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: table_editor.coretag,v 1.18 2007-03-30 23:40:54 pajamian Exp $

UserTag table-editor Order          mv_data_table item_id
UserTag table-editor addAttr
UserTag table-editor AttrAlias      clone ui_clone_id
UserTag table-editor AttrAlias      table mv_data_table
UserTag table-editor AttrAlias      fields ui_data_fields
UserTag table-editor AttrAlias      mv_data_fields ui_data_fields
UserTag table-editor AttrAlias      key   item_id
UserTag table-editor AttrAlias      view  ui_meta_view
UserTag table-editor AttrAlias      profile ui_profile
UserTag table-editor AttrAlias      email_fields ui_display_only
UserTag table-editor hasEndTag
UserTag table-editor Version        $Revision: 1.18 $
UserTag table-editor MapRoutine     Vend::Table::Editor::editor
UserTag table-editor Documentation  <<EOD
Hint:   table_editor may not work for tables where the primary key
field is named 'id'.

You can change this behavior by just removing this line from ICDIR/etc/varnames:

    mv_session_id            id
EOD

Source: lib/Vend/Table/Editor.pm
Lines: 2594

sub editor {

my ($table, $key, $opt, $overall_template) = @_;
show_times("begin table editor call item_id=$key") if $Global::ShowTimes;

#::logDebug("overall_template=$overall_template\nin=$opt->{overall_template}");
use vars qw/$Tag/;

editor_init($opt);

my @messages;
my @errors;
my $pass_return_to;
my $hidden = $opt->{hidden} ||= {};

#::logDebug("key at beginning: $key");
$opt->{mv_data_table} = $table if $table;
$opt->{table}      = $opt->{mv_data_table};
$opt->{ui_meta_view}  ||= $CGI->{ui_meta_view} if $opt->{cgi};

$key ||= $opt->{item_id};

if($opt->{cgi}) {
  $key ||= $CGI->{item_id};
  unless($opt->{ui_multi_key} = $CGI->{ui_multi_key}) {
    $opt->{item_id_left} ||= $CGI::values{item_id_left};
    $opt->{ui_sequence_edit} ||= $CGI::values{ui_sequence_edit};
  }
}

if($opt->{ui_sequence_edit} and ! $opt->{ui_multi_key}) {
  delete $opt->{ui_sequence_edit};
  my $left = delete $opt->{item_id_left}; 

  if(! $key) {
#::logDebug("No key, getting from $left");
    if($left =~ s/(.*?)[\0,]// ) {
      $key = $opt->{item_id} = $1;
      $hidden->{item_id_left} = $left;
      $hidden->{ui_sequence_edit} = 1;
    }
    elsif($left) {
      $key = $opt->{item_id} = $left;
    }
#::logDebug("No key, left now $left");
  }
  elsif($left) {
#::logDebug("Key, leaving left $left");
    $hidden->{item_id_left} = $left;
    $hidden->{ui_sequence_edit} = 1;
  }
}

$opt->{item_id} = $key;

$pass_return_to = save_cgi() if $hidden->{ui_sequence_edit};

my $data;
my $exists;
my $db;
my $multikey;

## Try and sneak a peek at the data so we can determine views and
## maybe some other stuff -- we definitely need table/key or a 
## clone id
unless($opt->{notable}) {
  # From Vend::Data
  my $tab = $table || $opt->{mv_data_table} || $CGI->{mv_data_table};
  my $key = $opt->{item_id} || $CGI->{item_id};
  $db = database_exists_ref($tab);

  if($db) {
    $multikey = $db->config('COMPOSITE_KEY');
    if($multikey and $key !~ /\0/) {
      $key =~ s/-_NULL_-/\0/g;
    }
    if($opt->{ui_clone_id} and $db->record_exists($opt->{ui_clone_id})) {
      $data = $db->row_hash($opt->{ui_clone_id});
    }
    elsif ($key and $db->record_exists($key)) {
      $data = $db->row_hash($key);
      $exists = 1;
    }
    
    if(! $exists and $multikey) {
      $data = {};
      eval { 
        my @inits = split /\0/, $key;
        for(@{$db->config('_Key_columns')}) {
          $data->{$_} = shift @inits;
        }
      };
    }
  }
}

my $regin = $opt->{all_opts} ? 1 : 0;

resolve_options($opt, undef, $data);

$Trailer = $opt->{xhtml} ? '/' : '';
if($regin) {
  ## Must reset these in case they get set from all_opts.
  $hidden = $opt->{hidden};
}
$overall_template = $opt->{overall_template}
  if $opt->{overall_template};

$table = $opt->{table};
$key = $opt->{item_id};
if($opt->{save_meta}) {
  $::Scratch->{$opt->{save_meta}} = uneval($opt);
}
#::logDebug("key after resolve_options: $key");

#::logDebug("cell_span=$opt->{cell_span}");
#### This code is also in resolve_options routine, change there too!
my $rowdiv         = $opt->{across}    || 1;
my $cells_per_span = $opt->{cell_span} || 2;
my $rowcount = 0;
my $span = $rowdiv * $cells_per_span;
#### 

my $oddspan = $span - 1;
my $def = $opt->{default_ref} || $::Values;

my $append       = $opt->{append};
my $check        = $opt->{check};
my $class        = $opt->{class} || {};
my $database     = $opt->{database};
my $default      = $opt->{default};
my $disabled     = $opt->{disabled};
my $error        = $opt->{error};
my $extra        = $opt->{extra};
my $field        = $opt->{field};
my $filter       = $opt->{filter};
my $form       = $opt->{form};
my $height       = $opt->{height};
my $help         = $opt->{help};
my $help_url     = $opt->{help_url};
my $id           = $opt->{id};
my $label        = $opt->{label};
my $wid_href     = $opt->{wid_href};
my $lookup       = $opt->{lookup};
my $lookup_query = $opt->{lookup_query};
my $meta         = $opt->{meta};
my $js_check     = $opt->{js_check};
my $maxlength    = $opt->{maxlength};
my $opts         = $opt->{opts};
my $options      = $opt->{options};
my $outboard     = $opt->{outboard};
my $override     = $opt->{override};
my $passed       = $opt->{passed};
my $pre_filter   = $opt->{pre_filter};
my $prepend      = $opt->{prepend};
my $template     = $opt->{template};
my $widget       = $opt->{widget};
my $width        = $opt->{width};
my $colspan      = $opt->{colspan} || {};

my $blabel = $opt->{blabel};
my $elabel = $opt->{elabel};
my $mlabel = '';
my $hidden_all = $opt->{hidden_all} ||= {};
#::logDebug("hidden_all=" . ::uneval($hidden_all));
my $ntext;
my $btext;
my $ctext;

if($pass_return_to) {
  delete $::Scratch->{$opt->{next_text}};
}
elsif (! $opt->{wizard} and ! $opt->{nosave}) {
  $ntext = $Tag->return_to('click', 1);
  $ctext = $ntext . "\nmv_todo=back";
}
else {
  if($opt->{action_click}) {
    $ntext = <<EOF;
mv_todo=$opt->{wizard_next}
ui_wizard_action=Next
mv_click=$opt->{action_click}
EOF
  }
  else {
    $ntext = <<EOF;
mv_todo=$opt->{wizard_next}
ui_wizard_action=Next
mv_click=ui_override_next
EOF
  }
  $::Scratch->{$opt->{next_text}} = $ntext;

  my $hidgo = $opt->{mv_cancelpage} || $opt->{hidden}{ui_return_to} || $CGI->{return_to};
  $hidgo =~ s/\0.*//s;
  $ctext = $::Scratch->{$opt->{cancel_text}} = <<EOF;
mv_form_profile=
ui_wizard_action=Cancel
mv_nextpage=$hidgo
mv_todo=$opt->{wizard_cancel}
EOF
  if($opt->{mv_prevpage}) {
    $btext = $::Scratch->{$opt->{back_text}} = <<EOF;
mv_form_profile=
ui_wizard_action=Back
mv_nextpage=$opt->{mv_prevpage}
mv_todo=$opt->{wizard_next}
EOF
  }
  else {
    delete $opt->{back_text};
  }
}

for(qw/next_text back_text cancel_text/) {
  $opt->{"orig_$_"} = $opt->{$_};
}

$::Scratch->{$opt->{next_text}}   = $ntext if $ntext;
$::Scratch->{$opt->{cancel_text}} = $ctext if $ctext;
$::Scratch->{$opt->{back_text}}   = $btext if $btext;

$opt->{next_text} = HTML::Entities::encode($opt->{next_text}, $ESCAPE_CHARS::std);
$opt->{back_text} = HTML::Entities::encode($opt->{back_text}, $ESCAPE_CHARS::std);
$opt->{cancel_text} = HTML::Entities::encode($opt->{cancel_text}, $ESCAPE_CHARS::std);

$::Scratch->{$opt->{next_text}}   = $ntext if $ntext;
$::Scratch->{$opt->{cancel_text}} = $ctext if $ctext;
$::Scratch->{$opt->{back_text}}   = $btext if $btext;

undef $opt->{auto_secure} if $opt->{cgi};

### Build the error checking
my $error_show_var = 1;
my $have_errors;
if($opt->{ui_profile} or $check) {
  $Tag->error( { all => 1 } )
    unless $CGI->{mv_form_profile} or $opt->{keep_errors};
  my $prof = $opt->{ui_profile} || "&update=yes\n";
  if ($prof =~ s/^\*//) {
    # special notation ui_profile="*whatever" means
    # use automatic checklist-related profile
    my $name = $prof;
    $prof = $::Scratch->{"profile_$name"} || "&update=yes\n";
    if ($prof) {
      $prof =~ s/^\s*(\w+)[\s=]+required\b/$1=mandatory/mg;
      for (grep /\S/, split /\n/, $prof) {
        if (/^\s*(\w+)\s*=(.+)$/) {
          my $k = $1; my $v = $2;
          $v =~ s/\s+$//;
          $v =~ s/^\s+//;
          $error->{$k} = 1;
          $error_show_var = 0 if $v =~ /\S /;
        }
      }
      $prof = '&calc delete $Values->{step_'
          . $name
          . "}; return 1\n"
          . $prof;
      ## Un-confuse vi }
      $opt->{ui_profile_success} = "&set=step_$name 1";
    }
  }
  my $success = $opt->{ui_profile_success};
  # make sure profile so far ends with a newline so we can add more
  $prof .= "\n" unless $prof =~ /\n\s*\z/;
  if(ref $check) {
    while ( my($k, $v) = each %$check ) {
      next unless length $v;
      $error->{$k} = 1;
      $v =~ s/\s+$//;
      $v =~ s/^\s+//;
      $v =~ s/\s+$//mg;
      $v =~ s/^\s+//mg;
      $v =~ s/^required\b/mandatory/mg;
      unless ($v =~ /^\&/m) {
        $error_show_var = 0 if $v =~ /\S /;
        $v =~ s/^/$k=/mg;
        $v =~ s/\n/\n&and\n/g;
      }
      $prof .= "$v\n";
    }
  }
  elsif ($check) {
    for (@_ = grep /\S/, split /[\s,]+/, $check) {
      $error->{$_} = 1;
      $prof .= "$_=mandatory\n";
    }
  }

  ## Enable individual widget checks
  $::Scratch->{mv_individual_profile} = 1;

  ## Call the profile in the form
  $opt->{hidden}{mv_form_profile} = 'ui_profile';
  my $fail = $opt->{mv_failpage} || $Global::Variable->{MV_PAGE};

  # watch out for early interpolation here!
  $::Scratch->{ui_profile} = <<EOF;
[perl]
#Debug("cancel='$opt->{orig_cancel_text}' back='$opt->{orig_back_text}' click=\$CGI->{mv_click}");
my \@clicks = split /\\0/, \$CGI->{mv_click};

for( qq{$opt->{orig_cancel_text}}, qq{$opt->{orig_back_text}}) {
#Debug("compare is '\$_'");
  next unless \$_;
  my \$cancel = \$_;
  for(\@clicks) {
#Debug("click is '\$_'");
    return if \$_ eq \$cancel; 
  }
}
# the following should already be interpolated by the table-editor tag
# before going into scratch ui_profile
return <<'EOP';
$prof
&fail=$fail
&fatal=1
$success
mv_form_profile=mandatory
&set=mv_todo $opt->{action}
EOP
[/perl]
EOF
  $opt->{blabel} = '<span style="font-weight: normal">';
  $opt->{elabel} = '</span>';
  $mlabel = ($opt->{message_label} || '&nbsp;&nbsp;&nbsp;'
. errmsg('<b>Bold</b> fields are required'));
  $have_errors = $Tag->error( {
                all => 1,
                show_var => $error_show_var,
                show_error => 1,
                joiner => "<br$Vend::Xtrailer>",
                keep => 1}
                );
  if($opt->{all_errors} and $have_errors) {
    my $title = $opt->{all_errors_title} || errmsg('Errors');
    my $style = $opt->{all_errors_style} || "color: $opt->{color_fail}";
    my %hash = (
      title => $opt->{all_errors_title} || errmsg('Errors'),
      style => $opt->{all_errors_style} || "color: $opt->{color_fail}",
      errors => $have_errors,
    );
    my $tpl = $opt->{all_errors_template} || <<EOF;
<p>{TITLE}:
<blockquote style="{STYLE}">{ERRORS}</blockquote>
</p>
EOF
    $mlabel .= tag_attr_list($tpl, \%hash, 'uc');

  }
}

SEE ALSO


Name

table-organize — automatically organize table cells into rows or columns

ATTRIBUTES

AttributePos.Req.DefaultDescription
cols | columns Yes 2 Number of columns.
rows Optional number of rows. Implies "table" parameter.
columnize Display cells in "newspaper" column order. (Rotate the table — instead of filling rows, fill columns).
min_rows On small result sets, it can be ugly to build more than the necessary number of columns. This option will guarantee a minimum number of rows — columns will change as numbers change. Formula: $num_cells % $opt->{min_rows}.
cells
embed Allows embedding other table elements within tables you want to organize. See more in the section called “DESCRIPTION” and examples.
limit Maximum number of cells to use. Truncates extra cells silently.
table If specified, causes a surrounding HTML <table> </table> to be generated with the specified attributes.
caption Table <caption> container text, if any. (Can be an array).
tr Attributes for table rows. (Can be an array).
td Attributes for table cells. (Can be an array).
pretty Adds newline and TAB characters to provide some reasonable indenting in the HTML source.
filler &nbsp; (non-breaking space) Content to automatically place in empty, "filler" cells. It could be important to provide at least minimal content in there since some browsers do not display empty cells.
font Attributes for HTML <font> inside table cells, if any.
joiner \n\t\t if pretty is specified, none otherwise. Element to use in joining cells. This is mostly used for visual layout in HTML source.
interpolate   1interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

table-organize takes an bunch of table cells and organizes them into rows based on the specified number of columns.

If the number of cells is not on an even modulus of the number of columns, then "filler" cells will be included to keep table structure correct.

Attributes tr, td and caption can be specified as an array (with indexes); if they are, they will alternate according to the modulus. The td array size should always equal the number of columns; if it is bigger, then trailing elements are ignored. If it is smaller, the attribute is ignored altogether.

If you will want to embed other tables inside the table you want to organize, you'll run into an interesting problem; table-organize won't know whether <td>s belong to the table you want to arrange or to the "subtable" that should be left intact. To solve this problem, we resort to differentiating them by lowercase <td> and uppercase <TD>. See more in the section called “EXAMPLES”.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Advanced table-organize example

To produce a table that alternates between two row background colors and specifies custom alignment for the three columns, use:

<table>
  [table-organize
    cols=3
    pretty=1
    tr.0='bgcolor="#EEEEEE"'
    tr.1='bgcolor="#FFFFFF"'
    td.0='align=right'
    td.1='align=center'
    td.2='align=left'
  ]
  [loop list="1 2 3 1a 2a 3a 1b"] <td> [loop-code] </td> [/loop]
  [/table-organize]
</table>

(In the above example, loop tag is used to produce example data for the table cells.) The final result produced will look like this:

<table>
  <tr bgcolor="#EEEEEE">
    <td align=right>1</td>
    <td align=center>2</td>
    <td align=left>3</td>
  </tr>
  <tr bgcolor="#FFFFFF">
    <td align=right>1a</td>
    <td align=center>2a</td>
    <td align=left>3a</td>
  </tr>
  <tr bgcolor="#EEEEEE">
    <td align=right>1b</td>
    <td align=center>&nbsp;</td>
    <td align=left>&nbsp;</td>
  </tr>
<table>

If you also provide the columnize=1 attribute, the result will be a "rotated" table:

<table>
  <tr bgcolor="#EEEEEE">
    <td align=right>1</td>
    <td align=center>1a</td>
    <td align=left>1b</td>
  </tr>
  <tr bgcolor="#FFFFFF">
    <td align=right>2</td>
    <td align=center>2a</td>
    <td align=left>&nbsp;</td>
  </tr>
  <tr bgcolor="#EEEEEE">
    <td align=right>3</td>
    <td align=center>3a</td>
    <td align=left>&nbsp;</td>
  </tr>
</table>

Example: Embedding tables

To embed tables, make sure the table you want to organize uses lowercase <td> and set attribute embed=lc. To invert the meaning and make uppercase <TD>s arranged (ignoring lower- or mixed-case cells), set the embed attribute to any other true value except lc (embed=uc will work well).

<table>
  [table-organize embed=lc]
  <td>
    <TABLE>
    <TR>
    <TD>something embedded</TD>
    </TR>
    </TABLE>
  </td>
  [/table-organize]
</table>

or

<table>
  [table-organize embed=uc]
  <TD>
    <table>
    <tr>
    <td>something</td>
    </tr>
    </table>
  </TD>
  [/table-organize]
</table>

NOTES

AVAILABILITY

table-organize is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/table_organize.tag
Lines: 185


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: table_organize.tag,v 1.11 2007-11-05 20:15:27 docelic Exp $

UserTag table-organize Order         cols
UserTag table-organize attrAlias     columns cols
UserTag table-organize Interpolate
UserTag table-organize addAttr
UserTag table-organize hasEndTag
UserTag table-organize Version       $Revision: 1.11 $
UserTag table-organize Routine <<EOR
sub {
my ($cols, $opt, $body) = @_;
$cols = int($cols) || 2;
$body =~ s/(.*?)(<td)\b/$2/is
  or return;
my $out = $1;
$body =~ s:(</td>)(?!.*</td>)(.*):$1:is;
my $postamble = $2;

my @cells;
if($opt->{cells} and ref($opt->{cells}) eq 'ARRAY') {
  @cells = @{$opt->{cells}};
}
elsif($opt->{embed}) {
  if($opt->{embed} eq 'lc') {
    push @cells, $1 while $body =~ s:(<td\b.*?</td>)::s;
  }
  else {
    push @cells, $1 while $body =~ s:(<TD\b.*?</TD>)::s;
  }
}
else {
  push @cells, $1 while $body =~ s:(<td\b.*?</td>)::is;
}

while ($opt->{min_rows} and ($opt->{min_rows} * ($cols - 1)) > scalar(@cells) ) {
  $cols--;
  last if $cols == 1;
}

if(int($opt->{limit}) and $opt->{limit} < scalar(@cells) ) {
  splice(@cells, $opt->{limit});
}

for(qw/ table/) {
  $opt->{$_} = defined $opt->{$_} ? " $opt->{$_}" : '';
}

my @td;

if(! $opt->{td}) {
  @td = '' x $cols;
}
elsif (ref $opt->{td} ) {
  @td = @{$opt->{td}};
  push @td, '' while scalar(@td) < $cols;
}
else {
  @td = (" $opt->{td}") x $cols;
}

my %attr;
for(qw/caption tr pre post/) {
  if( ! $opt->{$_} ) {
    #do nothing
  }
  elsif (ref $opt->{$_}) {
    $attr{$_} = $opt->{$_};
  }
  else {
    $attr{$_} = [$opt->{$_}];
  }
}

my $pretty = $opt->{pretty};

#$opt->{td} =~ s/^(\S)/ $1/;
#$opt->{tr} =~ s/^(\S)/ $1/;

my @rest;
my $rows;

my $rmod;
my $tmod = 0;
my $total_mod;

$opt->{filler} = '&nbsp;' if ! defined $opt->{filler};

my $td_beg;
my $td_end;
if($opt->{font}) {
  $td_beg = qq{<FONT $opt->{font}>};
  $td_end = qq{</FONT>};
}

if($rows = int($opt->{rows}) ) {
  $total_mod = $rows * $cols;
  @rest = splice(@cells, $total_mod)
    if $total_mod < @cells;
  $opt->{table} = ' ' if ! $opt->{table};
}

my $joiner = $opt->{joiner} || ($pretty ? "\n\t\t" : "");
while(@cells) {
  if ($opt->{columnize}) {
    my $cell_count = scalar @cells;
    my $row_count_ceil = POSIX::ceil($cell_count / $cols);
    my $row_count_floor = int($cell_count / $cols);
    my $remainder = $cell_count % $cols;
    my @tmp = splice(@cells, 0);
    my $index;
    for (my $r = 0; $r < $row_count_ceil; $r++) {
      for (my $c = 0; $c < $cols; $c++) {
        if ($c >= $remainder + 1) {
          $index = $r + $row_count_floor * $c + $remainder;
        }
        else {
          $index = $r + $row_count_ceil * $c;
        }
        push @cells, $tmp[$index];
        last if $r + 1 == $row_count_ceil and $c + 1 == $remainder;
      }
    }
  }

  while (scalar(@cells) % $cols) {
    push @cells, "<td>$opt->{filler}</td>";
  }

  #$out .= "<!-- starting table tmod=$tmod -->";
  if($opt->{table}) {
    $out .= "<table$opt->{table}>";
    $out .= "\n" if $pretty;
    if($opt->{caption}) {
      my $idx = $tmod % scalar(@{$attr{caption}});
      #$out .= "<!-- caption index $idx -->";
      $out .= "\n" if $pretty;
      $out .= "<caption>" . $attr{caption}[$idx] . "</caption>";
      $out .= "\n" if $pretty;
    }
  }
  $rmod = 0;
  while(@cells) {
    $out .= "\t" if $pretty;
    $out .= "<tr";
    if($opt->{tr}) {
      my $idx = $rmod % scalar(@{$attr{tr}});
      $out .= " " . $attr{tr}[$idx];
    }
    $out .= ">";
    $out .= "\n\t\t" if $pretty;
    my @op =  splice (@cells, 0, $cols);
    if($opt->{td}) {
      for ( my $i = 0; $i < $cols; $i++) {
        $op[$i] =~ s/(<td)/$1 $td[$i]/i;
      }
    }
    @op = map { s/>/>$td_beg/; $_ }       @op  if $td_beg;
    @op = map { s/(<[^<]+)$/$td_end$1/; $_ } @op  if $td_end;

    $out .= join($joiner, @op);
    $out .= "\n\t" if $pretty;
    $out .= "</tr>";
    $out .= "\n" if $pretty;
    $rmod++;
  }
  if($opt->{table}) {
    $out .= "</table>";
    $out .= "\n" if $pretty;
  }
  if(@rest) {
    my $num = $total_mod < scalar(@rest) ? $total_mod : scalar(@rest);
    @cells = splice(@rest, 0, $num);
  }
  $tmod++;
}
return $out . $postamble;
}
EOR

SEE ALSO


Name

tag

ATTRIBUTES

AttributePos.Req.DefaultDescription
op Yes
arg | description Yes
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

tag is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/tag.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: tag.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag tag                 Order        op arg
UserTag tag                 addAttr
UserTag tag                 attrAlias    description arg
UserTag tag                 hasEndTag
UserTag tag                 PosNumber    2
UserTag tag                 Version      $Revision: 1.4 $
UserTag tag                 MapRoutine   Vend::Interpolate::do_tag

Source: lib/Vend/Interpolate.pm
Lines: 2149

sub do_tag {
my $op = uc $_[0];
#::logDebug("tag op: op=$op opt=" . uneval(\@_));
return $_[3] if !  defined $Tag_op_map{$op};
shift;
#::logDebug("tag args now: op=$op opt=" . uneval(\@_));
return &{$Tag_op_map{$op}}(@_);
}


Name

time — display formatted date, similar to strftime POSIX function

ATTRIBUTES

AttributePos.Req.DefaultDescription
locale Yes Format date and time according to the named locale (assuming that the locale is available on your system).
tz Specify the timezone. Note that the first alphabetical string is the zone name to be used when not under daylight-savings time. The following digit is the number of hours displacement from GMT, and the second alphabetical string is the zone name when in daylight savings time. (This may not work on all operating systems.)
time Specify the date/time manually, instead of letting Interchange call Perl time() function.
sortable 0 Display date in "sortable" format? Sortable format is predefined format= string that displays the date in " YYYY/ MM/ DD
adjust For the display purpose, adjust the time for the specified value. In most cases, the value will represent hours. If the value ends in 0 and contains three or more digits, then it is assumed to be in timezone format. The offset can also be specified using interval format. See the section called “EXAMPLES” for clarification.
hours 0 Force the adjust= argument to always represent hours.
format | fmt POSIX strftime format specifier; see time glossary entry.
gmt 0 Display GMT (UTC) time?
zerofix 0 Strip leading zeros from numbers?
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag displays date and time values, formatted similar to the strftime(3) function. The date can be specified with the time= parameter and adjusted with the adjust= parameter. The current date and time is the assumed default.

See time glossary entry for a list and description of format specifiers.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic example

[time]%am %B %d, %Y[/time]

This tag would return a date such as Sunday, September 4, 2005.


Example: Specifying adjust= attribute in number of hours

[time adjust="-3"]%c[/time]

With a base date of Mon 01 Jan 2001 11:29:03 AM EST, this tag would display Mon 01 Jan 2001 08:29:03 AM EST.


Example: ISO 8601 date suitable for MySQL datetime and PostgreSQL timestamp fields

[time]%Y-%m-%d %H:%M:%S[/time]

Example: Convert epoch value to ISO 8601 date

Time values as seconds since epoch can be converted by passing the value as time attribute.

[time time="1261306319"]%Y-%m-%d %H:%M:%S[/time]

Example: Specifying adjust= attribute in timezone format

[time]%c[/time]
[time adjust="-330"]%c[/time]
[time adjust="-300"]%c[/time]

With a base date of Mon 01 Jan 2001 11:29:03 AM EST, this tag would display second date offset by 3 hours and 30 minutes, and the third date offset by 3 hours.

Mon 01 Jan 2001 11:29:03 AM EST
Mon 01 Jan 2001 07:59:03 AM EST
Mon 01 Jan 2001 08:29:03 AM EST

Example: Specifying adjust= attribute in interval format

[time adjust="2 days"]%c[/time]

Example: Displaying locale-specific date

[time locale=en_US]%B %d, %Y[/time]
[time locale=fr_FR]%B %d, %Y[/time]

would result in

January 01, 2001
janvier 01, 2001

Example: Specifying tz= attribute

[time tz=GMT0]
[time tz=CST6CDT]
[time tz=PST8PDT]

would result in

Mon 01 Jan 2001 04:43:02 PM GMT
Mon 01 Jan 2001 10:43:02 AM CST
Mon 01 Jan 2001 08:43:02 AM PST

NOTES

In all adjust= manipulations, the offset will just be applied at the end (the timezone will not be changed for the invocation of time function). This means you shouldn't use any format that uses timezone information. For the timezone to enter calculations, either use tz=, or manage the calculation yourself.

The timezone can be set globally for the Interchange installation by defining the TZ environment variable and restarting Interchange.

AVAILABILITY

time is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/time.coretag
Lines: 15


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: time.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag time                Order        locale
UserTag time                addAttr
UserTag time                hasEndTag
UserTag time                PosNumber    1
UserTag time                Version      $Revision: 1.4 $
UserTag time                MapRoutine   Vend::Interpolate::mvtime

Source: lib/Vend/Interpolate.pm
Lines: 2120

sub mvtime {
my ($locale, $opt, $fmt) = @_;
my $current;

if($locale) {
  $current = POSIX::setlocale(&POSIX::LC_TIME);
  POSIX::setlocale(&POSIX::LC_TIME, $locale);
}

local($ENV{TZ}) = $opt->{tz} if $opt->{tz};

my $now = $opt->{time} || time();
$fmt = '%Y%m%d' if $opt->{sortable};

if($opt->{adjust} || $opt->{hours}) {
  my $adjust = $opt->{adjust};
  if ($opt->{hours}) {
    $adjust ||= $opt->{hours};
    $adjust .= ' hours';
  }

  elsif ($adjust !~ /[A-Za-z]/) {
    $adjust =~ s/(?<=\d)(\d[05])// and $adjust += $1 / 60;
    $adjust .= ' hours';
  }

  $now = adjust_time($adjust, $now, $opt->{compensate_dst});
}

$fmt ||= $opt->{format} || $opt->{fmt} || '%c';
  my $out = $opt->{gmt} ? ( POSIX::strftime($fmt, gmtime($now)    ))
                        : ( POSIX::strftime($fmt, localtime($now) ));
$out =~ s/\b0(\d)\b/$1/g if $opt->{zerofix};
POSIX::setlocale(&POSIX::LC_TIME, $current) if defined $current;
return $out;
}


Name

timed-build — save output of Interchange interpolation to named file (cache pages)

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes Cache filename.
if
scan
login
auto
new
force
minutes 60 Number of minutes the cache file is kept. A value of 0 means infinitely.
period
umask
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

timed-build is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/timed_build.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: timed_build.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag timed-build         Order        file
UserTag timed-build         addAttr
UserTag timed-build         Gobble
UserTag timed-build         hasEndTag
UserTag timed-build         PosNumber    1
UserTag timed-build         Version      $Revision: 1.4 $
UserTag timed-build         MapRoutine   Vend::Interpolate::timed_build

Source: lib/Vend/Interpolate.pm
Lines: 5369

sub timed_build {
  my $file = shift;
  my $opt = shift;
my $abort;

if ($Vend::LockedOut) {
  $abort = 1;
  delete $opt->{new};
}
elsif (defined $opt->{if}) {
  $abort = 1 if ! $opt->{if}; 
}

my $saved_file;
if($opt->{scan}) {
  $saved_file = $Vend::ScanPassed;
  $abort = 1 if ! $saved_file || $file =~ m:MM=:;
}

$opt->{login} = 1 if $opt->{auto};

my $save_scratch;
if($opt->{new} and $Vend::new_session and !$Vend::Session->{logged_in}) {
#::logDebug("we are new");
  $save_scratch = $::Scratch;
  $Vend::Cookie = 1;
  $Vend::Session->{scratch} = { %{$Vend::Cfg->{ScratchDefault}}, mv_no_session_id \
 => 1, mv_no_count => 1, mv_force_cache => 1 };
  
}
else {
  return Vend::Interpolate::interpolate_html($_[0])
    if $abort
    or ( ! $opt->{force}
        and
        (   ! $Vend::Cookie
          or ! $opt->{login} && $Vend::Session->{logged_in}
        )
      );
}

local ($Scratch->{mv_no_session_id});
$Scratch->{mv_no_session_id} = 1;

if($opt->{auto}) {
  $opt->{minutes} = 60 unless defined $opt->{minutes};
  my $dir = "$Vend::Cfg->{ScratchDir}/auto-timed";
  unless (allowed_file($dir)) {
    log_file_violation($dir, 'timed_build');
    return;
  }
  if(! -d $dir) {
    require File::Path;
    File::Path::mkpath($dir);
  }
  $file = "$dir/" . generate_key(@_);
}

my $secs;
CHECKDIR: {
  last CHECKDIR if Vend::File::file_name_is_absolute($file);
  last CHECKDIR if $file and $file !~ m:/:;
  my $dir;
  if ($file) {
    $dir = '.';
  }
  else {
    $dir = 'timed';
    $file = $saved_file || $Vend::Flypart || $Global::Variable->{MV_PAGE};
#::logDebug("static=$file");
    if($saved_file) {
      $file = $saved_file;
      $file =~ s:^scan/::;
      $file = generate_key($file);
      $file = "scan/$file";
    }
    else {
      $saved_file = $file = ($Vend::Flypart || $Global::Variable->{MV_PAGE});
    }
    $file .= $Vend::Cfg->{HTMLsuffix};
  }
  $dir .= "/$1" 
    if $file =~ s:(.*)/::;
  unless (allowed_file($dir)) {
    log_file_violation($dir, 'timed_build');
    return;
  }
  if(! -d $dir) {
    require File::Path;
    File::Path::mkpath($dir);
  }
  $file = Vend::Util::catfile($dir, $file);
}

#::logDebug("saved=$saved_file");
#::logDebug("file=$file exists=" . -f $file);
if($opt->{minutes}) {
      $secs = int($opt->{minutes} * 60);
  }
elsif ($opt->{period}) {
  $secs = Vend::Config::time_to_seconds($opt->{period});
}

  $file = Vend::Util::escape_chars($file);
  if(! $opt->{auto} and ! allowed_file($file)) {
  log_file_violation($file, 'timed_build');
  return undef;
  }

  if( ! -f $file or $secs && (stat(_))[9] < (time() - $secs) ) {
      my $out = Vend::Interpolate::interpolate_html(shift);
  $opt->{umask} = '22' unless defined $opt->{umask};
      Vend::Util::writefile(">$file", $out, $opt );
  $Vend::Session->{scratch} = $save_scratch if $save_scratch;
      return $out;
  }
$Vend::Session->{scratch} = $save_scratch if $save_scratch;
return Vend::Util::readfile($file);
}

SEE ALSO


Name

timed-display

ATTRIBUTES

AttributePos.Req.DefaultDescription
start Yes Cache filename.
stop Yes Cache filename.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

timed-display is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/timed_display.tag
Lines: 77


UserTag timed-display Order start stop
UserTag timed-display HasEndTag
UserTag timed-display AddAttr 1
UserTag timed-display Routine <<EOR
sub {
my ($start, $stop, $opt, $body) = @_;

my $tv     = $opt->{tv};
my $adjust   = $opt->{adjust};
my $currtime = $tv && ($CGI->{$tv} || $Scratch->{$tv});

my $now = $Tag->convert_date({
  fmt     => '%Y%m%d%H%M',
  body   => $currtime,
  adjust => $adjust,
});
my $else = pull_else($body);

if (!$start){
  $start = $now - 1;
}
if (!$stop){
  $stop = '599900010000';#forever or at least after I die.
}

$start = $Tag->convert_date({
  fmt     => '%Y%m%d%H%M',
  body   => $start,
});
$stop = $Tag->convert_date({
  fmt     => '%Y%m%d%H%M',
  body   => $stop,
});
return $body if !$start;

if ($start <= $now and $now <= $stop){
  return $body;
}
else {
  return $else;
}
}


EOR

UserTag timed-display Documentation <<EOD

Purpose: To allow for date specific display of text or html in pages.

Usage: 

[timed-display start=2007060608 stop=2007060612]
Some text/code to display between June 06, 2007 between 8am and Noon.
[/timed-display]

For open ended display you can just specify a start date.  To start
immediately and end on a specific date you can just specify a stop
date.

The start and stop date use the convert_date tag, so you can use any
format acceptable by that tag to specify your start and stop
dates.  (See convert_date documentation for details.)

If the 'timevar' parameter is provided, instead of the current time
look first in the CGI and the Scratch variables with the provided name
for a date string to convert.  This allows you to provide a way to
test this behavior outside of the wall-clock time and see the actual
behavior at a specific time.

You can also use the 'adjust' parameter, which will pass its argument
directly on to the convert_date calls; this can be used to localize
the timezone relative to the server time.

EOD



SEE ALSO


Name

title-bar

ATTRIBUTES

AttributePos.Req.DefaultDescription
width Yes
size Yes
color Yes
interpolate   1interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: HEADERBG, HEADERTEXT

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

title-bar is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/title_bar.tag
Lines: 28


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: title_bar.tag,v 1.4 2007-03-30 23:40:57 pajamian Exp $

UserTag title-bar Order        width size color
UserTag title-bar PosNumber    3
UserTag title-bar Interpolate  1
UserTag title-bar HasEndTag    1
UserTag title-bar Version      $Revision: 1.4 $
UserTag title-bar Routine      <<EOR
sub {
my ($width, $size, $color, $text) = @_;
$width = 500 unless defined $width;
$size = 6 unless defined $size;
$color = ($::Variable->{HEADERBG} || '#444444') unless defined $color;
$color = qq{BGCOLOR="$color"} unless $color =~ /^\s*bgcolor=/i;
my $tcolor = $::Variable->{HEADERTEXT} || 'WHITE';
$text = qq{<FONT COLOR="$tcolor" SIZE="$size">$text</FONT>};
return <<EOF;
<TABLE CELLSPACING=0 CELLPADDING=6 WIDTH="$width"><TR><TD VALIGN=CENTER \
 \
 $color>$text</TD></TR></TABLE>
EOF
}
EOR

SEE ALSO


Name

tmp — temporarily set value of scratch variable, with interpolation

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Name of the temporary scratch variable.
interpolate   1interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag sets value of the named temporary scratch variable.

The variable is temporary in a way that Interchange adds its name to the list of variables to delete directly after the current page is processed and served. Except for being part of good design, temporary variables also speed up session write time in many cases.

By default, the provided value is interpolated before assignment. To not interpolate contents, use tmpn or provide interpolate=0 attribute to this tag.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

See scratch glossary entry for a complete discussion.

AVAILABILITY

tmp is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/tmp.coretag
Lines: 15


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: tmp.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag tmp                 Order        name
UserTag tmp                 hasEndTag
UserTag tmp                 Interpolate
UserTag tmp                 PosNumber    1
UserTag tmp                 Version      $Revision: 1.5 $
UserTag tmp                 MapRoutine   Vend::Interpolate::set_tmp

Source: lib/Vend/Interpolate.pm
Lines: 5250

sub set_tmp {
my($var,$val) = @_;
push @Vend::TmpScratch, $var;
  $::Scratch->{$var} = $val;
return '';
}

SEE ALSO

scratch(7ic)


Name

tmpn — temporarily set value of scratch variable, without interpolation

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Name of the temporary scratch variable.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag sets value of the named temporary scratch variable.

The variable is temporary in a way that Interchange adds its name to the list of variables to delete directly after the current page is processed and served. Except for being part of good design, temporary variables also speed up session write time in many cases.

By default, the provided value is not interpolated before assignment. To interpolate contents, use tmp or interpolate=1 attribute to this tag.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

See scratch glossary entry for a complete discussion.

AVAILABILITY

tmpn is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/tmpn.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: tmpn.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag tmpn                Order        name
UserTag tmpn                hasEndTag
UserTag tmpn                PosNumber    1
UserTag tmpn                Version      $Revision: 1.5 $
UserTag tmpn                MapRoutine   Vend::Interpolate::set_tmp

Source: lib/Vend/Interpolate.pm
Lines: 5250

sub set_tmp {
my($var,$val) = @_;
push @Vend::TmpScratch, $var;
  $::Scratch->{$var} = $val;
return '';
}

SEE ALSO

scratch(7ic)


Name

tn

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

tn is available in Interchange versions:

5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/tv.coretag
Lines: 88


UserTag tv  Order name
UserTag tv  Description Return $Tmp value
UserTag tv  Routine <<EOR
sub {
my $key = shift;
my $val = $Vend::Interpolate::Tmp->{ $key };
return $val;
}
EOR

UserTag ts  Order name
UserTag ts  hasEndTag
UserTag ts  Interpolate
UserTag ts  Description Set $Tmp value
UserTag ts  Routine <<EOR
sub {
my $key = shift;
$Vend::Interpolate::Tmp->{$key} = shift;
return '';
}
EOR

UserTag tn  Order name
UserTag tn  hasEndTag
UserTag tn  Description Set $Tmp value
UserTag tn  Routine <<EOR
sub {
my $key = shift;
$Vend::Interpolate::Tmp->{$key} = shift;
return '';
}
EOR

UserTag tv  Documentation <<EOD
=head1 NAME

tv -- true temporary, non-session set/value tag

=head1 SYNOPSIS

[ts foo]The time is: [time fmt="%H:%M"][/ts]
[tv foo]
(Shows "The time is: 09:10")

[tn bar]The time tag is set as in: [time fmt='%H:%M'][/tn]
[tv bar]
(Shows "The time tag is set as in: [time fmt='%H:%M']")

=head1 DESCRIPTION

Interchange uses C<[tmp foo][/tmp]> and C<[tmpn bar][/tmpn]> to set
temporary scratch values. While this works OK in most cases, these
values have to be managed in the session, and also may overwrite values
which could be counted on by other pages (when set with C<[set ...]>) or by
manipulating $Scratch.

The above three tags replace this scheme with values that are based
in the C<$Vend::Interpolate::Tmp> space. These values are available
in embedded Perl with C<$Tmp>, so are usable in the same fashion as
C<$Scratch>. But they are truly temporary and will never be saved to
a session.

=over 4

=item [ts VARNAME]VALUE[/ts]

ITL code in VALUE I<is> interoplated prior to setting VARNAME in $Tmp.

=item [tn VARNAME]VALUE[/tn]

ITL code in VALUE is I<not> interoplated prior to setting VARNAME in $Tmp.

=item [tv VARNAME]

Display value of VARNAME.

=back

=head1 AUTHOR

Mike Heins, <mheins@icdevgroup.org>

=head1 BUGS

The usual number.

=cut
EOD

SEE ALSO


Name

total-cost — display total cost of electronic cart, including all adjustments

ATTRIBUTES

AttributePos.Req.DefaultDescription
name | cart YesYesmainElectronic cart name.
noformat YesYes0Do not format the displayed price?
space | discount_space Yes Default spaceName of the discount "space".
locale    Format price according to the specified locale.
display  symbolDisplay currency as symbol, text or not at all?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag displays the total monetary value of the user's electronic cart, including all price adjustments such as quantity pricing, discounts, handling, shipping and taxing.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic example

[total-cost]

NOTES

Handling and shipping costs are not applied to the total cost if the corresponding values (mv_shipmode resp. mv_handling) are empty. This can happen if you use assign to set the costs and there are no defaults for the values.

AVAILABILITY

total-cost is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/total_cost.coretag
Lines: 21


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: total_cost.coretag,v 1.7 2007-03-30 23:40:49 pajamian Exp $

UserTag total-cost          Order        name noformat
UserTag total-cost          attrAlias    cart name
UserTag total-cost          attrAlias    space discount_space
UserTag total-cost          PosNumber    2
UserTag total-cost          addAttr
UserTag total-cost          Version      $Revision: 1.7 $
UserTag total-cost          Routine <<EOR
sub {
my($cart, $noformat, $opt) = @_;
return currency( total_cost($cart, $opt->{discount_space}), $noformat, undef, $opt);
}
EOR


Name

traffic-report

ATTRIBUTES

AttributePos.Req.DefaultDescription
save Yes
header
show
affiliate
begin_date
end_date
by_day
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: VISIT_TIMEOUT

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

traffic-report is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/traffic_report.coretag
Lines: 297


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: traffic_report.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag traffic-report Order   save
UserTag traffic-report addAttr
UserTag traffic-report Version $Revision: 1.6 $
UserTag traffic-report Routine <<EOR
sub {
my ($save, $opt) = @_;

use Search::Dict;

my %header = (
  date  => errmsg('Date'),
  affiliate  => errmsg('Affiliate'),
  campaign  => errmsg('Campaign'),
  visits  => errmsg('Visits'),
  hits  => errmsg('Hits'),
  pages  => errmsg('Pages'),
  views  => errmsg('Prod. views'),
  incart  => errmsg('Items in cart'),
  orders  => errmsg('Orders'),
);

my %hmap = qw/
  VIEWPAGE pages
  VIEWPROD views
  ADDITEM  incart
  ORDER    orders
/;

if(ref $opt->{header}) {
  for(keys %{$opt->{header}}) {
    $header{$_} = errmsg($opt->{header}{$_});
  }
}

my $cols = $opt->{show} || 'date affiliate visits hits pages views incart orders';
my @cols = grep /\w/, split /[\0,\s]+/, $cols;
my $numcols = scalar(@cols);

my @out = <<EOF;
<TABLE width="90%" border=0 cellpadding=0 cellspacing=0>
<tr class=rborder height=1><td colspan=8></td></tr>
<TR class=rmarq>
EOF
for(@cols) {
  push @out, "<TD VALIGN=top>$header{$_}</td>";
}

push @out, <<EOF;
</TR>
<tr class=rborder height=1><td colspan=8></td></tr>
EOF

my $file = $Vend::Cfg->{TrackFile};
unless (-f $file) {
  push @out, "<tr><td colspan=$numcols class=error>No traffic statistics found</td></tr></table>";
  return;
}

unless(open REPORT, "< $file") {
  push @out, "<tr><td colspan=$numcols class=error>Cannot open file $file</td></tr></table>";
  return;
}

my $affiliate = $opt->{affiliate} || $CGI::values{affiliate};
my $begin_date = $opt->{begin_date} || $CGI::values{ui_begin_date};
my $end_date = $opt->{end_date} || $CGI::values{ui_end_date};
my $Tag = new Vend::Tags;

if($begin_date) {
  $begin_date = filter_value('date_change', $begin_date);
  look(\*REPORT, $begin_date) if $begin_date;
}

$end_date = filter_value('date_change', $end_date)
  if $end_date;

my %names = qw/
   01 January
   02 February
   03 March
   04 April
 05 May
 06 June
 07 July
 08 August
 09 September
 10 October
 11 November
 12 December
/;

my $timeout = $::Variable->{VISIT_TIMEOUT} || (30 * 10);

my $by_day = $opt->{by_day} || $CGI::values{ui_by_day};
my $len;
$len = $by_day ? 8 : 6;

my $done;
my $prev;
my $break_check = sub {
  if(! defined($prev)) {
    $prev = $_[0];
    return;
  }
  if ($end_date and $_[0] gt $end_date) {
    $done = 1;
    return 1;
  }
  return if $_[0] eq $prev;
  $prev = $_[0];
  return 1;
};


BREAK: {
  my $hits;
  my $interval_count = 0;
  my $interval_total = 0;
  my $max_interval = 0;
  my $min_interval = 9999999;
  my $out = '';
  my $visits;
  my $visit_number;
  my %action_by_aff;
  my %action_by_day;
  my %action_by_period;
  my %action_by_tag;
  my %action_by_visit;
  my %action_by_visit_number;
  my %actions_per_visit_boolean;
  my %hits_by_day;
  my %hits_by_item;
  my %hits_by_page;
  my %hits_by_period;
  my %hits_by_session;
  my %last_access;
  my %session_by_order;
  my %session_by_page;
  my %visit_by_aff;
  my %visit_by_aff_by_day;
  my %visit_by_aff_by_period;
  my %visit_by_day;
  my %visit_by_ip;
  my %visit_by_period;
  my %visit_by_session;
  my %visit_by_user;
  my %visit_number;



my $donelines = 0;

## To fudge around break
my $saved_line;
my $recall;

COUNT:
while (<REPORT>) {
  chop;

  ## To fudge around break, so that we can break then recall
  ## the line where we broke
  if($recall) {
    $saved_line = $_;
    $_ = $recall;
    undef $recall;
  }
  my $line = [ split /\t/, $_ , 7];

  my $per = substr($line->[0], 0, $len);
  $break_check->($per)
    and do {
      $recall = $_;
      last COUNT;
    };
  next if $affiliate and $line->[5] ne $affiliate;
  my $update_visit;
  my $interval;
  $hits++;
  $hits_by_period{$per}++;
  $hits_by_day{$line->[0]}++;
  $hits_by_session{$line->[1]}++
    or $update_visit = 1;
  
  $interval = $line->[4] - $last_access{$line->[1]}
    if  $last_access{$line->[1]};
  if($interval) {
    $max_interval = $interval 
      if $interval > $max_interval;
    $min_interval = $interval 
      if $interval < $min_interval;
    $interval_total += $interval;
    $interval_count++;
    $update_visit = 1 if $interval > $timeout;
  }
  $last_access{$line->[1]} = $line->[4];

  if($update_visit) {
    $visits++;
    $visit_number = "$line->[1]:" . $visit_by_session{$line->[1]}++;
    $visit_by_period{$per}++;
    $visit_by_day{$line->[0]}++;
    $visit_by_user{$line->[2]}++;
    $visit_by_ip{$line->[3]}++;
    $visit_by_aff{$line->[5]}++;
    $visit_by_aff_by_period{$per}{$line->[5]}++;
    $visit_by_aff_by_day{$line->[0]}{$line->[5]}++;
  }

  # Leave this at & instead of UrlJoiner because of Vend::Track
  my (@items) = split /(?:^|&)([A-Z]+)=/, $line->[6];
  shift @items;
#::logDebug("items = " . ::uneval(\@items)) if $line->[6] =~ / \& /;
  while (@items) {
    my($tag, $val) = splice(@items, 0, 2);
    $action_by_visit{$tag}++
      unless $action_by_visit_number{$visit_number}{$tag}++;
    $action_by_tag{$tag}{$val}++;
    $action_by_aff{$line->[5]}{$tag}++;
    $action_by_period{$per}{$tag}++;
    $action_by_day{$line->[0]}{$tag}++;
  }

  ## To fudge around break
  if($saved_line) {
    $_ = $saved_line;
    undef $saved_line;
    redo COUNT;
  }
}
#::logDebug("action_by_visit=" . ::uneval(\%action_by_visit));
foreach my $one (sort keys %visit_by_period) {
  my ($yr, $mon, $day) = $one =~ /(\d\d\d\d)(\d\d)(\d\d)?/;
  my $date;
  my %output;
  push @out, "<TR class=rnorm>\n";
  $date = $day ? "$names{$mon} $day, $yr" : "$names{$mon} $yr";
  $output{date} = <<EOF;
<TD VALIGN="top">
$date
</TD>
EOF
  my (@number) = grep /\S/, keys %{ $visit_by_aff_by_period{$one} };
  my $count = scalar(@number);
  $output{affiliate} = <<EOF;
<TD VALIGN="top" ALIGN=CENTER>
$count
</TD>
EOF

  $output{visits} = <<EOF;
<TD VALIGN="top" ALIGN=CENTER>
$visit_by_period{$one}
</TD>
EOF

  $output{hits} = <<EOF;
<TD VALIGN="top" ALIGN=CENTER>
$hits_by_period{$one}
</TD>
EOF
  for(qw/ VIEWPAGE VIEWPROD ADDITEM ORDER /) {
    $count = $action_by_period{$one}{$_} || 0;
    my $pct = '';
    $pct = $action_by_visit{$_} / $visit_by_period{$one} * 100
      if $visit_by_period{$one};
    $pct = $pct <= 0 ? '' : sprintf( "<FONT SIZE=1><BR>%.2f%%</FONT>", $pct);
    $output{$hmap{$_}} = <<EOF;
<TD VALIGN="top" ALIGN=CENTER>
$count$pct
</TD>
EOF
  }
  for(@cols) {
    push @out, $output{$_};
  }
  push @out, '</TR>';
}

redo BREAK unless $done or eof(REPORT);
}
push @out, <<EOF;
<tr class=rborder height=1><td colspan=8></td></tr>
</TABLE>
EOF
return join "\n", @out;
}
EOR


Name

tree — display tree-like structure from database

ATTRIBUTES

AttributePos.Req.DefaultDescription
table Yes Yes None Database table which contains the tree.
master Yes Yes None Column which contains the parent item.
subordinate Yes Yes None Column which serves as subordinate.
start Yes None Root item of the tree.
file None Use specified tab-seperated file instead of database table.
delimiter
level_field
multiple_start
outline
spacing 10 spacing per level
code_field
sort
where None SQL where clause.
memo
toggle
collapse
full
explode
spacer
stop
continue
autodetect
pedantic
log_error
show_error
object
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

tree is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/tree.coretag
Lines: 299


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: tree.coretag,v 1.12 2007-07-18 00:16:26 jon Exp $

UserTag tree                Order        table master subordinate start
UserTag tree                addAttr
UserTag tree                attrAlias    sub subordinate
UserTag tree                hasEndTag
UserTag tree                Version      $Revision: 1.12 $
UserTag tree                Routine      <<EOR
sub {
my($table, $parent, $sub, $start_item, $opt, $text) = @_;

#::logDebug("tree-list: received parent=$parent sub=$sub start=$start_item");

my $nodb;
my @passed;
my @start;
if($opt->{file}) {
  my $delim = $opt->{delimiter} || "\t";
  my $s = $opt->{subordinate} || 'code';
  my $l = $opt->{level_field} || 'msort';
  $delim = qr/$delim/;
  my @lines = split /\n/, readfile($opt->{file});
  my $hdr = shift @lines;
  my @fields = split $delim, $hdr;
  my $i = 1;
  for(@lines) {
    my $ref = {};
    @{$ref}{@fields} = split $delim, $_;
    $ref->{$s} = $i++;
    push @passed, $ref;
    push @start, $ref if $ref->{$l} == 0;
  }
  $nodb = 1;
}
my $db;

unless($nodb) {
  $db = ::database_exists_ref($table)
    or return error_opt($opt, "Database %s doesn't exist", $table);
  $db->column_exists($parent)
    or return error_opt($opt, "Parent column %s doesn't exist", $parent);
  $db->column_exists($sub)
    or return error_opt($opt, "Subordinate column %s doesn't exist", $sub);
}

my $basewhere;

WHEREBASE: {
  my @keys;
  my @things;
  if($opt->{multiple_start}) {
    @keys = split /[\0,\s]+/, $start_item;
  }
  else {
    @keys = $start_item;
  }

  unless($nodb) {
    for(@keys) {
      push @things, "$parent = " . $db->quote($_, $parent);
    }
  }
  $basewhere = join " OR ", @things;
}

my @outline = (1);
if(defined $opt->{outline}) {
  $opt->{outline} =~ s/[^a-zA-Z0-9]+//g;
  @outline = split //, $opt->{outline};
  @outline = (qw/1 A 1 a 1 a/) if scalar @outline < 2;
}

my $mult = ( int($opt->{spacing}) || 10 );
my $keyfield;
$keyfield = $db->config('KEY') unless $nodb;
$opt->{code_field} = $keyfield if ! $opt->{code_field};

my $sort = '';
if($opt->{sort}) {
  $sort .= ' ';
  $sort .= 'ORDER BY '
    unless $opt->{sort} =~ /^\s*order\s+by\s+/i;
  my @sort;
  @sort = ref $opt->{sort}
      ?  @{$opt->{sort}}  
      : ( $opt->{sort} );
  for(@sort) {
    s/\s*[=:]\s*([rnxf]).*//;
    $_ .= " DESC" if $1 eq 'r';
  }
  $sort .= join ", ", @sort;
  undef $opt->{sort};
}

my $where = '';
unless($nodb) {
  if( my $f = $db->config('HIDE_FIELD')) {
    $where .= " AND $f <> 1";
  }
}

if($opt->{where}) {
  $where .= " AND ($opt->{where})";
}

my $qb = "SELECT * FROM $table WHERE $basewhere$where$sort";
#::logDebug("tree tag initial query=$qb");

my $ary;
if($nodb) {
  $ary = \@start;
}
else {
  $ary = $db->query( {
            hashref => 1,
            sql => $qb,
            });
}

my $memo;
if( $opt->{memo} ) {
  $memo = ($::Scratch->{$opt->{memo}} ||= {});
  my $toggle;
  if($opt->{toggle} and $toggle = $CGI::values{$opt->{toggle}}) {
    $memo->{$toggle} = ! $memo->{$toggle};
  }
}

if($opt->{collapse} and $CGI::values{$opt->{collapse}}) {
  $memo = {};
  delete $::Scratch->{$opt->{memo}} if $opt->{memo};
}

my $explode;
if($opt->{full} or $opt->{explode} and $CGI::values{$opt->{explode}}) {
  $explode = 1;
}

my $enable;

my $qsub;

my $donemsg;
my $dbh;
$dbh = $db->dbh() unless $nodb;

my $qs_query = "SELECT * FROM $table WHERE $parent = ?$where$sort";
if($nodb) {
  my $l = $opt->{level_field} || 'msort';
#::logDebug("setting up nodb qsub level=$l");
  $qsub = sub {
    my $key = shift;
#::logDebug("Looking for key=$key");
    return if $key < 1;
    my $base = $passed[$key - 1]->{$l} + 1;
#::logDebug("Base level=$base, firstone = $passed[$key]{$l}");
    my @out;
    for(my $i = $key; $passed[$i]{$l} >= $base ; $i++ ) {
      push @out, $passed[$i] if $passed[$i]{$l} == $base;
    }
    return unless @out;
    return \@out;
  };
}
elsif($dbh and $db->config('Class') eq 'DBI') {
  my $sth = $dbh->prepare($qs_query)
      or die errmsg(
          "tree failed to prepare query: %s\nError was: %s",
          $qs_query,
          $DBI::errstr,
          );
  $qsub = sub {
#::logDebug("executing query sub DBI style"); # while ! $donemsg++;
    my $parm = shift;
    my @ary;
    $sth->execute($parm)
      or die errmsg(
          "tree failed to prepare query for '%s': %s\nError was: %s",
          $parm,
          $qs_query,
          $DBI::errstr,
          );
    while(my $ref = $sth->fetchrow_hashref()) {
      push @ary, { %$ref };
    }
    return unless @ary;
    return \@ary;
  };
}
else {
  $qsub = sub {
    my $parm = shift;
#::logDebug("executing query sub regular style"); # while ! $donemsg++;
    $parm = $db->quote($parm, $parent);
    my $q = $qs_query;
    $q =~ s/\s\?\s/ $parm /;
    $db->query( { hashref => 1, sql => $q });
  };
}


$memo = {} if ! $memo;

my $count = 0;

my $stop_sub;

#::logDebug("tree-list: valid parent=$parent sub=$sub start=$start_item mult=$mult");

my @ary_stack   = ( $ary );        # Stacks the rows
my @above_stack = { $start_item => 1 }; # Holds the previous levels
my @inc_stack   = ($outline[0]);    # Holds the increment characters
my @rows;
my $row;

ARY: for (;;) {
#::logDebug("next ary");
  my $ary = pop(@ary_stack)
    or last ARY;
  my $above = pop(@above_stack);
  my $level = scalar(@ary_stack);
  my $increment = pop(@inc_stack);
  ROW: for(;;) {
#::logDebug("next row level=$level increment=$increment");
    my $prev = $row;
    $row = shift @$ary
      or ($prev and $prev->{mv_last} = 1), last ROW;
    $row->{mv_level} = $level;
    $row->{mv_spacing} = $level * $mult;
    $row->{mv_spacer} = $opt->{spacer} x $row->{mv_spacing}
      if $opt->{spacer};
    $row->{mv_increment} = $increment++;
    $row->{mv_ip} = $count++;
    push(@rows, $row);
    my $code = $row->{$keyfield};
    $row->{mv_toggled} = 1 if $memo->{$code};
#::logDebug("next row sub=$sub=$row->{$sub}");
    my $next = $row->{$sub}
      or next ROW;

    my $stop;
    $row->{mv_children} = 1
      if ($opt->{stop}    and ! $row->{ $opt->{stop} }  )
      or ($opt->{continue}  and   $row->{ $opt->{continue} })
      or ($opt->{autodetect});

    $stop = 1  if ! $explode and ! $memo->{$code};
#::logDebug("next row sub=$sub=$next stop=$stop explode=$explode memo=$memo->{$code}");

    if($above->{$next} and ($opt->{autodetect} or ! $stop) ) {
      my $fmt = <<EOF;
Endless tree detected at key %s in table %s.
Parent %s, would traverse to %s.
EOF
      my $msg = ::errmsg($fmt, $code, $table, $row->{$parent}, $next);
      if(! $opt->{pedantic}) {
        error_opt($opt, $msg);
        next ROW;
      }
      else {
        $opt->{log_error} = 1 unless $opt->{show_error};
        return error_opt($opt, $msg);
      }
    }

    my $a;
    if ($opt->{autodetect} or ! $stop) {
#::logDebug("next=$next row query=$q");
      $a = $qsub->($next);
      $above->{$next} = 1 if $a and scalar @{$a};
    }

    if($opt->{autodetect}) {
      $row->{mv_children} = $a ? scalar(@$a) : 0; 
    }

    if (! $stop) {
      push(@ary_stack, $ary);
      push(@above_stack, $above);
      push(@inc_stack, $increment);
      $level++;
      $increment = defined $outline[$level] ? $outline[$level] : 1;
      $ary = $a;
    }
  }  # END ROW
#::logDebug("last row");
} # END ARY
$opt->{object} = { mv_results => \@rows };
#::logDebug("last ary, results =" . ::uneval(\@rows));
return labeled_list($opt, $text, $opt->{object});
}
EOR


Name

try — safely execute a code block and test for errors

ATTRIBUTES

AttributePos.Req.DefaultDescription
label 1 1 default Name to assign to the try block. The name is later used by cache (or some custom code) to refer to the proper try block.
status 0 0 0 Suppresses normal try block output and only return 1 for no error, or 0 when the error happens. The corresponding catch block is executed if there's an error.
hide 0 0 0 Suppresses normal try block output, regardless of its evaluation success or failure. The corresponding catch block is executed if there's an error.
clean 0 0 0 Cause the try block to suppress its output only if it has an error. Otherwise the block will return whatever partial output it has completed before the error. The corresponding catch block is executed if there's an error.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The try block allows you to trap execution errors. Interchange processes the body of the tag and normally parses and evaluates the block. If no errors are raised during execution of the block, the parsing procedure continues as if try wasn't there. If the error does get generated, however, Interchange will execute the correspondingly named catch block. "Corresponding names" are determined by using labels — arbitrary strings that must match at both sides.

The try tag will place execution result in the $Session object. See the section called “EXAMPLES” for clarification.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Simple 'try' block in action

[set divisor]0[/set]

[try label=div]
  [calc] 1 / [scratch divisor] [/calc]
[/try]

[catch div]Division error[/catch]

Example: Triggering an illegal division by zero and watching the error message

As we've mentioned above, a try block labeled divide creates the $Session->{try}{divide} entry in Perl data structures:

[try label=divide][calc] 1 / [scratch divisor] [/calc][/try]

[catch divide]
  Verbatim error message is: [calc]$Session->{try}{divide}[/calc]
[/catch]

NOTES

See catch for more examples and further discussion.

AVAILABILITY

try is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/try.coretag
Lines: 15


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: try.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag try                 Order        label
UserTag try                 addAttr
UserTag try                 hasEndTag
UserTag try                 PosNumber    1
UserTag try                 Version      $Revision: 1.4 $
UserTag try                 MapRoutine   Vend::Interpolate::try

Source: lib/Vend/Interpolate.pm
Lines: 773

sub try {
my ($label, $opt, $body) = @_;
$label = 'default' unless $label;
$Vend::Session->{try}{$label} = '';
my $out;
my $save;
$save = delete $SIG{__DIE__} if defined $SIG{__DIE__};
$Vend::Try = $label;
eval {
  $out = interpolate_html($body);
};
undef $Vend::Try;
$SIG{__DIE__} = $save if defined $save;
if($@) {
  $Vend::Session->{try}{$label} .= "\n" 
    if $Vend::Session->{try}{$label};
  $Vend::Session->{try}{$label} .= $@;
}
if ($opt->{status}) {
  return ($Vend::Session->{try}{$label}) ? 0 : 1;
}
elsif ($opt->{hide}) {
  return '';
}
elsif ($opt->{clean}) {
  return ($Vend::Session->{try}{$label}) ? '' : $out;
}

return $out;
}

SEE ALSO

catch(7ic)


Name

ts

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

ts is available in Interchange versions:

5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/tv.coretag
Lines: 88


UserTag tv  Order name
UserTag tv  Description Return $Tmp value
UserTag tv  Routine <<EOR
sub {
my $key = shift;
 my $val = $Vend::Interpolate::Tmp->{ $key };
return $val;
}
EOR

UserTag ts  Order name
UserTag ts  hasEndTag
UserTag ts  Interpolate
UserTag ts  Description Set $Tmp value
UserTag ts  Routine <<EOR
sub {
my $key = shift;
 $Vend::Interpolate::Tmp->{$key} = shift;
return '';
}
EOR

UserTag tn  Order name
UserTag tn  hasEndTag
UserTag tn  Description Set $Tmp value
UserTag tn  Routine <<EOR
sub {
my $key = shift;
 $Vend::Interpolate::Tmp->{$key} = shift;
return '';
}
EOR

UserTag tv  Documentation <<EOD
=head1 NAME

tv -- true temporary, non-session set/value tag

=head1 SYNOPSIS

[ts foo]The time is: [time fmt="%H:%M"][/ts]
[tv foo]
(Shows "The time is: 09:10")

[tn bar]The time tag is set as in: [time fmt='%H:%M'][/tn]
[tv bar]
(Shows "The time tag is set as in: [time fmt='%H:%M']")

=head1 DESCRIPTION

Interchange uses C<[tmp foo][/tmp]> and C<[tmpn bar][/tmpn]> to set
temporary scratch values. While this works OK in most cases, these
values have to be managed in the session, and also may overwrite values
which could be counted on by other pages (when set with C<[set ...]>) or by
manipulating $Scratch.

The above three tags replace this scheme with values that are based
in the C<$Vend::Interpolate::Tmp> space. These values are available
in embedded Perl with C<$Tmp>, so are usable in the same fashion as
C<$Scratch>. But they are truly temporary and will never be saved to
a session.

=over 4

=item [ts VARNAME]VALUE[/ts]

ITL code in VALUE I<is> interoplated prior to setting VARNAME in $Tmp.

=item [tn VARNAME]VALUE[/tn]

ITL code in VALUE is I<not> interoplated prior to setting VARNAME in $Tmp.

=item [tv VARNAME]

Display value of VARNAME.

=back

=head1 AUTHOR

Mike Heins, <mheins@icdevgroup.org>

=head1 BUGS

The usual number.

=cut
EOD

SEE ALSO


Name

tv

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

tv is available in Interchange versions:

5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/tv.coretag
Lines: 88


UserTag tv  Order name
UserTag tv  Description Return $Tmp value
UserTag tv  Routine <<EOR
sub {
 my $key = shift;
  my $val = $Vend::Interpolate::Tmp->{ $key };
 return $val;
}
EOR

UserTag ts  Order name
UserTag ts  hasEndTag
UserTag ts  Interpolate
UserTag ts  Description Set $Tmp value
UserTag ts  Routine <<EOR
sub {
 my $key = shift;
  $Vend::Interpolate::Tmp->{$key} = shift;
 return '';
}
EOR

UserTag tn  Order name
UserTag tn  hasEndTag
UserTag tn  Description Set $Tmp value
UserTag tn  Routine <<EOR
sub {
 my $key = shift;
  $Vend::Interpolate::Tmp->{$key} = shift;
 return '';
}
EOR

UserTag tv  Documentation <<EOD
=head1 NAME

tv -- true temporary, non-session set/value tag

=head1 SYNOPSIS

[ts foo]The time is: [time fmt="%H:%M"][/ts]
[tv foo]
(Shows "The time is: 09:10")

[tn bar]The time tag is set as in: [time fmt='%H:%M'][/tn]
[tv bar]
(Shows "The time tag is set as in: [time fmt='%H:%M']")

=head1 DESCRIPTION

Interchange uses C<[tmp foo][/tmp]> and C<[tmpn bar][/tmpn]> to set
temporary scratch values. While this works OK in most cases, these
values have to be managed in the session, and also may overwrite values
which could be counted on by other pages (when set with C<[set ...]>) or by
manipulating $Scratch.

The above three tags replace this scheme with values that are based
in the C<$Vend::Interpolate::Tmp> space. These values are available
in embedded Perl with C<$Tmp>, so are usable in the same fashion as
C<$Scratch>. But they are truly temporary and will never be saved to
a session.

=over 4

=item [ts VARNAME]VALUE[/ts]

ITL code in VALUE I<is> interoplated prior to setting VARNAME in $Tmp.

=item [tn VARNAME]VALUE[/tn]

ITL code in VALUE is I<not> interoplated prior to setting VARNAME in $Tmp.

=item [tv VARNAME]

Display value of VARNAME.

=back

=head1 AUTHOR

Mike Heins, <mheins@icdevgroup.org>

=head1 BUGS

The usual number.

=cut
EOD

SEE ALSO


Name

uc-attr-list — replaces placeholders in curly braces with provided values

ATTRIBUTES

AttributePos.Req.DefaultDescription
hash
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

uc-attr-list replaces placeholders in curly braces with provided values. These values can be passed as parameters or as Perl hash reference in the hash parameter.

PlaceholderReplacement
{NAME}value of NAME
{NAME?}...{/NAME?}placeholder contents if NAME is true
{NAME?}...{/NAME?}placeholder contents if NAME is false

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

uc-attr-list is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/uc_attr_list.coretag
Lines: 23


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: uc_attr_list.coretag,v 1.2 2007-03-30 23:40:49 pajamian Exp $

UserTag uc-attr-list           addAttr
UserTag uc-attr-list           hasEndTag
UserTag uc-attr-list           PosNumber    0
UserTag uc-attr-list           noRearrange
UserTag uc-attr-list           Version      $Revision: 1.2 $
UserTag uc-attr-list           Routine      <<EOR
sub {
my ($opt, $body) = @_;
if( ref $opt->{hash} ) {
  $opt = $opt->{hash};
}
return Vend::Interpolate::tag_attr_list($body, $opt, 1);
}
EOR

SEE ALSO


Name

uneval

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes
ref Yes
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

uneval is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/uneval.coretag
Lines: 22


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: uneval.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag uneval Order       name ref
UserTag uneval PosNumber   1
UserTag uneval Version     $Revision: 1.5 $
UserTag uneval Routine     <<EOR
sub {
my ($name, $ref) = @_;
#::logError("args: @_" . Vend::Util::uneval_it(@_));
if(! $ref) {
  $ref = $Vend::Session->{$name};
}
return Vend::Util::uneval($ref);
}
EOR

SEE ALSO


Name

uninstall_feature

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

uninstall_feature is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/uninstall_feature.tag
Lines: 15


# Copyright 2005-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: uninstall_feature.tag,v 1.3 2007-03-30 23:40:54 pajamian Exp $

UserTag uninstall_feature Order       name
UserTag uninstall_feature MapRoutine  Vend::Config::uninstall_feature
UserTag uninstall_feature Version     $Revision: 1.3 $
UserTag uninstall_feature Description <<EOD
This tag uninstalls features which were installed with Feature.
EOD

Source: lib/Vend/Config.pm
Lines: 2542

sub uninstall_feature {
my ($value) = @_;
my $c = $Vend::Cfg
  or die "Not in catalog context.\n";

#::logDebug("Running uninstall for cat=$Vend::Cat, from cfg ref=$c->{CatalogName}");
$value =~ s/^\s+//;
$value =~ s/\s+$//;
my $fdir = Vend::File::catfile($Global::FeatureDir, $value);

unless(-d $fdir) {
  config_warn("Feature '%s' not found, skipping.", $value);
  return $c;
}

my $etag = errmsg("feature %s uninstall -- ", $value);

# Get the global install files and remove them from the config list
my @gfiles = glob("$fdir/*.global");
my %seen;
@seen{@gfiles} = @gfiles;

# Get the init files and remove them from the config list
my @ifiles = glob("$fdir/*.init");
@seen{@ifiles} = @ifiles;

# Get the uninstall files and remove them from the config list
my @ufiles = glob("$fdir/*.uninstall");
@seen{@ufiles} = @ifiles;

# Any other files are config files
my @cfiles = grep ! $seen{$_}++, glob("$fdir/*");

# directories are for copying
my @cdirs = grep -d $_, @cfiles;

my $Tag = new Vend::Tags;

my @copy;
my @errors;
my @warnings;

my $wanted = sub {
  return unless -f $_;
  my $n = $File::Find::name;
  $n =~ s{^$fdir/}{};
  my $d = $File::Find::dir;
  $d =~ s{^$fdir/}{};
  push @copy, [$n, $d];
};

if(@cdirs) {
  File::Find::find({ wanted => $wanted, follow => 1 }, @cdirs);
}
#::logDebug("ufiles=" . ::uneval(\@ufiles));
#::logDebug("ifiles=" . ::uneval(\@ifiles));
#::logDebug("cdirs=" . ::uneval(\@cdirs));
#::logDebug("copy=" . ::uneval(\@copy));

for(@ufiles) {
#::logDebug("Running uninstall file $_");
  my $save = $Global::AllowGlobal->{$Vend::Cat};
  $Global::AllowGlobal->{$Vend::Cat} = 1;
  open UNFILE, "< $_"
    or do {
      push @errors, $etag . errmsg("error reading %s: %s", $_, $!);
    };
  my $chunk = join "", <UNFILE>;
  close UNFILE;

#::logDebug("uninstall chunk length=" . length($chunk));

  my $out;
  eval {
    $out = Vend::Interpolate::interpolate_html($chunk);
  };

  if($@) {
    push @errors, $etag . errmsg("error running uninstall %s: %s", $_, $@);
  }

  push @warnings, $etag . errmsg("message from %s: %s", $_, $out)
    if $out =~ /\S/;

  $Global::AllowGlobal->{$Vend::Cat} = $save;
}

for(@copy) {
  my ($n, $d) = @$_;

  my $tf = Vend::File::catfile($c->{VendRoot}, $n);
  next unless -f $tf;

  my $contents1 = Vend::File::readfile($tf);

  my $sf = "$fdir/$n";

  open UNSRC, "< $sf"
    or die $etag . errmsg("Couldn't read uninstall source file %s: %s", $sf, $!);

  local $/;
  my $contents2 = <UNSRC>;

  if($contents1 ne $contents2) {
    push @warnings, $etag . errmsg("will not uninstall %s, changed.", $tf);
    next;
  }

  unlink $tf
    or do {
      push @errors,
        $etag . errmsg("$etag couldn't unlink file %s: %s", $tf, $!);
      next;
    };

  my $td = Vend::File::catfile($c->{VendRoot}, $d);
  my @left = glob("$td/*");
  push @left, glob("$td/.?*");
  next if @left;
  File::Path::rmtree($td);
}

if(@ifiles) {
#::logDebug("running uninstall touch and init");
  my $initdir = Vend::File::catfile($c->{ConfDir}, 'init', $value);
  File::Path::mkpath($initdir) unless -d $initdir;
  my $fn = Vend::File::catfile($initdir, 'uninstall');
#::logDebug("touching uninstall file $fn");
  open UNFILE, ">> $fn"
    or die errmsg("Couldn't create uninstall flag file %s: %s", $fn, $!);
  print UNFILE $etag . errmsg("uninstalled at %s.\n", scalar(localtime));
  close UNFILE;
}


my $errors;
for(@errors) {
  $Tag->error({ set => $_});
  ::logError($_);
  $errors++;
}

for(@warnings) {
  $Tag->warnings($_);
  ::logError($_);
}

return ! $errors;
}

SEE ALSO


Name

unless

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

unless is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 2828

sub tag_unless {
return tag_self_contained_if(@_, 1) if defined $_[4];
return tag_if(@_, 1);
}

SEE ALSO


Name

unlink_file — safely delete a file within catalog root directory

ATTRIBUTES

AttributePos.Req.DefaultDescription
name YesYes File name to delete
prefix Yes tmp/Prefix that the filename must match (a safety measure)
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag safely deletes a file from the catalog root directory (CATROOT).

The beginning of the filename must match the prefix= option for the deletion to succeed.

The filename can not start with a / nor ../.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: create and delete file "tmp/testfile"

[tmp]

[write-relative-file tmp/testfile]
  Hello, World!
[/write-relative-file]

[unlink-file tmp/testfile]

[/tmp]

The tmp tag is only used to hide output values from the two contained tags.


Example: delete file "logs/tmplog"

[tmp] [unlink-file name="logs/tmplog" prefix="logs/"] [/tmp]


NOTES

AVAILABILITY

unlink_file is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/unlink_file.coretag
Lines: 23


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: unlink_file.coretag,v 1.5 2007-03-30 23:40:54 pajamian Exp $

UserTag unlink_file Order      name prefix
UserTag unlink_file PosNumber  2
UserTag unlink_file Version    $Revision: 1.5 $
UserTag unlink_file Routine    <<EOR
sub {
my ($file, $prefix) = @_;
#::logDebug("got to unlink: file=$file prefix=$prefix");
$prefix = 'tmp/' unless $prefix;
return if Vend::File::absolute_or_relative($file);
return unless $file =~ /^$prefix/;
#::logDebug("got to unlink: $file qualifies");
unlink $file;
}
EOR


Name

unpack — unpacks mapped output into template

ATTRIBUTES

AttributePos.Req.DefaultDescription
interpolate   1interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Pragmas: <pragma>no_image_rewrite</pragma>

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

unpack is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/unpack.coretag
Lines: 44


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: unpack.coretag,v 1.4 2007-03-30 23:40:49 pajamian Exp $

UserTag unpack PosNumber     0
UserTag unpack addAttr
UserTag unpack hasEndTag
UserTag unpack Interpolate
UserTag unpack Version       $Revision: 1.4 $
UserTag unpack Routine       <<EOR
sub {
my ($opt, $template) = @_;
Vend::Interpolate::substitute_image(\$template);
if($Vend::MultiOutput) {
#::logDebug("We have mult-output");
  for my $space (keys %Vend::OutPtr) {
#::logDebug("Filtering $space");
    my $things = $Vend::OutPtr{$space} || [];
    for my $ptr (@$things) {
      my $subs = $Vend::OutFilter{$space} || [];
      for my $sub (@$subs) {
#::logDebug("Filtering ${$Vend::Output[$ptr]}");
        $sub->($Vend::Output[$ptr]);
#::logDebug("Now is    ${$Vend::Output[$ptr]}");
    }
  }
}
}
else {
for(@Vend::Output) {
  Vend::Interpolate::substitute_image($_);
}
}
undef $Vend::MultiOutput;
$::Pragma->{no_image_rewrite} = 1;
Vend::Page::templatize($template);
return;
}
EOR


Name

update — refresh specific set of internal data

ATTRIBUTES

AttributePos.Req.DefaultDescription
function yes yes name of function (see below)
name cart name (cart function only)
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

[update cart] updates the cart. If the user has put in 0 for any quantity, delete that item from the cart. Also adjust the cart to take minimum and maximum order quantities as specified by the MinQuantityField and MaxQuantityField directives into account.

[update values] updates the value namespace from the volatile CGI namespace.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

update is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/update.coretag
Lines: 13


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: update.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag update              Order        function
UserTag update              addAttr
UserTag update              Version      $Revision: 1.5 $
UserTag update              MapRoutine   Vend::Interpolate::update

Source: lib/Vend/Interpolate.pm
Lines: 5397

sub update {
my ($func, $opt) = @_;
if($func eq 'quantity') {
  Vend::Order::update_quantity();
}
elsif($func eq 'cart') {
  my $cart;
  if($opt->{name}) {
    $cart = $::Carts->{$opt->{name}};
  }
  else {
    $cart = $Vend::Items;
  }
  return if ! ref $cart;
  Vend::Cart::toss_cart($cart, $opt->{name});
}
elsif ($func eq 'process') {
  Vend::Dispatch::do_process();
}
elsif ($func eq 'values') {
  Vend::Dispatch::update_user();
}
elsif ($func eq 'data') {
  Vend::Data::update_data();
}
return;
}

SEE ALSO


Name

update-order-status

ATTRIBUTES

AttributePos.Req.DefaultDescription
order_number Yes
orderline_table
transactions_table
userdb_table
ship_all
void_transaction
cancel_order
archive
do_archive
send_email
settle_transaction
status
tracking_number
lines_shipped
ship_notice_template
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: MV_PAYMENT_MODE

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

update-order-status is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/update_order_status.tag
Lines: 378


# Copyright 2002-2008 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: update_order_status.tag,v 1.13 2008-06-26 12:43:44 mheins Exp $

UserTag update-order-status Order   order_number
UserTag update-order-status addAttr
UserTag update-order-status Version $Revision: 1.13 $
UserTag update-order-status Routine <<EOR
sub {
my ($on, $opt) = @_;
#::logDebug("Shipping order number $on, opt=" . ::uneval($opt));
my $die = sub {
  logError(@_);
  return undef;
};
my $odb = database_exists_ref($opt->{orderline_table} || 'orderline')
  or return $die->("No %s table!", 'orderline');
my $tdb = database_exists_ref($opt->{transactions_table} || 'transactions')
  or return $die->("No %s table!", 'transactions');
my $udb = database_exists_ref($opt->{userdb_table} || 'userdb')
  or return $die->("No %s table!", 'userdb');

my $trec = $tdb->row_hash($on);

if(! $trec) {
  return $die->("Bad transaction number: %s", $on);
}

my $user       = $trec->{username};
my $wants_copy;
if($udb->column_exists('email_copy')) {
  $wants_copy = $udb->field($user, 'email_copy');
}
else {
  $wants_copy = 1;
}

for(qw/
    archive
    auth_code
    cancel_order
    do_archive
    lines_shipped
    send_email
    settle_transaction
    ship_all
    status
    tracking_number
    void_transaction
  /)
{
  $opt->{$_} = $CGI::values{$_} if ! defined $opt->{$_};
}

my @track_keys = grep /tracking_number__1$/, keys %CGI::values;
my @otracks;
for(@track_keys) {
  if(m{^(\d+)_}) {
    $otracks[$1] = $CGI::values{$_};
  }
  else {
    $otracks[0] = $CGI::values{$_};
  }
}

if($opt->{ship_all} == 2 or $opt->{void_transaction} or $opt->{cancel_order}) {
  $opt->{cancel_order} = 1;
  $opt->{ship_all} = 2;
}

$opt->{archive} ||= $opt->{do_archive};

$wants_copy = $opt->{send_email} if length $opt->{send_email};
#Log("Order number=$on username=$user wants=$wants_copy");
delete $::Scratch->{ship_notice_username};
delete $::Scratch->{ship_notice_email};
if($wants_copy) {
  $::Scratch->{ship_notice_username} = $user;
  $::Scratch->{ship_notice_email} = $udb->field($user, 'email')
    or delete $::Scratch->{ship_notice_username};
}

 
if($opt->{settle_transaction}) {
  my $oid = $trec->{order_id};
  my $amount = $trec->{total_cost};
  SETTLE: {
    if(! $oid) {
      Vend::Tags->error( {
              name => 'settle_transaction',
              set => "No order ID to settle!",
            });
      return undef;
    }
elsif($oid =~ /\*$/) {
Vend::Tags->error( {
        name => 'settle_transaction',
        set => "Order ID $oid already settled!",
      });
return undef;
}
else {
#::logDebug("auth-code: $trec->{auth_code} oid=$oid");
my $settled  = Vend::Tags->charge( {
          route => $::Variable->{MV_PAYMENT_MODE},
          order_id => $oid,
          amount => $amount,
          auth_code => $trec->{auth_code},
          transaction => 'settle_prior',
              });
      if($settled) {
        $tdb->set_field($on, 'order_id', "$oid*");
        Vend::Tags->warning(
               errmsg(
                 "Order ID %s settled with processor.",
                $oid,
               ),
            );
      }
      else {
        Vend::Tags->error( {
          name => 'settle_transaction',
          set => errmsg(
              "Order ID %s settle operation failed. Reason: %s",
              $oid,
              $Vend::Session->{payment_result}{MErrMsg},
              ),
            });
          return undef;
      }

    }
  }
}
elsif($opt->{void_transaction}) {
  my $oid = $trec->{order_id};
  $oid =~ s/\*$//;
  my $amount = $trec->{total_cost};
  SETTLE: {
    if(! $oid) {
      Vend::Tags->error( {
              name => 'void_transaction',
              set => "No order ID to void!",
            });
      return undef;
    }
elsif($oid =~ /-$/) {
Vend::Tags->error( {
        name => 'void_transaction',
        set => "Order ID $oid already voided!",
      });
return undef;
}
else {
#::logDebug("auth-code: $trec->{auth_code} oid=$oid");
my $voided  = Vend::Tags->charge( {
          route => $::Variable->{MV_PAYMENT_MODE},
          order_id => $oid,
          amount => $amount,
          auth_code => $trec->{auth_code},
          transaction => 'void',
              });
      if($voided) {
        $tdb->set_field($on, 'order_id', $oid . "-");
        Vend::Tags->warning(
               errmsg(
                 "Order ID %s voided.",
                $oid,
               ),
            );
      }
      else {
        Vend::Tags->error( {
          name => 'void_transaction',
          set => errmsg(
              "Order ID %s void operation failed. Reason: %s",
              $oid,
              $Vend::Session->{payment_result}{MErrMsg},
              ),
            });
          return undef;
      }

    }
  }
}

if($opt->{status} =~ /\d\d\d\d/) {
  $tdb->set_field($on, 'status', $opt->{status});
}
else {
  $tdb->set_field($on, 'status', 'shipped');
}

if($opt->{tracking_number} =~ /\w/) {
  $tdb->set_field($on, 'tracking_number', $opt->{tracking_number});
}

my $need_shiplines;
my @shiplines;
if($opt->{lines_shipped}) {
  @shiplines = grep /\S/, split /\0/, $opt->{lines_shipped};
}
else {
  $need_shiplines = 1;
}

if(! @shiplines and ! $opt->{ship_all}) {
  my @keys = grep /status__1/, keys %CGI::values;
#::logDebug("keys to ship: " . join(',', @keys));
  my %stuff;
  for(@keys) {
#::logDebug("examining $_");
    my $n = 0;
    m/^(\d+)_/ and $n = $1;
    $n++;
    if($opt->{ship_all} or $CGI::values{$_} eq 'shipped') {
      push @shiplines, $n;
#::logDebug("ship $n");
    }
  }
  undef $need_shiplines;
}
else {
  @shiplines = map { s/.*\D//; $_; } @shiplines;
}

my $count_q = "select * from orderline where order_number = '$on'";
my $lines_ary =  $odb->query($count_q);
if(! $lines_ary) {
  $::Scratch->{ui_message} = "No order lines for order $on";
  return;
}
my $total_lines = scalar @$lines_ary;

my $odb_keypos = $odb->config('KEY_INDEX');

# See if some items have already shipped
my %shipping;
my %already;

my $target_status = $opt->{cancel_order} ? 'canceled' : 'shipped';

my $i = 0;
for(@$lines_ary) {
  my $code = $_->[$odb_keypos];
  my $status = $odb->field($code, 'status');
  if (@otracks) {
    $odb->set_field($code,'tracking_number',$otracks[$i]);
  }
  my $line = $code;
  push @shiplines, $line if $need_shiplines;
  $line =~ s/.*\D//;
  $line =~ s/^0+//;
  if($status eq $target_status and ! $opt->{cancel_order}) {
    $already{$line} = 1;
  }
  elsif($opt->{ship_all}) {
    $shipping{$line} = 1;
  }
  $i++;
}

my $to_ship = scalar @shiplines;

#::logDebug("total_lines=$total_lines to_ship=$to_ship shiplines=" . uneval(\@shiplines));

my $ship_mesg;
my $g_status;

@shiplines = grep ! $already{$_}, @shiplines;
@shipping{@shiplines} = @shiplines;

if($total_lines == $to_ship) {
  $ship_mesg = "Order $on complete, $total_lines lines set shipped.";
  $::Scratch->{ship_notice_complete} = $ship_mesg;
  $g_status = $target_status;
}
else {
  $ship_mesg = "Order $on partially shipped ($to_ship of $total_lines lines).";
  delete $::Scratch->{ship_notice_complete};
  $g_status = 'partial';
}

my $minor_mesg = '';

my $email_mesg = $::Scratch->{ship_notice_username}
        ? "Email copy sent to $::Scratch->{ship_notice_email}."
        : "No email copy sent as per user preference.";

my $dotime = $odb->config('DSN');
my $update_date;
$dotime = $dotime =~ /dbi:mysql:/ ? 0 : 1;
$update_date = POSIX::strftime('%Y-%m-%d %H:%M:%S %z', localtime());

# Actually update the orderline database
for(@$lines_ary) {
  my $code = $_->[$odb_keypos];
  my $line = $code;
  $line =~ s/.*\D//;
  next if $already{$line};
  my $status = $shipping{$line} ? $target_status : 'backorder';
  $odb->set_field($code, 'status', $status)
    or do {
      $::Scratch->{ui_message} = "Orderline $code ship status update failed.";
      return;
    };
  if($dotime) {
    $odb->set_field($code, 'update_date', $update_date)
      or do {
        $::Scratch->{ui_message} = "Orderline $code ship date update failed.";
        return;
      };
  }

}

for(keys %already) {
  $shipping{$_} = $_;
}

my $total_shipped_now = scalar keys %shipping; 

delete $::Scratch->{ship_now_complete};

if($opt->{cancel_order}) {
  $g_status = 'canceled';
  $ship_mesg = "Order $on canceled.";
}
elsif (
  $total_lines != scalar @shiplines
    and
  $total_shipped_now == $total_lines 
  )
{
  $g_status = 'shipped';
  $::Scratch->{ship_now_complete} = 1
    if $total_shipped_now == $total_lines;
  $ship_mesg = "Order $on now complete (all $total_lines lines).";
}

$tdb->set_field($on, 'status', $g_status);
$tdb->set_field($on, 'archived', 1)
  if $opt->{archive} and $g_status eq $target_status;

Vend::Tags->warning("$ship_mesg $email_mesg");
delete $::Scratch->{ship_notice_username};
delete $::Scratch->{ship_notice_email};
delete $::Scratch->{ship_notice_order_number};
if($wants_copy) {
  $::Scratch->{ship_notice_order_number} = $on;
  $::Scratch->{ship_notice_username} = $user;
  $::Scratch->{ship_notice_email} = $trec->{email}
    or delete $::Scratch->{ship_notice_username};
  if($opt->{send_email}) {
    my $filename = $opt->{ship_notice_template} || 'etc/ship_notice';
    my $contents = $Tag->file($filename);
    if($contents) {
      $contents = interpolate_html($contents);
      $contents =~ s/^\s+//;
      $contents =~ s/\s*$/\n/;
      $Tag->email_raw({}, $contents);
    }
    else {
      $Tag->warnings(
          errmsg("No ship_notice_template '%s' found", $filename),
        );
    }
  }
}
return;
}
EOR

SEE ALSO


Name

ups-query

ATTRIBUTES

AttributePos.Req.DefaultDescription
mode Yes
origin Yes
zip Yes
weight Yes
query Yes
aggregate
cache_table
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: UPS_ORIGIN, UPS_COUNTRY_FIELD, UPS_POSTCODE_FIELD, UPS_QUERY_MODULO, UPS_COUNTRY_REMAP

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

ups-query is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/ups_query.tag
Lines: 259


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: ups_query.tag,v 1.12 2007-03-30 23:40:57 pajamian Exp $

UserTag  ups-query  Order    mode origin zip weight country
UserTag  ups-query  addAttr
UserTag  ups-query  Version  $Revision: 1.12 $
UserTag  ups-query  Routine  <<EOR
sub {
my( $mode, $origin, $zip, $weight, $country, $opt) = @_;
$opt ||= {};
BEGIN {
eval {
require Business::UPS;
import Business::UPS;
};
};

$origin    = $::Variable->{UPS_ORIGIN}
 if ! $origin;
$country  = $::Values->{$::Variable->{UPS_COUNTRY_FIELD}}
 if ! $country;
$zip    = $::Values->{$::Variable->{UPS_POSTCODE_FIELD}}
   if ! $zip;

my $modulo = $opt->{aggregate};

if($modulo and $modulo < 10) {
 $modulo = $::Variable->{UPS_QUERY_MODULO} || 150;
}
elsif(! $modulo) {
$modulo = 9999999;
}

$country = uc $country;

my %exception;

$exception{UK} = 'GB';

if(! $::Variable->{UPS_COUNTRY_REMAP} ) {
# do nothing
}
elsif ($::Variable->{UPS_COUNTRY_REMAP} =~ /=/) {
my $new = Vend::Util::get_option_hash($::Variable->{UPS_COUNTRY_REMAP});
Vend::Util::get_option_hash(\%exception, $new);
}
else {
Vend::Util::hash_string($::Variable->{UPS_COUNTRY_REMAP}, \%exception);
}

$country = $exception{$country} if $exception{$country};

 # In the U.S., UPS only wants the 5-digit base ZIP code, not ZIP+4
 $country eq 'US' and $zip =~ /^(\d{5})/ and $zip = $1;

#::logDebug("calling with: " . join("|", $mode, $origin, $zip, $weight, $country));
 my $cache;
 my $cache_code;
 my $db;
 my $now;
 my $updated;
 my %cline;
 my $shipping;
 my $zone;
 my $error;

 my $ctable = $opt->{cache_table} || 'ups_cache';


 if($Vend::Database{$ctable}) {
   $Vend::WriteDatabase{$ctable} = 1;
   CACHE: {
     $db = dbref($ctable)
       or last CACHE;
     my $tname = $db->name();
     $cache = 1;
     %cline = (
       weight => $weight,
       origin => $origin,
       country => $country,
       zip  => $zip,
       shipmode => $mode,
     );

     my @items;
     # reverse sort makes zip first
     for(reverse sort keys %cline) {
       push @items, "$_ = " . $db->quote($cline{$_}, $_);
     }

     my $string = join " AND ", @items;
     my $q = qq{SELECT code,cost,updated from $tname WHERE $string};
     my $ary = $db->query($q);
     if($ary and $ary->[0] and $cache_code = $ary->[0][0]) {
       $shipping = $ary->[0][1];
       $updated = $ary->[0][2];
       $now = time();
       if($now - $updated > 86000) {
         undef $shipping;
         $updated = $now;
       }
       elsif($shipping <= 0) {
         $error = $shipping;
         $shipping = 0;
       }
     }
   }
 }

 my $w = $weight;
 my $maxcost;
 my $tmpcost;

 unless(defined $shipping) {
   $shipping = 0;
   while($w > $modulo) {
     $w -= $modulo;
     if($maxcost) {
       $shipping += $maxcost;
       next;
     }

     ($maxcost, $zone, $error) = getUPS( $mode, $origin, $zip, $modulo, $country);
     if($error) {
       $Vend::Session->{ship_message} .= " $mode: $error";
       return 0;
     }
     $shipping += $maxcost;
   }

   undef $error;
   ($tmpcost, $zone, $error) = getUPS( $mode, $origin, $zip, $w, $country);

   $shipping += $tmpcost;
   if($cache and $shipping) {
     $cline{updated} = $now || time();
     $cline{cost} = $shipping || $error;
     $db->set_slice($cache_code, \%cline);
   }
 }

 if($error) {
   $Vend::Session->{ship_message} .= " $mode: $error";
   return 0;
 }
 return $shipping;
}
EOR

UserTag  ups-query  Documentation <<EOD

=head1 NAME

ups-query tag -- calculate UPS costs via www

=head1 SYNOPSIS

 [ups-query
    weight=NNN
    origin=45056*
    zip=61821*
    country=US*
    mode=MODE
    aggregate=N*
 ]
 
=head1 DESCRIPTION

Calculates UPS costs via the WWW using Business::UPS.

Options:

=over 4

=item weight

Weight in pounds. (required)

=item mode

Any valid Business::UPS mode (required). Example: 1DA,2DA,GNDCOM

=item origin

Origin zip code. Default is $Variable->{UPS_ORIGIN}.

=item zip

Destination zip code. Default $Values->{zip}.

=item country

Destination country. Default $Values->{country}.

=item aggregate

If 1, aggregates by a call to weight=150 (or $Variable->{UPS_QUERY_MODULO}).
Multiplies that times number necessary, then runs a call for the
remainder. In other words:

 [ups-query weight=400 mode=GNDCOM aggregate=1]

is equivalent to:

 [calc]
   [ups-query weight=150 mode=GNDCOM] + 
   [ups-query weight=150 mode=GNDCOM] + 
   [ups-query weight=100 mode=GNDCOM];
 [/calc]

If set to a number above 10, will be the modulo to do repeated calls by. So:

 [ups-query weight=400 mode=GNDCOM aggregate=100]

is equivalent to:

 [calc]
   [ups-query weight=100 mode=GNDCOM] + 
   [ups-query weight=100 mode=GNDCOM] + 
   [ups-query weight=100 mode=GNDCOM] + 
   [ups-query weight=100 mode=GNDCOM];
 [/calc]

=item cache_table

Set to the name of a table (default ups_cache) which can cache the
calls so repeated calls for the same values will not require repeated
calls to UPS.

Table needs to be set up with:

 Database   ups_cache        ship/ups_cache.txt         __SQLDSN__
 Database   ups_cache        AUTO_SEQUENCE  ups_cache_seq
 Database   ups_cache        DEFAULT_TYPE varchar(12)
 Database   ups_cache        INDEX  weight origin zip shipmode country

And have the fields:

  code weight origin zip country shipmode cost updated

Typical cached data will be like:

 code  weight  origin  zip  country  shipmode  cost  updated
 14  11  45056  99501  US  2DA  35.14  1052704130
 15  11  45056  99501  US  1DA  57.78  1052704130
 16  11  45056  99501  US  2DA  35.14  1052704132
 17  11  45056  99501  US  1DA  57.78  1052704133

Cache expires in one day.

=back

EOD

SEE ALSO


Name

user-merge

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: UI_USER_MERGE_USER_TABLE, UI_USER_MERGE_TABLES

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

user-merge is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/user_merge.tag
Lines: 215


# Copyright 2005-2009 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: user_merge.tag,v 1.4 2009-05-20 23:37:27 pajamian Exp $

UserTag user-merge Order from to
UserTag user-merge addAttr
UserTag user-merge Description Merges users based on order number or username
UserTag user-merge Routine <<EOR
sub {
my ($from, $to, $opt) = @_;

#::logDebug("Called user merge");
use vars qw/$Tag $CGI/;

my $err = sub {
  my $msg = errmsg(@_);
  logError($msg);
  $Tag->error({ name => 'order merge', set => $msg });
  return undef;
};

unless($Vend::admin) {
  return $err->("Only admin can merge records.");
}

unless($Vend::superuser) {
  return $err->("Only admin can merge records.")
    unless $Tag->if_mm('advanced', 'merge_users');
}

$from ||= $CGI->{item_id};
$to ||= $CGI->{item_radio};
my $table = $opt->{table} || $CGI->{mv_data_table};


if($opt->{from_user} or $opt->{from_order}) {
  ## We are told what to do
}
elsif($table eq 'userdb') {
  $opt->{from_user} = 1;
}
elsif ($table eq 'transactions') {
$opt->{from_order} = 1;
}
else {
return $err->("Unable to determine what to do, no table or from_user...");
}

my $ufield = $opt->{user_field} || 'username';
my $ofield = $opt->{order_field} || 'order_number';

my $utab = $opt->{user_table} || $::Variable->{UI_USER_MERGE_USER_TABLE} || 'userdb';
my $ttabs = $opt->{merge_tables} || $::Variable->{UI_USER_MERGE_TABLES} \
 \
 \
 || 'transactions orderline';

my @ttab = grep /\w/, split /[\s,\0]+/, $ttabs;

my %kfield;
my %sth;
my %dbh;
my %dbr;
my %query;

for(@ttab) {
  my ($t, $f) = split /[=:]+/, $_, 2;
  $_ = $t;
  $kfield{$t} = $f || $ufield;
}

my $tdb = dbref($ttab[0])
  or return $err->("No %s table.", $ttab[0]);
my $udb = dbref($utab)
  or return $err->("No %s table.", $utab);

for(@ttab) {
  my $db = $dbr{$_} = dbref($_)
    or return $err->("Unable to open '%s' table for merge.", $_);
  my $dbh = $dbh{$_} = $db->dbh();
  $query{$_} = "update $_ set $kfield{$_} = ? where $kfield{$_} = ?"; 
  $sth{$_} = $dbh->prepare($query{$_}) 
    or return $err->("Unable to prepare statement '%s' for merge.", $query{$_});
}

my $to_user = $to;

if($opt->{from_order}) {
  $to_user = $tdb->field($to, $ufield);
}

my $urec = $udb->row_hash($to_user)
  or return $err->("%s does not exist, cannot merge to that user.", $to_user);

my @from;

if(ref($from) eq 'ARRAY') {
  @from = @$from;
}
else {
  @from = split /\0/, $from;
}

my %from_user;

if($opt->{from_order}) {
  my @to;
  for(@from) {
    my $okey = $tdb->foreign($_, $ofield);
    my $user = $tdb->field($okey, $ufield);
    push @to, $user;
  }
  @from = @to;
}

for(@from) {
  next if $_ eq $to_user;
  unless($from_user{$_} or $udb->field($_, 'username')) {
    $err->("User '%s' does not exist.", $_);
    next;
  }
  $from_user{$_}++;
}

my $cart_hash = string_to_ref($urec->{carts});
my $carts_changed;

my @users = sort keys %from_user;

my @record;
@record = @users;

my $logfile = $opt->{logfile} || 'logs/merged_users.log';
my $done_one;
my $save_rec;

for my $user (@users) {
  $Tag->log({ type => 'text', file => $logfile, body => $Tag->time() . "\n" } )
    unless $done_one++;

  my $from_urec = $udb->row_hash($user);

  # If there's a user_merge specialsub run it here
  if (my $subname = $Vend::Cfg->{SpecialSub}{user_merge}) {
    my $sub = $Vend::Cfg->{Sub}{$subname} || $Global::GlobalSub->{$subname};
    my $status;
    eval { $status = $sub->($user, $from_urec, $to_user, $urec, $udb, $tdb) };
    if ($@) {
      ::logError("Error running %s subroutine %s: %s", 'user_merge', $subname, $@);
    }

    elsif ($status) {
      # Skip further processing of this user
      next;
    }

    else {
      $save_rec = 1;
    }
  }

  for(@ttab) {
    $sth{$_}->execute($to_user, $user)
      or $err->("%s update failed: %s", $_, $dbh{$_}->errstr);
    my $o = $query{$_};
    $o =~ s/\?/$to_user/;
    $o =~ s/\?/$user/;
    push @record, $o;
  }

  my $chash = string_to_ref($from_urec->{carts});
  if(ref $chash) {
    for(keys %$chash) {
      if($cart_hash->{$_}) {
        $Tag->log({ type => 'text', file => $logfile, body => "unable \
 to merge cart=$_ (already exists). Contents=$from_urec->{carts}\n"} );
      }
      else {
        $cart_hash->{$_} = $chash->{$_};
        $carts_changed++;
      }
    }
  }
  my $ustring = ::uneval($from_urec);
  $Tag->log({ type => 'text', file => $logfile, body => "delete user $user=$ustring\n"} );
  $udb->delete_record($user)
    unless $opt->{no_delete};
  push @record, "delete user $user" unless $opt->{no_delete};
}

if($carts_changed) {
  if ($save_rec) {
    $urec->{carts} = ::uneval($cart_hash);
  }

  else {
    $udb->set_field($to, 'carts', ::uneval($cart_hash));
  }
}

if ($save_rec) {
  delete $urec->{$udb->[$Vend::Table::DBI::KEY]};
  $udb->set_slice($to, $urec);
}

push @record, '';

$Tag->log({ type => 'text', file => $logfile, body => join("\n", @record)} );
::logDebug(join("\n", @record)) if $opt->{debug};
return 1 unless $opt->{hide};
return '';
}
EOR


SEE ALSO


Name

userdb — access user database functions

ATTRIBUTES

AttributePos.Req.DefaultDescription
function Yes Yes
profile default UserDB profile
db | table
nickname | nick
show_message 0 whether to return message (success or error)
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

userdb provides access to UserDB functions.

Create New Account

[userdb new_account] registers a new account.

Logout function

[userdb logout] performs log out operation on the current user account:

[userdb logout]

Usually, data stored in the session should be removed at the same time:

[userdb function=logout clear=1]
[userdb function=logout clear_session=1]
[userdb function=logout clear_cookie="MV_PASSWORD"]

clear=1 resets all value and scratch variables initialized by the UserDB.

clear_session=1 forces the creation of an entirely new session for the user.

clear_cookie="NAME" expires the cookie NAME.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Save cart

[userdb function=set_cart nickname=basket]

Example: Restore cart

[userdb function=get_cart nickname=basket]

NOTES

AVAILABILITY

userdb is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/userdb.coretag
Lines: 16


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: userdb.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag userdb              Order        function
UserTag userdb              addAttr
UserTag userdb              attrAlias    table db
UserTag userdb              attrAlias    name nickname
UserTag userdb              PosNumber    1
UserTag userdb              Version      $Revision: 1.5 $
UserTag userdb              MapRoutine   Vend::UserDB::userdb

Source: lib/Vend/UserDB.pm
Lines: 2553

sub userdb {
my $function = shift;
my $opt = shift;

my %options;

if(ref $opt) {
  %options = %$opt;
}
else {
  %options = ($opt, @_);
}

my $status = 1;
my $user;

my $module = $Vend::Cfg->{UserControl} ? 'Vend::UserControl' : 'Vend::UserDB';

if($function eq 'login') {
  $Vend::Session->{logged_in} = 0;
  delete $Vend::Session->{username};
  delete $Vend::Session->{groups};
  undef $Vend::username;
  undef $Vend::groups;
  undef $Vend::admin;
  $user = $module->new(%options);
  unless (defined $user) {
    $Vend::Session->{failure} = errmsg("Unable to access user database.");
    return undef;
  }
  if ($status = $user->login(%options) ) {
    if( $Vend::ReadOnlyCfg->{AdminUserDB}{$user->{PROFILE}} ) {
      $Vend::admin = 1;
    }
    ::update_user();
  }
}
elsif($function eq 'new_account') {
  $user = $module->new(%options);
  unless (defined $user) {
    $Vend::Session->{failure} = errmsg("Unable to access user database.");
    return undef;
  }
  $status = $user->new_account(%options);
  if($status and ! $options{no_login}) {
    $Vend::Session->{logged_in} = 1;
    $Vend::Session->{username} = $user->{USERNAME};
  }
}
elsif($function eq 'logout') {
  $user = $module->new(%options)
    or do {
      $Vend::Session->{failure} = errmsg("Unable to create user object.");
      return undef;
    };
  $user->logout();
}
elsif (! $Vend::Session->{logged_in}) {
  $Vend::Session->{failure} = errmsg("Not logged in.");
  return undef;
}
elsif($function eq 'save') {
  $user = $module->new(%options);
  unless (defined $user) {
    $Vend::Session->{failure} = errmsg("Unable to access user database.");
    return undef;
  }
  $status = $user->set_values();
}
elsif($function eq 'load') {
  $user = $module->new(%options);
  unless (defined $user) {
    $Vend::Session->{failure} = errmsg("Unable to access user database.");
    return undef;
  }
  $status = $user->get_values();
}
else {
  $user = $module->new(%options);
  unless (defined $user) {
    $Vend::Session->{failure} = errmsg("Unable to access user database.");
    return undef;
  }
  eval {
    $status = $user->$function(%options);
  };
  $user->{ERROR} = $@ if $@;
}

if(defined $status) {
  delete $Vend::Session->{failure};
  $Vend::Session->{success} = $user->{MESSAGE};
  if($options{show_message}) {
    $status = $user->{MESSAGE};
  }
}
else {
  $Vend::Session->{failure} = $user->{ERROR};
  if($options{show_message}) {
    $status = $user->{ERROR};
  }
}
return $status unless $options{hide};
return;
}


Name

usertrack — append usertrack entry with arbitrary key=value pair

ATTRIBUTES

AttributePos.Req.DefaultDescription
tag YesYes Key name
value Yes  Key value
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag is used to append content to the line that will be inserted into user tracking log.

Key/value pairs are added to the line in "GET"-like style. See the section called “EXAMPLES”.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Basic example

Put each of the two lines anywhere on a page:

[usertrack HELLO WORLD]

[usertrack tag=test_var value=test_value]

Example: Recording the number of cart items each time the user visits the index page

Put the following in index.html:

[usertrack tag=nitems value="[nitems]"]

NOTES

User tracking must be enabled for this tag to produce any noticeable effect.

usertrack does not work on special pages.

AVAILABILITY

usertrack is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/usertrack.tag
Lines: 12


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: usertrack.tag,v 1.5 2007-03-30 23:40:57 pajamian Exp $

UserTag usertrack Order   tag value
UserTag usertrack Version $Revision: 1.5 $
UserTag usertrack Routine sub { $Vend::Track->user(@_) if $Vend::Track; }


Name

usps-query

ATTRIBUTES

AttributePos.Req.DefaultDescription
weight Yes
service Yes
origin
destination
userid
passwd
url
container
machinable
size
country
mailtype
modulo
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: USPS_ORIGIN, SHIP_DEFAULT_ZIP, USPS_ID, USPS_PASSWORD, USPS_URL, USPS_CONTAINER, USPS_MACHINABLE, USPS_SIZE, USPS_MAILTYPE, USPS_MODULO

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

usps-query is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/usps_query.tag
Lines: 394


# Copyright 2002-2009 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag  usps-query  Order   service weight
UserTag  usps-query  addAttr
UserTag  usps-query  Version 1.10
UserTag  usps-query  Routine <<EOR

sub {
   my ($service, $weight, $opt) = @_;
   my ($rate, $resp, $xml, $mailtype, @intl, $m_rep, $m_mod);
   my %supported_services = (
           'EXPRESS'     => 1,
           'FIRST CLASS' => 1,
           'PRIORITY'    => 1,
           'PARCEL'      => 1,
           'BPM'         => 1,
           'LIBRARY'     => 1,
           'MEDIA'       => 1,
           'GLOBAL EXPRESS GUARANTEED'                              => 1,
           'GLOBAL EXPRESS GUARANTEED NON-DOCUMENT RECTANGULAR'     => 1,
           'GLOBAL EXPRESS GUARANTEED NON-DOCUMENT NON-RECTANGULAR' => 1,
           'USPS GXG ENVELOPES'                                     => 1,
           'EXPRESS MAIL INTERNATIONAL (EMS)'                       => 1,
           'EXPRESS MAIL INTERNATIONAL (EMS) FLAT-RATE ENVELOPE'    => 1,
           'PRIORITY MAIL INTERNATIONAL'                            => 1,
           'PRIORITY MAIL INTERNATIONAL FLAT-RATE ENVELOPE'         => 1,
           'PRIORITY MAIL INTERNATIONAL REGULAR FLAT-RATE BOXES'    => 1,
           'PRIORITY MAIL INTERNATIONAL LARGE FLAT-RATE BOX'        => 1,
           'PRIORITY MAIL INTERNATIONAL SMALL FLAT-RATE BOX'        => 1,
           'FIRST CLASS MAIL INTERNATIONAL LARGE ENVELOPE'          => 1,
           'FIRST CLASS MAIL INTERNATIONAL PACKAGE'                 => 1,
           'MATTER FOR THE BLIND - ECONOMY MAIL'            => 1,
           );
   my %package_sizes = (
      'REGULAR'  => 1,
      'LARGE'    => 1,
  'OVERSIZE' => 1,
);
my %mailtypes = (
'package'                  => 1,
'postcards or aerogrammes' => 1,
'matter for the blind'     => 1,
'envelope'                 => 1,
);

my $error_msg = 'USPS: ';
my $origin = $opt->{origin} || $::Variable->{USPS_ORIGIN} || $::Variable->{UPS_ORIGIN};
my $destination = $opt->{destination} || $::Values->{zip} || $::Variable->{SHIP_DEFAULT_ZIP};
my $userid = $opt->{userid} || $::Variable->{USPS_ID};
my $passwd = $opt->{passwd} || $::Variable->{USPS_PASSWORD};
my $url = $opt->{url} || $::Variable->{USPS_URL} || 'http://Production.ShippingAPIs.com/ShippingAPI.dll';
my $container = $opt->{container} || $::Variable->{USPS_CONTAINER} || 'None';
my $machinable = $opt->{machinable} || $::Variable->{USPS_MACHINABLE} || 'False';

$service = uc $service;
if (! $supported_services{$service}) {
$error_msg .= "unknown service type $service.";
return;
 }

 my $size = uc ($opt->{size} || $::Variable->{USPS_SIZE} || 'REGULAR');
 if (! $package_sizes{$size}) {
$error_msg .= "unknown package size $size.";
return;
}

 if ($service eq 'PARCEL') {
if ($weight < .375 or $weight > 35) {
   $machinable = 'False';
}
}

if ($opt->{country}) {
$mailtype = lc ($opt->{mailtype} || $::Variable->{USPS_MAILTYPE} || 'package');
unless ($mailtypes{$mailtype}) {
 $error_msg = "unknown mail type '$mailtype'.";
 return;
}
 }

 my $modulo = $opt->{modulo} || $::Variable->{USPS_MODULO};
 if ($modulo and ($modulo < $weight)) {
$m_rep = int $weight / $modulo;
$m_mod = $weight % $modulo;
$weight = $modulo;
   }


RATEQUOTE: {
   my $ounces = int(($weight - int($weight)) * 16);
   $weight = int $weight;
   
   if ($opt->{country}) {
       my %map = (
           q{United Kingdom} => q{Great Britain},
           q{Virgin Islands, British} => q{British Virgin Islands},
           q{Viet Nam} => q{Vietnam},
           q{Tanzania, United Republic Of} => q{Tanzania},
           q{Slovakia} => q{Slovak Republic},
           q{Serbia} => q{Serbia-Montenegro},
           q{Montenegro} => q{Serbia-Montenegro},
           q{Samoa} => q{Western Samoa},
           q{Saint Kitts And Nevis} => q{St. Christopher and Nevis},
           q{Russian Federation} => q{Russia},
           q{Pitcairn} => q{Pitcairn Island},
           q{Moldova, Republic Of} => q{Moldova},
           q{Marshall Islands} => q{Republic of the Marshall Islands},
           q{Macedonia, The Former Yugoslav R} => q{Macedonia, Republic of},
           q{Libyan Arab Jamahiriya} => q{Libya},
           q{Lao People's Democratic Republic} => q{Laos},
           q{Korea, Republic of} => q{South Korea},
           q{Iran, Islamic Republic Of} => q{Iran},
           q{Holy See (Vatican City State)} => q{Vatican City},
           q{Georgia} => q{Georgia, Republic of},
           q{Falkland Islands (Malvinas)} => q{Falkland Islands},
           q{Cote d'Ivoire (Ivory Coast)} => q{Cote d'Ivoire},
           q{Congo, The Democratic Republic O} => q{Democratic Republic of the Congo},
           q{Congo} => q{Congo, Republic of the},
           q{Bosnia And Herzegowina} => q{Bosnia-Herzegovina},
       );

       my $usps_country = $map{ $opt->{country} }
           || $opt->{country};

 $xml = qq{API=IntlRate\&XML=<IntlRateRequest USERID="$userid" PASSWORD="$passwd">};
 $xml .= <<EOXML;
 <Package ID="0">
     <Pounds>$weight</Pounds>
     <Ounces>$ounces</Ounces>
     <MailType>$mailtype</MailType>
     <Country>$usps_country</Country>
 </Package>
 </IntlRateRequest>
EOXML
   }
   else {
 $xml = qq{API=Rate\&XML=<RateRequest USERID="$userid" PASSWORD="$passwd">};
 $xml .= <<EOXML;
 <Package ID="0">
     <Service>$service</Service>
     <ZipOrigination>$origin</ZipOrigination>
     <ZipDestination>$destination</ZipDestination>
     <Pounds>$weight</Pounds>
     <Ounces>$ounces</Ounces>
     <Container>$container</Container>
     <Size>$size</Size>
     <Machinable>$machinable</Machinable>
 </Package>
 </RateRequest>
EOXML
   }

   my $ua = new LWP::UserAgent;
   my $req = new HTTP::Request 'POST', "$url";
   $req->content_type('application/x-www-form-urlencoded');
   $req->content($xml);
   my $response = $ua->request($req);

   $error_msg = 'USPS: ';
   if ($response->is_success) {
 $resp = $response->content;
   } 
   else {
 $error_msg .= 'Error obtaining rate quote from usps.com.';
   }

   if ($resp =~ /<Error>/i) {
 $resp =~ m|<Description>(.+)</Description>|;
 $error_msg .=  $1;
   }
   else {
 if ($opt->{country}) {
     @intl = split /<Service/, $resp;
     foreach (@intl) {
   m|<SvcDescription>(.+)</SvcDescription>|;
   $resp = uc $1;
   if ($resp eq $service) {
       m|<Postage>(.+)</Postage>|;
       $rate += $1;
       undef $error_msg;
       last;
   }
     }
 }
 else {
     $resp =~ m|<Postage>(.+)</Postage>|;
     $rate += $1;
     undef $error_msg;
 }
   }
}

   if ($m_rep) {
 $rate *= $m_rep; undef $m_rep;
   } 
   if ($m_mod) {
 $weight = $m_mod; undef $m_mod;
 goto RATEQUOTE;
   }

   $::Session->{ship_message} .= " $error_msg" if $error_msg;
   return $rate;
}
EOR

UserTag  usps-query  Documentation <<EOD

=head1 NAME


usps-query tag -- calculate USPS costs via www

=head1 SYNOPSIS

 [usps-query
   service="service name"
   weight="NNN"
   userid="USPS webtools user id"*
   passwd="USPS webtools password"*
   origin="NNNNN"*
   destination="NNNNN"*
   url="applet URL"*
   container="container type"*
   size="package size"*
   machinable="True/False"*
   mailtype="mailing type"*
   country="Country name"*
   modulo="NN"*
 ]
 
=head1 DESCRIPTION

Calculates USPS costs via the WWW using the United States Postal Service Rate
Rate Calculator API. You *MUST* register with USPS in order to use this service.
Visit http://www.usps.com/webtools and follow the link(s) to register. You will
receive a confirmation email upon completing the registration process. You 
*MUST* follow the instructions in this email to obtain access to the production
rate quote server. THIS USERTAG WILL NOT WORK WITH USPS's TEST SERVER.


=head1 PARAMETERS

=head2 Base Parameters (always required):


=over 4

=item service

The USPS service you wish to get a rate quote for. Services currently supported:

   EXPRESS
   FIRST CLASS
   PRIORITY
   PARCEL
   BPM
   LIBRARY
   MEDIA
   GLOBAL EXPRESS GUARANTEED
   GLOBAL EXPRESS GUARANTEED NON-DOCUMENT RECTANGULAR
   GLOBAL EXPRESS GUARANTEED NON-DOCUMENT NON-RECTANGULAR
   USPS GXG ENVELOPES
   EXPRESS MAIL INTERNATIONAL (EMS)
   EXPRESS MAIL INTERNATIONAL (EMS) FLAT-RATE ENVELOPE
   PRIORITY MAIL INTERNATIONAL
   PRIORITY MAIL INTERNATIONAL FLAT-RATE ENVELOPE
   PRIORITY MAIL INTERNATIONAL REGULAR FLAT-RATE BOXES
   PRIORITY MAIL INTERNATIONAL LARGE FLAT-RATE BOX
   PRIORITY MAIL INTERNATIONAL SMALL FLAT-RATE BOX
   FIRST CLASS MAIL INTERNATIONAL LARGE ENVELOPE
   FIRST CLASS MAIL INTERNATIONAL PACKAGE
   MATTER FOR THE BLIND - ECONOMY MAIL


=item weight

The total weight of the items to be mailed/shipped.

=item userid

Your USPS webtools userid, which was obtained by registering.
This will default to $Variable->{USPS_ID}, which is the preferred
way to set this parameter.

=item passwd

Your USPS webtools passwd, which was obtained by registering.
This will default to $Variable->{USPS_PASSWORD}, which is the 
preferred way to set this parameter.

=back

=head2 Extended Parameters (domestic and international services)


=over 4

=item url

The URL of the USPS rate quote API. The default is $Variable->{USPS_URL}
or 'http://Production.ShippingAPIs.com/ShippingAPI.dll'.

=item modulo

Enables a rudimentary method of obtaining rate quotes for multi-box shipments. 
'modulo' is a number which represents the maximum weight per box; the default 
is $Variable->{USPS_MODULO}. When modulo > 0, the shipping weight will be divided 
into the number of individual parcels of max. weight 'modulo' which will accommodate 
the whole shipment, and the total rate will be calculated accordingly. 
Example: with modulo = 10, a 34.5lbs. shipment will be calculated as 3 parcels 
weighing 10lbs. each, plus one parcel weighing 4lbs. 8oz.

=back

=head2 Extended Parameters for domestic (U.S.) services only


=over 4

=item origin

Origin zip code. Default is $Variable->{USPS_ORIGIN} or $Variable->{UPS_ORIGIN}.

=item destination

Destination zip code. Default is $Values->{zip} or $Variable->{SHIP_DEFAULT_ZIP}.

=item container

The USPS-defined container type for the shipment. Default is
Variable->{USPS_CONTAINER} or 'None". Please see the Technical Guide to the
Domestic Rates Calculator Application Programming Interface for a complete
list of container types.

=item size

The USPS-defined package size for the shipment. Valid choices are
'REGULAR', 'LARGE', and 'OVERSIZE'. The default is $Variable->{USPS_SIZE} or
'REGULAR'. Please see the Technical Guide to the Domestic Rates Calculator 
Application Programming Interface for a definition of package sizes.

=item machinable (for PARCEL service only)

Possible value are 'True' and 'False'. Indicates whether or not the shipment
qualifies for machine processing by UPS. Default is $Variable->{USPS_MACHINABLE}
or 'False". Consult the USPS service guides for more info on this subject.

=back

=head2 Extended parameters for International services only


=over 4

=item mailtype

The USPS-defined mail type for the shipment. Valid choices are:

   package
   postcards or aerogrammes
   matter for the blind
   envelope

Default is $Variable->{USPS_MAILTYPE} or 'package'. See the USPS international 
service guides for more information on this topic.

=item country (required for international services)

Destination country. No default. You must pass the name of the country, not the ISO
code or abbreviation (i.e. 'Canada', not 'CA'). Note that USPS maintains a table of
valid country names which does not necessarily match all entries in the country
table which is distributed with the standard demo, so modifications may be needed
if you intend to use USPS international services. Consult the USPS International
Services guide for more information.

=back

=head1 BUGS

We shall see....

=head1 AUTHORS

Ed LaFrance <edl@newmediaems.com>
Josh Lavin <josh@perusion.com>
Mathew Jones <mat@bibliopolis.com>

=cut
EOD

SEE ALSO


Name

value — expand to value of the UserDB variable specified in body

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

The filter expands to the value of a UserDB variable. Name of the variable is specified in filter body.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Filter example

[value name=online_value_test set="TEST VALUE" hide=1]

My test value is [filter value]online_value_test[/filter]

NOTES

In Interchange version 4.6.0, this symbol changed type from Filter to System Tag.

AVAILABILITY

value is available in Interchange versions:

4.6.0, 4.6.0, 4.8.0, 5.0.0, 5.2.0, 5.4.0, 5.6.0, 5.8.0, 5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/value.coretag
Lines: 15


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: value.coretag,v 1.7 2008-07-04 15:52:35 mheins Exp $

UserTag value               Order        name
UserTag value               addAttr
UserTag value               PosNumber    1
UserTag value               Version      $Revision: 1.7 $
UserTag value               MapRoutine   Vend::Interpolate::tag_value
UserTag evalue              Alias        value keep=1 filter="encode_entities" name=

Source: lib/Vend/Interpolate.pm
Lines: 2573

sub tag_value {
  my($var,$opt) = @_;
#::logDebug("called value args=" . uneval(\@_));
local($^W) = 0;

my $vspace = $opt->{values_space};
my $vref;
if (defined $vspace) {
  if ($vspace eq '') {
    $vref = $Vend::Session->{values};
  }
  else {
    $vref = $Vend::Session->{values_repository}{$vspace} ||= {};
  }
}
else {
  $vref = $::Values;
}

$vref->{$var} = $opt->{set} if defined $opt->{set};

my $value = defined $vref->{$var} ? $vref->{$var} : '';
$value =~ s/\[/&#91;/g unless $opt->{enable_itl};
if($opt->{filter}) {
  $value = filter_value($opt->{filter}, $value, $var);
  $vref->{$var} = $value unless $opt->{keep};
}
$::Scratch->{$var} = $value if $opt->{scratch};
return '' if $opt->{hide};
  return $opt->{default} if ! $value and defined $opt->{default};
$value =~ s/</&lt;/g unless $opt->{enable_html};
  return $value;
}

Source: lib/Vend/Interpolate.pm
Lines: 2573

sub tag_value {
  my($var,$opt) = @_;
#::logDebug("called value args=" . uneval(\@_));
local($^W) = 0;

my $vspace = $opt->{values_space};
my $vref;
if (defined $vspace) {
  if ($vspace eq '') {
    $vref = $Vend::Session->{values};
  }
  else {
    $vref = $Vend::Session->{values_repository}{$vspace} ||= {};
  }
}
else {
  $vref = $::Values;
}

$vref->{$var} = $opt->{set} if defined $opt->{set};

my $value = defined $vref->{$var} ? $vref->{$var} : '';
$value =~ s/\[/&#91;/g unless $opt->{enable_itl};
if($opt->{filter}) {
  $value = filter_value($opt->{filter}, $value, $var);
  $vref->{$var} = $value unless $opt->{keep};
}
$::Scratch->{$var} = $value if $opt->{scratch};
return '' if $opt->{hide};
  return $opt->{default} if ! $value and defined $opt->{default};
$value =~ s/</&lt;/g unless $opt->{enable_html};
  return $value;
}


Name

value-extended — Expand value

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Name of variable.
values_space
yes 1 Return value on success.
no Return value on failure.
test
put_contents
enable_html
enable_itl
file_contents Returns file contents from a upload field.
put_ref
outfile File name for output file.
encoding Encoding for output file (UTF-8, raw).
auto_create_dir  0Auto-create directories in the file path?
umask    File creation umask.
ascii
maxsize Maximum size of uploaded file.
joiner
'index'
elements
filter
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

value-extended can be used for a number of tasks related to user input:

  • Manipulate files uploaded by the user.

  • Output variables from value space.

  • Perform a test.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Test for uploaded file

[value-extended name="picture" 
	test="isfile" 
	yes="Your picture has been uploaded."
	no="Please upload your picture!"
]

NOTES

AVAILABILITY

value-extended is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/value_extended.coretag
Lines: 14


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: value_extended.coretag,v 1.5 2007-03-30 23:40:49 pajamian Exp $

UserTag value-extended      Order        name
UserTag value-extended      addAttr
UserTag value-extended      PosNumber    1
UserTag value-extended      Version      $Revision: 1.5 $
UserTag value-extended      MapRoutine   Vend::Interpolate::tag_value_extended

Source: lib/Vend/Interpolate.pm
Lines: 2387

sub tag_value_extended {
  my($var, $opt) = @_;

my $vspace = $opt->{values_space};
my $vref;
if (defined $vspace) {
  if ($vspace eq '') {
    $vref = $Vend::Session->{values};
  }
  else {
    $vref = $Vend::Session->{values_repository}{$vspace} ||= {};
  }
}
else {
  $vref = $::Values;
}

my $yes = $opt->{yes} || 1;
my $no = $opt->{'no'} || '';

if($opt->{test}) {
  $opt->{test} =~ /(?:is)?put/i
    and
    return defined $CGI::put_ref ? $yes : $no;
  $opt->{test} =~ /(?:is)?file/i
    and
    return defined $CGI::file{$var} ? $yes : $no;
  $opt->{test} =~ /defined/i
    and
    return defined $CGI::values{$var} ? $yes : $no;
  return length $CGI::values{$var}
    if $opt->{test} =~ /length|size/i;
  return '';
}

if($opt->{put_contents}) {
  return undef if ! defined $CGI::put_ref;
  return $$CGI::put_ref;
}

my $val = $CGI::values{$var} || $vref->{$var} || return undef;
$val =~ s/</&lt;/g unless $opt->{enable_html};
$val =~ s/\[/&#91;/g unless $opt->{enable_itl};

if($opt->{file_contents}) {
  return '' if ! defined $CGI::file{$var};
  return $CGI::file{$var};
}

if($opt->{put_ref}) {
  return $CGI::put_ref;
}

if($opt->{outfile}) {
  my $file = $opt->{outfile};
  $file =~ s/^\s+//;
  $file =~ s/\s+$//;

  unless (Vend::File::allowed_file($file)) {
    Vend::File::log_file_violation($file, 'value-extended');
    return '';
  }

  if($opt->{ascii}) {
    my $replace = $^O =~ /win32/i ? "\r\n" : "\n";
    if($CGI::file{$var} !~ /\n/) {
      # Must be a mac file.
      $CGI::file{$var} =~ s/\r/$replace/g;
    }
    elsif ( $CGI::file{$var} =~ /\r\n/) {
      # Probably a PC file
      $CGI::file{$var} =~ s/\r\n/$replace/g;
    }
    else {
      $CGI::file{$var} =~ s/\n/$replace/g;
    }
  }
  if($opt->{maxsize} and length($CGI::file{$var}) > $opt->{maxsize}) {
    logError(
      "Uploaded file write of %s bytes greater than maxsize %s. Aborted.",
      length($CGI::file{$var}),
      $opt->{maxsize},
    );
    return $no;
  }
#::logDebug(">$file \$CGI::file{$var}" . uneval($opt));
  $opt->{encoding} ||= $CGI::file_encoding{$var};
  Vend::Util::writefile(">$file", \$CGI::file{$var}, $opt)
    and return $yes;
  return $no;
}

my $joiner;
if (defined $opt->{joiner}) {
  $joiner = $opt->{joiner};
  if($joiner eq '\n') {
    $joiner = "\n";
  }
  elsif($joiner =~ m{\\}) {
    $joiner = $ready_safe->reval("qq{$joiner}");
  }
}
else {
  $joiner = ' ';
}

my $index = defined $opt->{'index'} ? $opt->{'index'} : '*';

$index = '*' if $index =~ /^\s*\*?\s*$/;

my @ary;
if (!ref $val) {
  @ary = split /\0/, $val;
}
elsif($val =~ /ARRAY/) {
  @ary = @$val;
}
else {
  logError( "value-extended %s: passed non-scalar, non-array object", $var);
}

return join " ", 0 .. $#ary if $opt->{elements};

eval {
  @ary = @ary[$ready_safe->reval( $index eq '*' ? "0 .. $#ary" : $index )];
};
logError("value-extended $var: bad index") if $@;

if($opt->{filter}) {
  for(@ary) {
    $_ = filter_value($opt->{filter}, $_, $var);
  }
}
return join $joiner, @ary;
}


Name

value_extended

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

value_extended is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: lib/Vend/Interpolate.pm
Lines: 2387

sub tag_value_extended {
  my($var, $opt) = @_;

my $vspace = $opt->{values_space};
my $vref;
if (defined $vspace) {
  if ($vspace eq '') {
    $vref = $Vend::Session->{values};
  }
  else {
    $vref = $Vend::Session->{values_repository}{$vspace} ||= {};
  }
}
else {
  $vref = $::Values;
}

my $yes = $opt->{yes} || 1;
my $no = $opt->{'no'} || '';

if($opt->{test}) {
  $opt->{test} =~ /(?:is)?put/i
    and
    return defined $CGI::put_ref ? $yes : $no;
  $opt->{test} =~ /(?:is)?file/i
    and
    return defined $CGI::file{$var} ? $yes : $no;
  $opt->{test} =~ /defined/i
    and
    return defined $CGI::values{$var} ? $yes : $no;
  return length $CGI::values{$var}
    if $opt->{test} =~ /length|size/i;
  return '';
}

if($opt->{put_contents}) {
  return undef if ! defined $CGI::put_ref;
  return $$CGI::put_ref;
}

my $val = $CGI::values{$var} || $vref->{$var} || return undef;
$val =~ s/</&lt;/g unless $opt->{enable_html};
$val =~ s/\[/&#91;/g unless $opt->{enable_itl};

if($opt->{file_contents}) {
  return '' if ! defined $CGI::file{$var};
  return $CGI::file{$var};
}

if($opt->{put_ref}) {
  return $CGI::put_ref;
}

if($opt->{outfile}) {
  my $file = $opt->{outfile};
  $file =~ s/^\s+//;
  $file =~ s/\s+$//;

  unless (Vend::File::allowed_file($file)) {
    Vend::File::log_file_violation($file, 'value-extended');
    return '';
  }

  if($opt->{ascii}) {
    my $replace = $^O =~ /win32/i ? "\r\n" : "\n";
    if($CGI::file{$var} !~ /\n/) {
      # Must be a mac file.
      $CGI::file{$var} =~ s/\r/$replace/g;
    }
    elsif ( $CGI::file{$var} =~ /\r\n/) {
      # Probably a PC file
      $CGI::file{$var} =~ s/\r\n/$replace/g;
    }
    else {
      $CGI::file{$var} =~ s/\n/$replace/g;
    }
  }
  if($opt->{maxsize} and length($CGI::file{$var}) > $opt->{maxsize}) {
    logError(
      "Uploaded file write of %s bytes greater than maxsize %s. Aborted.",
      length($CGI::file{$var}),
      $opt->{maxsize},
    );
    return $no;
  }
#::logDebug(">$file \$CGI::file{$var}" . uneval($opt));
  $opt->{encoding} ||= $CGI::file_encoding{$var};
  Vend::Util::writefile(">$file", \$CGI::file{$var}, $opt)
    and return $yes;
  return $no;
}

my $joiner;
if (defined $opt->{joiner}) {
  $joiner = $opt->{joiner};
  if($joiner eq '\n') {
    $joiner = "\n";
  }
  elsif($joiner =~ m{\\}) {
    $joiner = $ready_safe->reval("qq{$joiner}");
  }
}
else {
  $joiner = ' ';
}

my $index = defined $opt->{'index'} ? $opt->{'index'} : '*';

$index = '*' if $index =~ /^\s*\*?\s*$/;

my @ary;
if (!ref $val) {
  @ary = split /\0/, $val;
}
elsif($val =~ /ARRAY/) {
  @ary = @$val;
}
else {
  logError( "value-extended %s: passed non-scalar, non-array object", $var);
}

return join " ", 0 .. $#ary if $opt->{elements};

eval {
  @ary = @ary[$ready_safe->reval( $index eq '*' ? "0 .. $#ary" : $index )];
};
logError("value-extended $var: bad index") if $@;

if($opt->{filter}) {
  for(@ary) {
    $_ = filter_value($opt->{filter}, $_, $var);
  }
}
return join $joiner, @ary;
}

SEE ALSO


Name

values-space — switch between value namespaces

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Switch namespace. Empty value (name="") switches back to the main namespace.
copy-all   0 Copy all values from the current namespace to the new one before switching to it? (dereference on nested data structures is not performed).
copy     Copy only specified, space-separated values.
clear   0 Clear all values in the target namespace before switching to it?
show   0 Return name of the current namespace, then switch to a new one?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag switches the values namespace for the duration of the page. To switch back to the default namespace, use [values-space name=''].

The current namespace is kept in the $Vend::ValuesSpace variable.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Switch and display namespaces

Current namespace is: [values-space] 
Switching to namespace 'basket': [values-space basket]
Switching [values-space name=checkout show=1 clear=1] to clear [values-space]

NOTES

AVAILABILITY

values-space is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/values_space.tag
Lines: 49


# Copyright 2004-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: values_space.tag,v 1.5 2007-03-30 23:40:57 pajamian Exp $

UserTag values-space Order   name
UserTag values-space addAttr
UserTag values-space Version $Revision: 1.5 $
UserTag values-space Routine <<EOR
sub {
my ($name, $opt) = @_;
return $Vend::ValuesSpace unless defined $name;

my $old_name = $Vend::ValuesSpace;
my $old_ref;
if ($old_name eq '') {
  $old_ref = $Vend::Session->{values};
}
else {
  $old_ref = $Vend::Session->{values_repository}{$old_name} ||= {};
}

if ($name eq '') {
  $::Values = $Vend::Session->{values};
}
else {
  $::Values = $Vend::Session->{values_repository}{$name} ||= {};
}
$Vend::ValuesSpace = $name;

%$::Values = () if $opt->{clear};

my @copy;
if ($opt->{copy_all}) {
  @copy = keys %$old_ref;
}
elsif ($opt->{copy}) {
  @copy = grep /\S/, split / /, $opt->{copy};
}
$::Values->{$_} = $old_ref->{$_} for @copy;

#Debug("changed values space from $old_name to $name; new contents:\n" . ::uneval($::Values));
return $opt->{show} ? $old_name : '';
}
EOR


Name

var — access local (catalog) and global Interchange variables

ATTRIBUTES

AttributePos.Req.DefaultDescription
name YesYes Name of the Interchange variable to display.
global Yes  Empty value only looks for a catalog variable. Value of 1 looks only for a global variable. Value of 2 looks for the catalog variable with the fallback to global, if local one is not defined.
filter   None. filter to apply.
interpolate   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

This tag gives access to Interchange global or catalog variables. Direct access to variables (using the __VAR__ syntax) is faster, so you should only use this tag where the direct access is impossible.

Here's the equivalence list:

[var VAR] == __VAR__
[var VAR 1] == @@VAR@@
[var VAR 2] == @_VAR_@

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Pragmas: <pragma>dynamic_variables</pragma>

EXAMPLES

Example: Direct access equivalence example

Note that the following two lines are identical in effect:

[image  src="[var IMAGE_DIR]/items/[cgi item_id]" border=0 extra="id='item_img'"]
[image  src="__IMAGE_DIR__/items/[cgi item_id]" border=0 extra="id='item_img'"]

NOTES

AVAILABILITY

var is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/var.tag
Lines: 34


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: var.tag,v 1.12 2007-03-30 23:40:57 pajamian Exp $

UserTag var Order         name global filter
UserTag var Interpolate   1
UserTag var Version       $Revision: 1.12 $
UserTag var Routine       <<EOR
sub {
my ($key, $global, $filter) = @_;
my $value;
if ($global and $global != 2) {
$value = $Global::Variable->{$key};
}
elsif ($Vend::Session->{logged_in} and defined $Vend::Cfg->{Member}{$key}) {
$value = $Vend::Cfg->{Member}{$key};
}
else {
$value = (
  $::Pragma->{dynamic_variables}
  ? Vend::Interpolate::dynamic_var($key)
  : $::Variable->{$key}
);
$value ||= $Global::Variable->{$key} if $global;
}
$value = filter_value($filter, $value, $key) if $filter;
return $value;
}
EOR


Name

version — print all sorts of Interchange-related system information

ATTRIBUTES

AttributePos.Req.DefaultDescription
extended Yes 0 Print extended version report?
joiner <br> Record/line separator.
global_error 0 Print location of the global (Interchange) error file?
local_error 0 Print location of the local (catalog) error file? (The filename is provided as a hyperlink).
env 0 Print environment variable names? (the environment variables specified in Environment).
safe 0 Print SafeUntrap value?
child_pid 0 Print child process PID?
modtest | module_test | moduletest | require Test for availability of the specified Perl module.
pid 0 Print parent PID?
mode 0 Print Interchange ic run mode?
uid 0 Print Interchange process username and numerical ID?
global_locale_options 0 Print locale information? (Available locale codes and language names)
perl 0 Print Perl information? (Perl version and the location of the Perl binary)
perl_config 0 Print Perl config information? (output of the Config::myconfig() function)
hostname 0 Print hostname?
modules 0 Print modules information? (List of Interchange-related modules found and their installed versions. For optional modules, print why one would want to have them).
db 1, if none of the above options were set Print database information?
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag produces all sorts of system information that is in some relation to Interchange.

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: UI_BASE

EXAMPLES

Example: Invoking the tag with the full set of options

[version
  extended=1
  global_error=1
  local_error=1
  env=1
  safe=1
  pid=1
  child_pid=1
  mode=1
  uid=1
  global_locale_options=1
  perl=1
  perl_config=1
  hostname=1
  db=1
  modules=1
  modtest=DBI
]

NOTES

AVAILABILITY

version is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/version.coretag
Lines: 233


# Copyright 2002-2016 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag version Order      extended
UserTag version attrAlias  module_test modtest
UserTag version attrAlias  moduletest modtest
UserTag version attrAlias  require modtest
UserTag version addAttr
UserTag version Version    1.16
UserTag version Routine    <<EOR
sub {
return $::VERSION unless shift;
my $opt = shift;
my $joiner = $opt->{joiner} || "<br$Vend::Xtrailer>";
my @out;
my $done_something;

if($opt->{global_error}) {
push @out, $Global::ErrorFile;
$done_something = 1;
}

if($opt->{local_error}) {
my $dfn = my $fn = $Vend::Cfg->{ErrorFile};
my $pre = $Global::Catalog{$Vend::Cat}->{dir} . '/';
$fn =~ s:^\Q$pre\E::;
my $href = $Tag->area("$::Variable->{UI_BASE}/do_view", $fn);
push(@out, qq{<a href="$href">$dfn</a>});
$done_something = 1;
}

if($opt->{env}) {
  push @out,
    ref $Global::Environment eq 'ARRAY' ?
    join ' ', @{$Global::Environment} :
    '(none)';
  $done_something = 1;
}

if($opt->{safe}) {
  push @out, join " ", @{$Global::SafeUntrap};
  $done_something = 1;
}

if($opt->{child_pid}) {
  push @out, $$;
  $done_something = 1;
}

if($opt->{modtest}) {
  eval "require $opt->{modtest}";
  if($@) {
    push @out, 0;
  }
  else {
    push @out, 1;
  }
  $done_something = 1;
}

if($opt->{pid}) {
  push @out, ::readfile($Global::PIDfile);
  $done_something = 1;
}

if($opt->{mode}) {
  push @out, Vend::Server::server_start_message('%s', 1);
  $done_something = 1;
}

if($opt->{uid}) {
  push @out, scalar getpwuid($>) . " (uid $>)";
  $done_something = 1;
}

if($opt->{global_locale_options}) {
  my @loc;
  my $curr = $Global::Locale;
  
  while ( my($k,$v) = each %$Global::Locale_repository ) {
    next unless $k =~ /_/;
    push @loc, "$v->{MV_LANG_NAME}~:~$k=$v->{MV_LANG_NAME}";
  }
  if(@loc > 1) {
    push @out, join ",", map { s/.*~:~//; $_ } sort @loc;
  }
  $done_something = 1;
}

if($opt->{perl}) {
  push @out, ($^V ? sprintf("%vd", $^V) : $]) . errmsg(" (called with: %s)", $^X);
  $done_something = 1;
}

if($opt->{perl_config}) {
  require Config;
  push @out, "<pre>\n" . Config::myconfig() . "</pre>";
  $done_something = 1;
}

if($opt->{hostname}) {
  require Sys::Hostname;
  push @out, Sys::Hostname::hostname()
    || errmsg("unable to determine hostname");
  $done_something = 1;
}

if(not $opt->{db} || $opt->{modules} || $done_something) {
  $opt->{db} = 1;
  push @out, "Interchange Version $::VERSION";
  push @out, "";
}

if($opt->{db}) {
  if($Global::GDBM) {
    push @out, errmsg('%s available (v%s)', 'GDBM', $GDBM_File::VERSION);
  }
  else {
    push @out, errmsg('No %s.', 'GDBM');
  }
  if($Global::DB_File) {
    push @out, errmsg('%s available (v%s)', 'Berkeley DB_File', $DB_File::VERSION);
  }
  else {
    push @out, errmsg('No %s.', 'Berkeley DB_File');
  }
  if($Global::LDAP) {
    push @out, errmsg('%s available (v%s)', 'LDAP', $Net::LDAP::VERSION);
  }
  if($Global::DBI and $DBI::VERSION) {
    push @out, errmsg ('DBI enabled (v%s), available drivers:', $DBI::VERSION);
    my $avail = join $joiner, DBI->available_drivers;
    push @out, "<blockquote>$avail</blockquote>";
  }
}

if($opt->{modules}) {
  my @wanted = qw/
    Archive::Tar
    Archive::Zip
    Business::UPS
    Compress::Zlib
    Crypt::Random
    Crypt::SSLeay
    DBI
    Digest::Bcrypt
    Digest::MD5
    Digest::SHA
    Image::Size
    LWP::Simple
    MIME::Base64
    Safe::Hole
    Set::Crontab
    Spreadsheet::ParseExcel
    Spreadsheet::WriteExcel
    Storable
    Tie::ShadowHash
    Tie::Watch
    URI::URL
  /;
  my %l_than;
  my %g_than;
  my %info = (
    'Archive::Tar' => q{Only needed for supplementary UserTag definitions.},
    'Archive::Zip' => q{Only needed for supplementary UserTag definitions.},
    'Business::UPS' => q{Enables lookup of shipping costs directly from www.ups.com.},
    'Compress::Zlib' => q{Only needed for supplementary UserTag definitions.},
    'Crypt::Random' => q{Used for UserDB bcrypt password hashing.},
    'Crypt::SSLeay' => q{Payment interface links via HTTPS/SSL.},
    'DBI' => q{Most people want to use SQL with Interchange, and this \
 is a requirement.  You will also need the appropriate DBD module, \
 i.e. DBD::mysql to support MySQL.},
    'Digest::Bcrypt' => q{Used for UserDB bcrypt password hashing.},
    'Digest::MD5' => q{IMPORTANT: cache keys and other search-related functions will not work.},
    'Digest::SHA' => q{Used by sha1 filter, optional UserDB functionality, \
 and some payment modules.},
    'Image::Size' => q{Optional but recommended for [image ...] tag.},
    'LWP::Simple'  => q{External UPS lookup and other internet-related functions will not work.},
    'MIME::Base64' => q{Provides HTTP services for internal HTTP server \
 and basic authentication.},
    'Safe::Hole' => q{IMPORTANT: SQL and some tags will not work in embedded Perl.},
    'Set::Crontab' => q{Used by HouseKeepingCron task scheduler.},
    'Spreadsheet::ParseExcel' => q{Allows upload of XLS spreadsheets \
 for database import in the UI.},
    'Spreadsheet::WriteExcel' => q{Allows output of XLS spreadsheets \
 for database export in the UI.},
    'Storable' => q{Session and search storage will be slower.},
    'Tie::ShadowHash' => q{Needed for PreFork mode of Interchange, prevents \
 permanent write of configuration.},
    'Tie::Watch' => q{Minor: cannot set watch points in catalog.cfg.},
    'URI::URL' => q{Provides HTTP primitives for internal HTTP server.},
  );
  foreach my $name (@wanted) {
    no strict 'refs';
    eval "require $name";
    if($@) {
      my $info = errmsg($info{$name} || "May affect program operation.");
      push @out, "$name " . errmsg('not found') . ". $info"
    }
    elsif($l_than{$name}) {
      my $ver = ${"${name}::VERSION"};
      $ver =~ s/^(\d+\.\d+)\..*/$1/;
      if($ver > $l_than{$name}) {
        my $info = errmsg($info{$name} || "May affect program operation.");
        my $ex = errmsg(
              '%s too high a version, need %s or lower',
              $ver,
              $l_than{$name},
            );
        push @out, "$name $ex. $info";
      }
    }
    elsif($g_than{$name}) {
      my $ver = ${"${name}::VERSION"};
      $ver =~ s/^(\d+\.\d+)\..*/$1/;
      if($ver < $g_than{$name}) {
        my $info = errmsg($info{$name} || "May affect program operation.");
        my $ex = errmsg(
              '%s too low a version, need %s or higher',
              $ver,
              $g_than{$name},
            );
        push @out, "$name $ex. $info";
      }
    }
    else {
      my $ver = ${"$name" . "::VERSION"};
      $ver = $ver ? "v$ver" : 'no version info';
      push @out, "$name " . errmsg('found') . " ($ver).";
    }
  }
}

return join $joiner, @out;
}
EOR

SEE ALSO


Name

warning — display and manipulate warnings stored in session

ATTRIBUTES

AttributePos.Req.DefaultDescription

DESCRIPTION

warning is an alias for tag warnings. Please refer to it for documentation.

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

warning is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/warnings.coretag
Lines: 59


# Copyright 2002-2015 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag warning  Alias      warnings

UserTag warnings Order      message
UserTag warnings addAttr
UserTag warnings PosNumber  1
UserTag warnings Version    1.10
UserTag warnings Routine    <<EOR
sub {
my($message, $opt) = @_;

if($message) {
  my $param = ref $opt->{param} ? $opt->{param} : [$opt->{param}];
      if($opt->{param}) { 
          my $param = ref $opt->{param} ? $opt->{param} : [$opt->{param}];
          push_warning($message, @$param);
      }
      else {
          push_warning($message);
      }
  return unless $opt->{show};
}

return unless $Vend::Session->{warnings};

my $out = $opt->{header} || "";
if($opt->{auto}) {
  $opt->{list_container} ||= 'ul';
  $out .= "<$opt->{list_container}";
  for(qw/ class style extra /) {
    next unless $opt->{"list_$_"};
    if($opt->{"list_$_"} =~ m{^\s*$_\s*=}i) {
      $out .= ' ' . $opt->{"list_$_"};
    }
    else {
      $out .= qq{ $_="$opt->{"list_$_"}"};
    }
  }
  $out .= '>';
  $opt->{joiner} = '<li>'
    if ! length($opt->{joiner});
  $out .= $opt->{joiner};
}
elsif(! length($opt->{joiner})) {
  $opt->{joiner} = "\n";
}
$out .= join $opt->{joiner}, grep /\S/, @{$Vend::Session->{warnings}};
$out .= "</$opt->{list_container}>" if $opt->{auto};
$out .= $opt->{footer} if length($opt->{footer});
delete $Vend::Session->{warnings} unless $opt->{keep};
return $out;
}
EOR

SEE ALSO


Name

warnings — display and manipulate warnings stored in session

ATTRIBUTES

AttributePos.Req.DefaultDescription
message Yes
param
show
header
auto
list_container
list_style None
list_class None
list_extra None
joiner <li>
footer
keep
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

warnings is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/SystemTag/warnings.coretag
Lines: 59


# Copyright 2002-2015 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.

UserTag warning  Alias      warnings

UserTag warnings Order      message
UserTag warnings addAttr
UserTag warnings PosNumber  1
UserTag warnings Version    1.10
UserTag warnings Routine    <<EOR
sub {
my($message, $opt) = @_;

if($message) {
my $param = ref $opt->{param} ? $opt->{param} : [$opt->{param}];
    if($opt->{param}) { 
        my $param = ref $opt->{param} ? $opt->{param} : [$opt->{param}];
        push_warning($message, @$param);
    }
    else {
        push_warning($message);
    }
return unless $opt->{show};
}

return unless $Vend::Session->{warnings};

my $out = $opt->{header} || "";
if($opt->{auto}) {
$opt->{list_container} ||= 'ul';
$out .= "<$opt->{list_container}";
for(qw/ class style extra /) {
  next unless $opt->{"list_$_"};
  if($opt->{"list_$_"} =~ m{^\s*$_\s*=}i) {
    $out .= ' ' . $opt->{"list_$_"};
  }
  else {
    $out .= qq{ $_="$opt->{"list_$_"}"};
  }
}
$out .= '>';
$opt->{joiner} = '<li>'
  if ! length($opt->{joiner});
$out .= $opt->{joiner};
}
elsif(! length($opt->{joiner})) {
$opt->{joiner} = "\n";
}
$out .= join $opt->{joiner}, grep /\S/, @{$Vend::Session->{warnings}};
$out .= "</$opt->{list_container}>" if $opt->{auto};
$out .= $opt->{footer} if length($opt->{footer});
delete $Vend::Session->{warnings} unless $opt->{keep};
return $out;
}
EOR

SEE ALSO

error(7ic)


Name

weight — calculate total weight of items in shopping cart

ATTRIBUTES

AttributePos.Req.DefaultDescription
attribute Yes
cart main cart name
field
table
options
options_table
fill_attribute
matrix
no_set
weight_scratch total_weight
hide
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

Calculates total weight of items in shopping cart, by default setting a scratch variable (default "total_weight").

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

weight is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UserTag/weight.tag
Lines: 385


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: weight.tag,v 1.9 2007-07-18 00:16:26 jon Exp $

UserTag weight Order   attribute
UserTag weight addAttr
UserTag weight Version $Revision: 1.9 $
UserTag weight Routine <<EOR
sub {
 my ($attr, $opt) = @_;
 $opt ||= {};
 
 my $cart;
 if($opt->{cart}) {
   $cart = $Vend::Session->{carts}{$opt->{cart}} || [];
 }
 else {
   $cart = $Vend::Items;
 }

 my $wsub;

 my $field = $opt->{field} || 'weight';
 my $table = $opt->{table};
 my $osub;

 if($opt->{options}) {
    BUILDO: {
    my $oattr = $Vend::Cfg->{OptionsAttribute}
      or last BUILDO;
    my $odb = dbref($opt->{options_table} || 'options')
      or last BUILDO;
    my $otab = $odb->name();
    my $q = qq{
          SELECT o_group, weight FROM $otab
         WHERE  sku = ?
         AND    weight is not null
         AND    weight <> ''
         };
    my $sth = $odb->dbh()->prepare($q)
      or last BUILDO;
    if($oattr and $odb) {
      $osub = sub {
       my $it = shift;
       my $oweight = 0;
       if($it->{$oattr} eq 'Simple') {
         $sth->execute($it->{code});
         while(my $ref = $sth->fetchrow_arrayref) {
           my ($opt, $wtext) = @$ref;
           next unless length($it->{$opt});
           my $whash = get_option_hash($wtext);
           next unless $whash;
           $oweight += $whash->{$it->{$opt}};
         }
       }
       return $oweight;
     };
   };
   }
 }

 my $exclude;
 my %exclude;
 if(my $thing = $opt->{exclude_attribute}) {
   eval {
   if(ref($thing) eq 'HASH') {
     for(keys %$thing) {
       $exclude{$_} = qr{$thing->{$_}};
     }
   }
   else {
     my ($k, $v) = split /=/, $thing;
     $exclude{$k} = qr{$v};
   }
   };
   if($@) {
     ::logError("Bad weight exclude option: %s", ::uneval($thing));
   }
   else {
     $exclude = 1;
   }
 }

 my $zero_unless;
 my %zero_unless;
 if(my $thing = $opt->{zero_unless_attribute}) {
   eval {
   if(ref($thing) eq 'HASH') {
     for(keys %$thing) {
       $zero_unless{$_} = qr{$thing->{$_}};
     }
   }
   else {
     my ($k, $v) = split /=/, $thing;
     $zero_unless{$k} = qr{$v};
   }
   };
   if($@) {
     ::logError("Bad weight zero_unless option: %s", ::uneval($thing));
   }
   else {
     $zero_unless = 1;
   }
 }

 if($attr) {
   $attr = $opt->{field} || 'weight';
   $wsub = sub {
     return shift(@_)->{$attr};
   };
 }
 elsif($opt->{fill_attribute}) {
   $attr = $opt->{fill_attribute};
   $wsub = sub {
     my $it = shift;
     return $it->{$attr} if defined $it->{$attr};
     my $tab = $table || $it->{mv_ib} || $Vend::Cfg->{ProductFiles}[0];
     $it->{$attr} = tag_data($tab,$field,$it->{code}) || 0;
     if($opt->{matrix} and ! $it->{$attr} and $it->{mv_sku}) {
       $it->{$attr} = Vend::Data::product_field($field,$it->{mv_sku});
     }
     return $it->{$attr};
   };
 }
 else {
   $wsub = sub {
     my $it = shift;
     my $tab = $table || $it->{mv_ib} || $Vend::Cfg->{ProductFiles}[0];
     my $w = tag_data($tab,$field,$it->{code}) || 0;
     if(! $w and $opt->{matrix} and $it->{mv_sku}) {
       $w = Vend::Data::product_field($field,$it->{mv_sku});
     }
     return $w;
   };
 }

 my $total = 0;
 CARTCHECK:
 for(@$cart) {
   if($exclude) {
     my $found;
     for my $k (keys %exclude) {
       $found = 1, last if $_->{$k} =~ $exclude{$k};
     }
     next if $found;
   }
   if($zero_unless) {
     for my $k (keys %zero_unless) {
       return 0 unless $_->{$k} =~ $zero_unless{$k};
     }
   }
   next if $_->{mv_free_shipping} && ! $opt->{no_free_shipping};
   $total += $_->{quantity} * $wsub->($_);
   next unless $osub;
   $total += $_->{quantity} * $osub->($_);
 }

 if(my $adder_thing = $opt->{tot_adder}) {
   my $adder = 0;
   my $calc_range = sub {
     my $current = shift;
     my $range = shift;
     my $add = shift;
     my ($l,$h) = split /[-:_]+/, $range;
     $l =~ s/^k//g;
     if($l < $current && $h >= $current){
       return $add;
     }
     else {
       return 0;
     }
   };

   eval {
     if(ref($adder_thing) eq 'HASH') {
       for(keys %$adder_thing) {
         $adder = $calc_range->($total, $_, $adder_thing->{$_});
         last if $adder != 0;
       }
     }
     elsif ($adder_thing =~ /=/) {
       my ($k, $v) = split /=/, $adder_thing;
       $adder = $calc_range->($total, $k, $v);
     }
     else {
       $adder = $adder_thing;
     }
   };

   if($@) {
     ::logError("Bad weight adder option: %s", ::uneval($adder_thing));
   }
   else {
     $total += $adder;
   }
 }
 
 unless($opt->{no_set}) {
   $::Scratch->{$opt->{weight_scratch} ||= 'total_weight'} = $total;
 }

 return $total unless $opt->{hide};
 return;
}
EOR

UserTag weight Documentation <<EOD
=head1 NAME

ITL tag [weight] -- calculate shipping weight from cart

=head1 SYNOPSIS

[weight]
[weight
   attribute=1*
   cart=cartname*
   field=sh_weight*
   fill-attribute=weight*
   zero-unless-attribute="attribute=regex"
   exclude-attribute="attribute=regex"
   hide=1|0*
 matrix=1
   no-set=1|0*
   table=weights*
   weight-scratch=sh_weight*
]

=head1 DESCRIPTION

Calculates total weight of items in shopping cart, by default setting
a scratch variable (default "total_weight").

=head2 Options

=over 4

=item attribute

If set, weight tag will calculate from the field in the item itself instead
of going to the database. This is the most efficient, and can be enabled
by using this in catalog.cfg:

 AutoModifier  weight

The default is not set, using the database every time.

=item cart

The cart to calculate for. Defaults to current cart.

=item field

The fieldname to use -- default "weight". This applies both to attribute
and database.

=item exclude-attribute

If an attribute I<already in the cart hash> matches the regex, it
will not show up as weight. Can be a scalar or hash.

 [weight exclude-attribute="prod_group=Gift Certificates"]

and 

 [weight exclude-attribute.prod_group="Gift Certificates"]

are identical, but with the second form you can do:

 [weight
   exclude-attribute.prod_group="Gift Certificates"
   exclude-attribute.category="Downloads"
 ]

The value is a regular expression, so you can group with C<|>,
or make case insensitive with:

 [weight exclude-attribute.prod_group="(?i)certificate"]

If the regular expression does not compile, an error is logged
and no exclusion is done.

It is IMPORTANT to note that you must have the attribute pre-filled
for this to work -- no database accesses will be done. If you want
to do this, use L<AutoModifier>, i.e. put in catalog.cfg:

 AutoModifier prod_group

=item fill-attribute

Sets the attribute from the database the first time, and uses it thereafter.
Sets to weight of a single unit, of course.

=item hide

Don't display the weight, only set in Scratch. It makes no sense to
use hide=1 and no-set=1.

=item matrix

If set, will get the weight from the ProductFiles for the mv_sku
attribute of the item. In other words, if the weight for a variant
is not set, it will use the weight for the base SKU.

=item no-set

Don't set the weight in scratch.

=item options

Scan the options table for applicable options and adjust weight
accordingly. Only works for "Simple" type options set in the
OptionsEnable attribute, and the o_group and weight fields must
represent the option attribute and the weight text. The weight text is a
normal Interchange option hash string type, i.e. 

 titanium=-1.2, iron=1.5

where "titanium" and "iron" are the values of an option
setting like "blade".

Will only work if your options table is SQL/DBI.

=item table

Specify a table to use to look up weights. Defaults to the table the
product was ordered from (or the first ProductFiles).

=item weight-scratch

The scratch variable name to set -- default is "total_weight".

=item zero-unless-attribute

Same as C<exclude-attribute> except that a zero weight is returned
unless B<all> items match the expression. This allows you to do
something like only offer Book Rate shipping when all items have
a prod_group of "Books".

=item totadder

Similar to 'adder' in shipping.asc, except that it allows you to add
lbs vs dollars to the total weight. There are 3 ways to add

1. Simply add X lbs per cart

[weight tot_adder=1]

Will add 1 lb to total_weight after all other weight calcs.

2. Add X lbs depending on a range of weight

[weight tot_adder.k0_25=2]

Will add 2 lbs to total_weight if weight between 0 and including 25, after all other weight calcs.

3. Add X lbs depending on multiple ranges of weight

[weight tot_adder.k0_3=1
   tot_adder.k3_6=2 
   tot_adder.k6_10=3 
   tot_adder.k10_16=4
   tot_adder.k16_25=5
 ]

Will add 1 lbs to total_weight if weight greater than 0 and including 3, \
 after all other weight calcs.
Will add 2 lbs to total_weight if weight greater than 3 and including 6, \
 after all other weight calcs.
Will add 3 lbs to total_weight if weight greater than 6 and including 10, \
 after all other weight calcs.
Will add 4 lbs to total_weight if weight greater than 10 and including \
 16, after all other weight calcs.
Will add 5 lbs to total_weight if weight greater than 16 and including \
 25, after all other weight calcs.


=back

=head1 AUTHOR

Mike Heins

=cut
EOD

SEE ALSO


Name

widget

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes Yes Name of the resulting HTML element.
set Override current or default widget value with specific data.
default Default value for a widget. The default is applied if there is no corresponding value for the widget in the values variable space.
pre_filter Filter name or names (separated by spaces) to apply to the widget's value prior to display.
attribute
table | db
field | column
key | outboard
extra
js
cols
delimiter
rows
data
passed
type
filter
interpolate   1interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

widget is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/widget.coretag
Lines: 58


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: widget.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag widget Order       name
UserTag widget PosNumber   1
UserTag widget attrAlias   db table
UserTag widget attrAlias   column field
UserTag widget attrAlias   outboard key
UserTag widget addAttr
UserTag widget HasEndTag   1
UserTag widget Interpolate 1
UserTag widget Version     $Revision: 1.6 $
UserTag widget Routine     <<EOR
sub {
my($name, $opt, $string) = @_;
#my($name, $type, $value, $table, $column, $key, $data, $string) = @_;
my $value;

if(defined $opt->{set}) {
  $value = $opt->{set};
}
else {
  $value = $::Values->{$name} || $opt->{default};
}
if($opt->{pre_filter}) {
#::logDebug("pre-filter with $opt->{pre_filter}");
  $value = $Tag->filter($opt->{pre_filter}, $value);
}
my $ref = {
      attribute  => $opt->{attribute} || 'attribute',
      db      => $opt->{table},
      field    => $opt->{field},
      extra    => $opt->{extra} || $opt->{js},
      cols    => $opt->{cols},
      delimiter  => $opt->{delimiter},
      rows    => $opt->{rows} || undef,
      name    => $name,
      outboard  => $opt->{key},
      passed    => $opt->{data} || $opt->{passed} || $string,
      type    => $opt->{type} || 'select',
      value    => $value,
      };

my $w = Vend::Form::display($ref);
if($opt->{filter}) {
  $w .= qq{<INPUT TYPE=hidden NAME="ui_filter:$name" VALUE="};
  $w .= $opt->{filter};
  $w .= '">';
}
return $w;
}
EOR

SEE ALSO

formel(7ic)


Name

widget-info — Access information for a particular widget

ATTRIBUTES

AttributePos.Req.DefaultDescription
name Yes
attribute Yes
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

widget-info is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/widget_info.coretag
Lines: 65


UserTag widget-info  Order  name attribute
UserTag widget-info  Version  $Revision: 1.1 $
UserTag  widget-info  Routine  <<EOR
my %wi_attr = ((map { (lc $_, $_) } qw(
Widget
Documentation
Visibility
Description
Help
Multiple
Version
)), qw(
exists  Widget
));

sub {
my ($name, $attr) = @_;

if (length $name) {
  # Global or Local?
  my $repo = $Global::CodeDef->{Widget};
  $repo = $Vend::Cfg->{CodeDef}{Widget} if $Vend::Cfg->{CodeDef}{Widget}{Widget}{$name};
  return unless $repo->{Widget}{$name};

  if (length $attr) {
    # return just one attribute for the given name.
    $attr = $wi_attr{lc $attr} or return;
    return $repo->{$attr}{$name};
  }
  else {
    # return a hashref with all the available attributes for a given name.
    my %build = reverse %wi_attr;
    while (my $key = each %build) {
      if (exists $repo->{$key}{$name}) {
        $build{$key} = $repo->{$key}{$name};
      }
      else {
        delete $build{$key};
      }
    }
    return \%build;
  }
}
else {
  # return a hashref of hashrefs for all the widgets and their attributes.
  my %build = %{$Global::CodeDef->{Widget}{Widget}};
  @build{keys %build} = ($Global::CodeDef->{Widget}) x scalar keys %build;
  @build{keys %{$Vend::Cfg->{CodeDef}{Widget}{Widget}}} = ($Vend::Cfg->{CodeDef}{Widget}) \
 x scalar keys %{$Vend::Cfg->{CodeDef}{Widget}{Widget}};

  foreach my $name (keys %build) {
    my $repo = $build{$name};
    $build{$name} = {reverse %wi_attr};
    while (my $key = each %{$build{$name}}) {
      if (exists $repo->{$key}{$name}) {
        $build{$name}{$key} = $repo->{$key}{$name};
      }
      else {
        delete $build{$name}{$key};
      }
    }
  }
  return \%build;
}
}
EOR

SEE ALSO


Name

widget-meta

ATTRIBUTES

AttributePos.Req.DefaultDescription
type Yes
view
meta_table
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

widget-meta is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/widget_meta.coretag
Lines: 13


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: widget_meta.coretag,v 1.4 2007-03-30 23:40:54 pajamian Exp $

UserTag widget-meta Order      type
UserTag widget-meta addAttr
UserTag widget-meta Version    $Revision: 1.4 $
UserTag widget-meta MapRoutine Vend::Table::Editor::widget_meta

Source: lib/Vend/Table/Editor.pm
Lines: 653

sub widget_meta {
my ($type,$opt) = @_;
my $meta = meta_record("_widget::$type", $opt->{view}, $opt->{meta_table}, 1);
return $meta if $meta;
my $w = $Vend::Cfg->{CodeDef}{Widget};
if($w and $w->{Widget}{$type}) {
  my $string;
  return undef unless $string = $w->{ExtraMeta}{$type};
  return get_option_hash($string);
}

$w = $Global::CodeDef->{Widget};
if($w and $w->{Widget}{$type}) {
  my $string;
  return undef unless $string = $w->{ExtraMeta}{$type};
  return get_option_hash($string);
}

return $Vend::Form::ExtraMeta{$type};
}

SEE ALSO


Name

write-relative-file — save content to a filename inside the catalog directory

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes Yes Pathname to write to, relative to CATROOT.
auto_create_dir  0Auto-create directories in the file path?
umask    File creation umask.
interpolate   0interpolate input?
reparse   1interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

The tag writes a file in the catalog directory. File name is subject to file control (e.g. it must be relative), it will return undef if the check isn't passed.

If the file exists, it is truncated (file contents get overwritten, not appended).

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

Example: Simple file write

[write-relative-file logs/test]Sample content[/write-relative-file]

NOTES

AVAILABILITY

write-relative-file is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/write_relative_file.coretag
Lines: 26


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: write_relative_file.coretag,v 1.10 2007-03-30 23:40:54 pajamian Exp $

UserTag write-relative-file Order         file
UserTag write-relative-file hasEndTag
UserTag write-relative-file addAttr
UserTag write-relative-file Version       $Revision: 1.10 $
UserTag write-relative-file Routine       <<EOR
sub {
my ($file, $opt, $data) = @_;
#::logDebug("writing $file");
unless(defined $data) {
  $data = $opt;
  $opt = {};
}
return undef unless Vend::File::allowed_file($file, 1);
$opt->{auto_create_dir} = 1 unless defined $opt->{auto_create_dir};
Vend::File::writefile(">$file", $data, $opt);
}
EOR


Name

write-shipping

ATTRIBUTES

AttributePos.Req.DefaultDescription
file Yes
interpolate   0interpolate output?
hide   0Hide the tag return value?

DESCRIPTION

BEHAVIOR

This tag does not appear to be affected by, or affect, the rest of Interchange.

EXAMPLES

No examples are available at this time. We do consider this a problem and will try to supply some.

NOTES

AVAILABILITY

write-shipping is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.0:

Source: code/UI_Tag/write_shipping.coretag
Lines: 51


# Copyright 2002-2007 Interchange Development Group and others
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.  See the LICENSE file for details.
# 
# $Id: write_shipping.coretag,v 1.6 2007-03-30 23:40:54 pajamian Exp $

UserTag write-shipping Order      file
UserTag write-shipping PosNumber  1
UserTag write-shipping addAttr
UserTag write-shipping Version    $Revision: 1.6 $
UserTag write-shipping Routine    <<EOR
sub {
my ($file, $opt) = @_;
if(! $file) {
  unless($file = $Vend::Cfg->{Special}{'shipping.asc'}) {
    my $dir = $Vend::Cfg->{Shipping}{dir} || $Vend::Cfg->{ProductDir};
    $file = Vend::Util::catfile($dir,'shipping.asc');
}
}

## This is set so the UI knows where to check for changes
$::Scratch->{ui_shipping_asc} = $file;

my $lines = $Vend::Cfg->{Shipping_line};
my @outlines;
for (@$lines) {
  #    0      1      2      3     4     5       6      7
  # ($mode, $desc, $crit, $min, $max, $cost, $query, $opt) 
  my @line = @$_;
  my $opt = '';
  if (ref($line[7]) =~ /HASH/) {
    $line[7] = uneval_it($line[7]);
  }
  push @outlines, \@line;
}

# Back the file up
$Tag->backup_file($file);

open(SHIPOUT, ">$file")
  or die errmsg("Can't write shipping to %s: %s", $file, $!);
for(@outlines) {
  print SHIPOUT join "\t", @$_;
  print SHIPOUT "\n";
}
close SHIPOUT;
}
EOR

SEE ALSO

DocBook!Interchange!