code/UI_Tag/version.coretag

   1 # Copyright 2002-2007 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7 #
   8 # $Id: version.coretag,v 1.15 2007-08-05 08:01:03 kwalsh Exp $
   9
  10 UserTag version Order      extended
  11 UserTag version attrAlias  module_test modtest
  12 UserTag version attrAlias  moduletest modtest
  13 UserTag version attrAlias  require modtest
  14 UserTag version addAttr
  15 UserTag version Version    $Revision: 1.15 $
  16 UserTag version Routine    <<EOR
  17 sub {
  18         return $::VERSION unless shift;
  19         my $opt = shift;
  20         my $joiner = $opt->{joiner} || "<br$Vend::Xtrailer>";
  21         my @out;
  22         my $done_something;
  23
  24         if($opt->{global_error}) {
  25                 push @out, $Global::ErrorFile;
  26                 $done_something = 1;
  27         }
  28
  29         if($opt->{local_error}) {
  30                 my $dfn = my $fn = $Vend::Cfg->{ErrorFile};
  31                 my $pre = $Global::Catalog{$Vend::Cat}->{dir} . '/';
  32                 $fn =~ s:^\Q$pre\E::;
  33                 my $href = $Tag->area("$::Variable->{UI_BASE}/do_view", $fn);
  34                 push(@out, qq{<a href="$href">$dfn</a>});
  35                 $done_something = 1;
  36         }
  37
  38         if($opt->{env}) {
  39                 push @out,
  40                         ref $Global::Environment eq 'ARRAY' ?
  41                         join ' ', @{$Global::Environment} :
  42                         '(none)';
  43                 $done_something = 1;
  44         }
  45
  46         if($opt->{safe}) {
  47                 push @out, join " ", @{$Global::SafeUntrap};
  48                 $done_something = 1;
  49         }
  50
  51         if($opt->{child_pid}) {
  52                 push @out, $$;
  53                 $done_something = 1;
  54         }
  55
  56         if($opt->{modtest}) {
  57                 eval "require $opt->{modtest}";
  58                 if($@) {
  59                         push @out, 0;
  60                 }
  61                 else {
  62                         push @out, 1;
  63                 }
  64                 $done_something = 1;
  65         }
  66
  67         if($opt->{pid}) {
  68                 push @out, ::readfile($Global::PIDfile);
  69                 $done_something = 1;
  70         }
  71
  72         if($opt->{mode}) {
  73                 push @out, Vend::Server::server_start_message('%s', 1);
  74                 $done_something = 1;
  75         }
  76
  77         if($opt->{uid}) {
  78                 push @out, scalar getpwuid($>) . " (uid $>)";
  79                 $done_something = 1;
  80         }
  81
  82         if($opt->{global_locale_options}) {
  83                 my @loc;
  84                 my $curr = $Global::Locale;
  85
  86                 while ( my($k,$v) = each %$Global::Locale_repository ) {
  87                         next unless $k =~ /_/;
  88                         push @loc, "$v->{MV_LANG_NAME}~:~$k=$v->{MV_LANG_NAME}";
  89                 }
  90                 if(@loc > 1) {
  91                         push @out, join ",", map { s/.*~:~//; $_ } sort @loc;
  92                 }
  93                 $done_something = 1;
  94         }
  95
  96         if($opt->{perl}) {
  97                 push @out, ($^V ? sprintf("%vd", $^V) : $]) . errmsg(" (called with: %s)", $^X);
  98                 $done_something = 1;
  99         }
 100
 101         if($opt->{perl_config}) {
 102                 require Config;
 103                 push @out, "<pre>\n" . Config::myconfig() . "</pre>";
 104                 $done_something = 1;
 105         }
 106
 107         if($opt->{hostname}) {
 108                 require Sys::Hostname;
 109                 push @out, Sys::Hostname::hostname()
 110                         || errmsg("unable to determine hostname");
 111                 $done_something = 1;
 112         }
 113
 114         if(not $opt->{db} || $opt->{modules} || $done_something) {
 115                 $opt->{db} = 1;
 116                 push @out, "Interchange Version $::VERSION";
 117                 push @out, "";
 118         }
 119
 120         if($opt->{db}) {
 121                 if($Global::GDBM) {
 122                         push @out, errmsg('%s available (v%s)', 'GDBM', $GDBM_File::VERSION);
 123                 }
 124                 else {
 125                         push @out, errmsg('No %s.', 'GDBM');
 126                 }
 127                 if($Global::DB_File) {
 128                         push @out, errmsg('%s available (v%s)', 'Berkeley DB_File', $DB_File::VERSION);
 129                 }
 130                 else {
 131                         push @out, errmsg('No %s.', 'Berkeley DB_File');
 132                 }
 133                 if($Global::LDAP) {
 134                         push @out, errmsg('%s available (v%s)', 'LDAP', $Net::LDAP::VERSION);
 135                 }
 136                 if($Global::DBI and $DBI::VERSION) {
 137                         push @out, errmsg ('DBI enabled (v%s), available drivers:', $DBI::VERSION);
 138                         my $avail = join $joiner, DBI->available_drivers;
 139                         push @out, "<blockquote>$avail</blockquote>";
 140                 }
 141         }
 142
 143         if($opt->{modules}) {
 144                 my @wanted = qw/
 145                         Archive::Tar
 146                         Archive::Zip
 147                         Bundle::LWP
 148                         Business::UPS
 149                         Compress::Zlib
 150                         Crypt::SSLeay
 151                         DBI
 152                         Digest::MD5
 153                         Image::Size
 154                         LWP::Simple
 155                         MIME::Base64
 156                         Safe::Hole
 157                         Set::Crontab
 158                         Spreadsheet::ParseExcel
 159                         Spreadsheet::WriteExcel
 160                         Storable
 161                         Tie::ShadowHash
 162                         Tie::Watch
 163                         URI::URL
 164                 /;
 165                 my %l_than;
 166                 my %g_than;
 167                 my %info = (
 168                         'Archive::Tar' => q{Only needed for supplementary UserTag definitions.},
 169                         'Archive::Zip' => q{Only needed for supplementary UserTag definitions.},
 170                         'Bundle::LWP' => q{Certain parts of these modules (URI::URL and MIME::Base64) are required for Interchange's internal HTTP server. Also, Business::UPS, for calculating shipping, requires this.},
 171                         'Business::UPS' => q{Enables lookup of shipping costs directly from www.ups.com. Requires Bundle::LWP.},
 172                         'Compress::Zlib' => q{Only needed for supplementary UserTag definitions.},
 173                         'Crypt::SSLeay' => q{Payment interface links via HTTPS/SSL.},
 174                         '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.},
 175                         'Digest::MD5' => q{IMPORTANT: cache keys and other search-related functions will not work.},
 176                         'Image::Size' => q{Optional but recommended for [image ...] tag.},
 177                         'LWP::Simple'  => q{External UPS lookup and other internet-related functions will not work.},
 178                         'MIME::Base64' => q{Provides HTTP services for internal HTTP server and basic authentication.},
 179                         'Safe::Hole' => q{IMPORTANT: SQL and some tags will not work in embedded Perl.},
 180                         'Set::Crontab' => q{Used by HouseKeepingCron task scheduler.},
 181                         'Spreadsheet::ParseExcel' => q{Allows upload of XLS spreadsheets for database import in the UI.},
 182                         'Spreadsheet::WriteExcel' => q{Allows output of XLS spreadsheets for database export in the UI.},
 183                         'Storable' => q{Session and search storage will be slower.},
 184                         'Tie::ShadowHash' => q{Needed for PreFork mode of Interchange, prevents permanent write of configuration.},
 185                         'Tie::Watch' => q{Minor: cannot set watch points in catalog.cfg.},
 186                         'URI::URL' => q{Provides HTTP primitives for internal HTTP server.},
 187                 );
 188                 foreach my $name (@wanted) {
 189                         no strict 'refs';
 190                         eval "require $name";
 191                         if($@) {
 192                                 my $info = errmsg($info{$name} || "May affect program operation.");
 193                                 push @out, "$name " . errmsg('not found') . ". $info"
 194                         }
 195                         elsif($l_than{$name}) {
 196                                 my $ver = ${"${name}::VERSION"};
 197                                 $ver =~ s/^(\d+\.\d+)\..*/$1/;
 198                                 if($ver > $l_than{$name}) {
 199                                         my $info = errmsg($info{$name} || "May affect program operation.");
 200                                         my $ex = errmsg(
 201                                                                 '%s too high a version, need %s or lower',
 202                                                                 $ver,
 203                                                                 $l_than{$name},
 204                                                         );
 205                                         push @out, "$name $ex. $info";
 206                                 }
 207                         }
 208                         elsif($g_than{$name}) {
 209                                 my $ver = ${"${name}::VERSION"};
 210                                 $ver =~ s/^(\d+\.\d+)\..*/$1/;
 211                                 if($ver < $g_than{$name}) {
 212                                         my $info = errmsg($info{$name} || "May affect program operation.");
 213                                         my $ex = errmsg(
 214                                                                 '%s too low a version, need %s or higher',
 215                                                                 $ver,
 216                                                                 $g_than{$name},
 217                                                         );
 218                                         push @out, "$name $ex. $info";
 219                                 }
 220                         }
 221                         else {
 222                                 my $ver = ${"$name" . "::VERSION"};
 223                                 $ver = $ver ? "v$ver" : 'no version info';
 224                                 push @out, "$name " . errmsg('found') . " ($ver).";
 225                         }
 226                 }
 227         }
 228
 229         return join $joiner, @out;
 230 }
 231 EOR