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
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
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
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
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: 1545

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: 1545

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: 3908

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: 2748

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: 2748

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: 237


# 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 backup-database Order    tables
UserTag backup-database AddAttr
UserTag backup-database Version  1.11
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;
  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

breadcrumbs

ATTRIBUTES

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

DESCRIPTION

BEHAVIOR

This tag appears to be affected by, or affects, the following:
Catalog Variables: BREADCRUMB_ONLY_LAST, BREADCRUMB_EXCLUDE, BREADCRUMB_MAX, COMPANY
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

breadcrumbs is available in Interchange versions:

4.6.0-5.9.0 (git-head)

SOURCE

Interchange 5.9.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: 2825

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: 2825

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: 2825

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: 2758

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

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

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: 2252

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: 2252

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: 889

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: 889

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: 1773

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{catalog} = $Vend::Cat;
      if($tpl =~ /\{caller\d+\}/i) {
          my @caller = caller();
          for(my $i = 0; $i < @caller; $i++) {
              $debug{"caller$i"} = $caller[$i];
          }
      }
  $debug{message} = errmsg(@_);

  $msg = Vend::Interpolate::tag_attr_list($tpl, \%debug, 1);
}
else {
  $msg = caller() . ":debug: " . errmsg(@_);
}

if ($Global::SysLog) {
  logGlobal({ level => 'debug' }, $msg);
}
else {
  print $msg, "\n";
}

return;
}

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: 101


# 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: deliver.coretag,v 1.8 2007-03-30 23:40:49 pajamian Exp $

UserTag deliver Order     type
UserTag deliver HasEndTag
UserTag deliver addAttr
UserTag deliver Version   $Revision: 1.8 $
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;
}

## 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;
}

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,
      } );
}
}
$::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: 3999

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: 1077

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

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: 1906

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: 1893

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: 744

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: 1875

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: 5099

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: 5514

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: 5228

*tag_handling = \&Vend::Ship::tag_handling;

Source: lib/Vend/Ship.pm
Lines: 1010

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: 4642

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: 1469

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: 278


# Copyright 2002-2011 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.25
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;
    } 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: 920

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

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: 3589

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: 2050

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

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: 5014

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: 5014

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: 2540

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: 2540

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: 722

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: 3517

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;
}

$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: 1576

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?