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

UserTag version Order      extended
UserTag version attrAlias  module_test modtest
UserTag version attrAlias  moduletest modtest
UserTag version attrAlias  require modtest
UserTag version addAttr
UserTag version Version    1.16
UserTag version Routine    <<EOR
sub {
return $::VERSION unless shift;
my $opt = shift;
my $joiner = $opt->{joiner} || "<br$Vend::Xtrailer>";
my @out;
my $done_something;

if($opt->{global_error}) {
push @out, $Global::ErrorFile;
$done_something = 1;
}

if($opt->{local_error}) {
my $dfn = my $fn = $Vend::Cfg->{ErrorFile};
my $pre = $Global::Catalog{$Vend::Cat}->{dir} . '/';
$fn =~ s:^\Q$pre\E::;
my $href = $Tag->area("$::Variable->{UI_BASE}/do_view", $fn);
push(@out, qq{<a href="$href">$dfn</a>});
$done_something = 1;
}

if($opt->{env}) {
  push @out,
    ref $Global::Environment eq 'ARRAY' ?
    join ' ', @{$Global::Environment} :
    '(none)';
  $done_something = 1;
}

if($opt->{safe}) {
  push @out, join " ", @{$Global::SafeUntrap};
  $done_something = 1;
}

if($opt->{child_pid}) {
  push @out, $$;
  $done_something = 1;
}

if($opt->{modtest}) {
  eval "require $opt->{modtest}";
  if($@) {
    push @out, 0;
  }
  else {
    push @out, 1;
  }
  $done_something = 1;
}

if($opt->{pid}) {
  push @out, ::readfile($Global::PIDfile);
  $done_something = 1;
}

if($opt->{mode}) {
  push @out, Vend::Server::server_start_message('%s', 1);
  $done_something = 1;
}

if($opt->{uid}) {
  push @out, scalar getpwuid($>) . " (uid $>)";
  $done_something = 1;
}

if($opt->{global_locale_options}) {
  my @loc;
  my $curr = $Global::Locale;
  
  while ( my($k,$v) = each %$Global::Locale_repository ) {
    next unless $k =~ /_/;
    push @loc, "$v->{MV_LANG_NAME}~:~$k=$v->{MV_LANG_NAME}";
  }
  if(@loc > 1) {
    push @out, join ",", map { s/.*~:~//; $_ } sort @loc;
  }
  $done_something = 1;
}

if($opt->{perl}) {
  push @out, ($^V ? sprintf("%vd", $^V) : $]) . errmsg(" (called with: %s)", $^X);
  $done_something = 1;
}

if($opt->{perl_config}) {
  require Config;
  push @out, "<pre>\n" . Config::myconfig() . "</pre>";
  $done_something = 1;
}

if($opt->{hostname}) {
  require Sys::Hostname;
  push @out, Sys::Hostname::hostname()
    || errmsg("unable to determine hostname");
  $done_something = 1;
}

if(not $opt->{db} || $opt->{modules} || $done_something) {
  $opt->{db} = 1;
  push @out, "Interchange Version $::VERSION";
  push @out, "";
}

if($opt->{db}) {
  if($Global::GDBM) {
    push @out, errmsg('%s available (v%s)', 'GDBM', $GDBM_File::VERSION);
  }
  else {
    push @out, errmsg('No %s.', 'GDBM');
  }
  if($Global::DB_File) {
    push @out, errmsg('%s available (v%s)', 'Berkeley DB_File', $DB_File::VERSION);
  }
  else {
    push @out, errmsg('No %s.', 'Berkeley DB_File');
  }
  if($Global::LDAP) {
    push @out, errmsg('%s available (v%s)', 'LDAP', $Net::LDAP::VERSION);
  }
  if($Global::DBI and $DBI::VERSION) {
    push @out, errmsg ('DBI enabled (v%s), available drivers:', $DBI::VERSION);
    my $avail = join $joiner, DBI->available_drivers;
    push @out, "<blockquote>$avail</blockquote>";
  }
}

if($opt->{modules}) {
  my @wanted = qw/
    Archive::Tar
    Archive::Zip
    Business::UPS
    Compress::Zlib
    Crypt::Random
    Crypt::SSLeay
    DBI
    Digest::Bcrypt
    Digest::MD5
    Digest::SHA
    Image::Size
    LWP::Simple
    MIME::Base64
    Safe::Hole
    Set::Crontab
    Spreadsheet::ParseExcel
    Spreadsheet::WriteExcel
    Storable
    Tie::ShadowHash
    Tie::Watch
    URI::URL
  /;
  my %l_than;
  my %g_than;
  my %info = (
    'Archive::Tar' => q{Only needed for supplementary UserTag definitions.},
    'Archive::Zip' => q{Only needed for supplementary UserTag definitions.},
    'Business::UPS' => q{Enables lookup of shipping costs directly from www.ups.com.},
    'Compress::Zlib' => q{Only needed for supplementary UserTag definitions.},
    'Crypt::Random' => q{Used for UserDB bcrypt password hashing.},
    'Crypt::SSLeay' => q{Payment interface links via HTTPS/SSL.},
    'DBI' => q{Most people want to use SQL with Interchange, and this \
 is a requirement.  You will also need the appropriate DBD module, \
 i.e. DBD::mysql to support MySQL.},
    'Digest::Bcrypt' => q{Used for UserDB bcrypt password hashing.},
    'Digest::MD5' => q{IMPORTANT: cache keys and other search-related functions will not work.},
    'Digest::SHA' => q{Used by sha1 filter, optional UserDB functionality, \
 and some payment modules.},
    'Image::Size' => q{Optional but recommended for [image ...] tag.},
    'LWP::Simple'  => q{External UPS lookup and other internet-related functions will not work.},
    'MIME::Base64' => q{Provides HTTP services for internal HTTP server \
 and basic authentication.},
    'Safe::Hole' => q{IMPORTANT: SQL and some tags will not work in embedded Perl.},
    'Set::Crontab' => q{Used by HouseKeepingCron task scheduler.},
    'Spreadsheet::ParseExcel' => q{Allows upload of XLS spreadsheets \
 for database import in the UI.},
    'Spreadsheet::WriteExcel' => q{Allows output of XLS spreadsheets \
 for database export in the UI.},
    'Storable' => q{Session and search storage will be slower.},
    'Tie::ShadowHash' => q{Needed for PreFork mode of Interchange, prevents \
 permanent write of configuration.},
    'Tie::Watch' => q{Minor: cannot set watch points in catalog.cfg.},
    'URI::URL' => q{Provides HTTP primitives for internal HTTP server.},
  );
  foreach my $name (@wanted) {
    no strict 'refs';
    eval "require $name";
    if($@) {
      my $info = errmsg($info{$name} || "May affect program operation.");
      push @out, "$name " . errmsg('not found') . ". $info"
    }
    elsif($l_than{$name}) {
      my $ver = ${"${name}::VERSION"};
      $ver =~ s/^(\d+\.\d+)\..*/$1/;
      if($ver > $l_than{$name}) {
        my $info = errmsg($info{$name} || "May affect program operation.");
        my $ex = errmsg(
              '%s too high a version, need %s or lower',
              $ver,
              $l_than{$name},
            );
        push @out, "$name $ex. $info";
      }
    }
    elsif($g_than{$name}) {
      my $ver = ${"${name}::VERSION"};
      $ver =~ s/^(\d+\.\d+)\..*/$1/;
      if($ver < $g_than{$name}) {
        my $info = errmsg($info{$name} || "May affect program operation.");
        my $ex = errmsg(
              '%s too low a version, need %s or higher',
              $ver,
              $g_than{$name},
            );
        push @out, "$name $ex. $info";
      }
    }
    else {
      my $ver = ${"$name" . "::VERSION"};
      $ver = $ver ? "v$ver" : 'no version info';
      push @out, "$name " . errmsg('found') . " ($ver).";
    }
  }
}

return join $joiner, @out;
}
EOR