[interchange-cvs] interchange - jon modified 3 files
interchange-core@icdevgroup.org
interchange-core@icdevgroup.org
Tue Jul 23 13:46:01 2002
User: jon
Date: 2002-07-23 17:45:21 GMT
Modified: . MANIFEST
Added: extensions Interchange.pm
Removed: perl Interchange.pm
Log:
Move youthful Interchange.pm from perl/ to extensions/.
Revision Changes Path
2.47 +1 -1 interchange/MANIFEST
rev 2.47, prev_rev 2.46
Index: MANIFEST
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
RCS file: /var/cvs/interchange/MANIFEST,v
retrieving revision 2.46
retrieving revision 2.47
diff -u -u -r2.46 -r2.47
--- MANIFEST 23 Jul 2002 15:22:17 -0000 2.46
+++ MANIFEST 23 Jul 2002 17:45:20 -0000 2.47
@@ -869,6 +869,7 @@
eg/usertag/sleep
extensions/ECML/Vend/ECML.pm
extensions/ECML/ecml.coretag
+extensions/Interchange.pm
extensions/quickbooks/README
extensions/quickbooks/etc/trans_quickbooks
extensions/quickbooks/ic_qb.pod
@@ -958,7 +959,6 @@
lib/Vend/Track.pm
lib/Vend/UserDB.pm
lib/Vend/Util.pm
-perl/Interchange.pm
relocate.pl
scripts/compile_link.PL
scripts/config_prog.PL
1.1 interchange/extensions/Interchange.pm
rev 1.1, prev_rev 1.0
Index: Interchange.pm
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D
# Interchange.pm - Interchange access for Perl scripts
#
# $Id: Interchange.pm,v 1.1 2002/07/23 17:45:21 jon Exp $
#=20
# Copyright (C) 1996-2002 Red Hat, Inc. <interchange@redhat.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.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public
# License along with this program; if not, write to the Free
# Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA.
package Interchange;
require Exporter;
@ISA =3D qw(Exporter);
@EXPORT =3D qw();
@EXPORT_OK =3D qw();
use strict;
use Fcntl;
use vars qw($VERSION @EXPORT @EXPORT_OK);
$VERSION =3D substr(q$Revision: 1.1 $, 10);
BEGIN {
require 5.005;
($Global::VendRoot =3D $ENV{INTERCHANGE_ROOT})
if defined $ENV{INTERCHANGE_ROOT};
($Global::CatRoot =3D $ENV{INTERCHANGE_CATDIR})
if defined $ENV{INTERCHANGE_ROOT};
=09
$Global::VendRoot =3D $Global::VendRoot || '/work/minivend';
#$Global::VendRoot =3D $Global::VendRoot || '~_~INSTALLARCHLIB~_~';
$Global::CatRoot =3D $Global::CatRoot || '/work/minivend';
#$Global::VendRoot =3D $Global::VendRoot || '~_~INSTALLARCHLIB~_~';
$Global::ConfigFile =3D 'minivend.structure';
}
my $Eval_routine;
my $Eval_routine_file;
my $Pretty_uneval;
my $Fast_uneval;
my $Fast_uneval_file;
### END CONFIGURABLE MODULES
# leaving out 0, O and 1, l
my $random_chars =3D "ABCDEFGHIJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz234=
56789";
# Return a string of random characters.
sub random_string {
my ($len) =3D @_;
$len =3D 8 unless $len;
my ($r, $i);
$r =3D '';
for ($i =3D 0; $i < $len; ++$i) {
$r .=3D substr($random_chars, int(rand(length($random_chars))), 1);
}
$r;
}
sub hexify {
my $string =3D shift;
$string =3D~ s/(\W)/sprintf '%%%02x', ord($1)/ge;
return $string;
}
sub unhexify {
my $s =3D shift;
$s =3D~ s/%(..)/chr(hex($1))/ge;
return $s;
}
## UNEVAL
# Returns a string representation of an anonymous array, hash, or scaler
# that can be eval'ed to produce the same value.
# uneval([1, 2, 3, [4, 5]]) -> '[1,2,3,[4,5,],]'
# Uses either Storable::freeze or Data::Dumper::DumperX or uneval=20
# in=20
sub uneval_it {
my($o) =3D @_; # recursive
my($r, $s, $i, $key, $value);
local($^W) =3D 0;
$r =3D ref $o;
if (!$r) {
$o =3D~ s/([\\"\$@])/\\$1/g;
$s =3D '"' . $o . '"';
} elsif ($r eq 'ARRAY') {
$s =3D "[";
foreach $i (0 .. $#$o) {
$s .=3D uneval_it($o->[$i]) . ",";
}
$s .=3D "]";
} elsif ($r eq 'HASH') {
$s =3D "{";
while (($key, $value) =3D each %$o) {
$s .=3D "'$key' =3D> " . uneval_it($value) . ",";
}
$s .=3D "}";
} else {
$s =3D "'something else'";
}
$s;
}
use subs 'uneval_fast';
sub uneval_it_file {
my ($ref, $fn) =3D @_;
open(UNEV, ">$fn")=20
or die "Can't create $fn: $!\n";
print UNEV uneval_fast($ref);
close UNEV;
}
sub eval_it_file {
my ($fn) =3D @_;
local($/) =3D undef;
open(UNEV, "< $fn") or return undef;
my $ref =3D evalr(<UNEV>);
close UNEV;
return $ref;
}
# See if we have Storable and the user has OKed its use
# If so, session storage/write will be about 5x faster
eval {
die unless $ENV{MINIVEND_STORABLE} || -f "$Global::VendRoot/_session_stora=
ble";
require Storable;
import Storable 'freeze';
$Fast_uneval =3D \&Storable::freeze;
$Fast_uneval_file =3D \&Storable::store;
$Eval_routine =3D \&Storable::thaw;
$Eval_routine_file =3D \&Storable::retrieve;
};
# See if Data::Dumper is installed with XSUB
# If it is, session writes will be about 25-30% faster
eval {
require Data::Dumper;
import Data::Dumper 'DumperX';
$Data::Dumper::Indent =3D 1;
$Data::Dumper::Terse =3D 1;
$Pretty_uneval =3D \&Data::Dumper::DumperX;
$Fast_uneval =3D \&Data::Dumper::DumperX
unless defined $Fast_uneval;
};
*uneval_fast =3D defined $Fast_uneval ? $Fast_uneval : \&uneval=
_it;
*evalr =3D defined $Eval_routine ? $Eval_routine : sub { ev=
al shift };
*eval_file =3D defined $Eval_routine_file ? $Eval_routine_file : \&eval_i=
t_file;
*uneval_file =3D defined $Fast_uneval_file ? $Fast_uneval_file : \&uneval=
_it_file;
*uneval =3D defined $Pretty_uneval ? $Pretty_uneval : \&uneval=
_it;
# Returns a URL which will run the ordering system again. Each URL
# contains the session ID as well as a unique integer to avoid caching
# of pages by the browser.
my %Special =3D (
=09=09=09=09=09
);
sub new {
my ($class, @options) =3D=20
my ($k, $v);
my $self =3D {};
while (defined ($k =3D shift(@options))) {
($self->{$k} =3D shift(@options), next)
unless defined $Special{lc $k};
my $arg =3D shift @options;
$Special{lc $k}->($self, $arg);
}
if(! $self->{Cfg}{CatRoot}) {
for( $ENV{INTERCHANGE_CATDIR}, ) {
if(-f $ENV{INTERCHANGE_CATDIR}) {
}
}
}
unless (defined $self->{session}) {
}
bless $self, $class;
}
sub vendUrl {
my($path, $arguments, $r) =3D @_;
$r =3D $Vend::Cfg->{VendURL}
unless defined $r;
my @parms;
if(defined $Vend::Cfg->{AlwaysSecure}{$path}) {
$r =3D $Vend::Cfg->{SecureURL};
}
my($id, $ct);
$id =3D $Vend::SessionID
unless $CGI::cookie && $::Scratch->{mv_no_session_id};
$r .=3D '/' . $path;
$r .=3D '.html' if $::Scratch->{mv_add_dot_html} and $r !~ /\.html?$/;
push @parms, "mv_session_id=3D$id" if defined $id;
push @parms, "mv_arg=3D" . hexify($arguments) if defined $arguments;
push @parms, "mv_cat=3D$Vend::Cfg->{CatalogName}"
if defined $Vend::VirtualCat;
return $r unless @parms;
return $r . '?' . join("&", @parms);
}=20
sub secure_vendUrl {
return vendUrl($_[0], $_[1], $Vend::Cfg->{SecureURL});
}
my $use =3D undef;
### flock locking
# sys/file.h:
my $flock_LOCK_SH =3D 1; # Shared lock
my $flock_LOCK_EX =3D 2; # Exclusive lock
my $flock_LOCK_NB =3D 4; # Don't block when locking
my $flock_LOCK_UN =3D 8; # Unlock
sub flock_lock {
my ($fh, $excl, $wait) =3D @_;
my $flag =3D $excl ? $flock_LOCK_EX : $flock_LOCK_SH;
if ($wait) {
flock($fh, $flag) or die "Could not lock file: $!\n";
return 1;
}
else {
if (! flock($fh, $flag | $flock_LOCK_NB)) {
if ($! =3D~ m/^Try again/
or $! =3D~ m/^Resource temporarily unavailable/
or $! =3D~ m/^Operation would block/) {
return 0;
}
else {
die "Could not lock file: $!\n";
}
}
return 1;
}
}
sub flock_unlock {
my ($fh) =3D @_;
flock($fh, $flock_LOCK_UN) or die "Could not unlock file: $!\n";
}
### Select based on os, vestigial
use vars qw($lock_function $unlock_function);
$lock_function =3D \&flock_lock;
$unlock_function =3D \&flock_unlock;
sub fcntl_lock {
my ($fh, $excl, $wait) =3D @_;
my $flag =3D $excl ? F_WRLCK : F_RDLCK;
my $buf =3D pack("ssLL",$flag,0,0,0);
LOCKLOOP:{
if ($wait) {
if (! fcntl($fh, F_SETLKW, $buf)) {
redo LOCKLOOP if $! =3D~ m/^Interrupted/;
die "Could not lock file: $!\n";
}
}
else {
if (! fcntl($fh, F_SETLK, $buf)) {
redo LOCKLOOP if $! =3D~ m/^Interrupted/;
if ($! =3D~ m/^Try again/
or $! =3D~ m/^Resource temporarily unavailable/
or $! =3D~ m/^Operation would block/) {
return 0;
}
die "Could not lock file: $!\n";
}
}
return 1;
}
}
sub fcntl_unlock {
my ($fh) =3D @_;
my $buf =3D pack("ssLL",F_WRLCK,0,0,0);
fcntl($fh, F_UNLCK, $buf) or die "Could not unlock file: $!\n";
}
sub set_lock_function {
my ($self, $arg) =3D @_;
if(!$arg) {
return ($self->{_config}{lock_type} ||=3D 'flock');
}
elsif ($arg eq 'flock') {
$lock_function =3D \&flock_lock;
$unlock_function =3D \&flock_unlock;
return ($self->{_config}{lock_type} =3D 'flock');
}
elsif($arg eq 'fcntl') {
$lock_function =3D \&fcntl_lock;
$unlock_function =3D \&fcntl_unlock;
return ($self->{_config}{lock_type} =3D 'fcntl');
}
elsif ($arg eq 'none') {
warn "Using NO locking: I hope you know what you are doing!"
unless $^O =3D~ /win32/i;
$lock_function =3D sub {1};
$unlock_function =3D sub {1};
return ($self->{_config}{lock_type} =3D 'none');
}
else {
die "unknown lock function $arg";
}
}
sub lockfile {
&$lock_function(@_);
}
sub unlockfile {
&$unlock_function(@_);
}
# Returns the total number of items ordered.
# Uses the current cart if none specified.
sub tag_nitems {
my($self, $opt) =3D @_;
=09
$opt->{cart} =3D ($self->{_config}{current_cart} ||=3D 'main')
unless $opt->{cart};
=09
my ($attr, $sub);
if($opt->{qualifier}) {
$attr =3D $opt->{qualifier};
my $qr;
$qr =3D qr{$opt->{compare}}
if $opt->{compare};
if($opt->{compare}) {
$sub =3D sub {=20
$_[0] =3D~ $qr;
};
}
else {
$sub =3D sub { return $_[0] };
}
}
my $total =3D 0;
foreach my $item (@{$opt->{cart}}) {
next if $attr and ! $sub->($item->{$attr});
$total +=3D $item->{'quantity'};
}
$total;
}
sub errmsg {
my($fmt, @strings) =3D @_;
my $location;
if($Vend::Cfg->{Locale} and defined $Vend::Cfg->{Locale}{$fmt}) {
$location =3D $Vend::Cfg->{Locale};
}
elsif($Global::Locale and defined $Global::Locale->{$fmt}) {
$location =3D $Global::Locale;
}
return sprintf $fmt, @strings if ! $location;
if(ref $location->{$fmt}) {
$fmt =3D $location->{$fmt}[0];
@strings =3D @strings[ @{ $location->{$fmt}[1] } ];
}
else {
$fmt =3D $location->{$fmt};
}
return sprintf $fmt, @strings;
}
# Here for convenience in calls
sub set_cookie {
my ($name, $value, $expire) =3D @_;
$::Instance->{Cookies} =3D []
if ! $::Instance->{Cookies};
@{$::Instance->{Cookies}} =3D [$name, $value, $expire];
return;
}
# Here for convenience in calls
sub read_cookie {
my ($lookfor, $string) =3D @_;
$string =3D $ENV{HTTP_COOKIE}
unless defined $string;
return undef unless $string =3D~ /\b$lookfor=3D([^\s;]+)/i;
return unhexify($1);
}
# Return a quasi-hashed directory/file combo, creating if necessary
sub exists_filename {
my ($file,$levels,$chars, $dir) =3D @_;
my $i;
$levels =3D 1 unless defined $levels;
$chars =3D 1 unless defined $chars;
$dir =3D $Vend::Cfg->{ScratchDir} unless $dir;
for($i =3D 0; $i < $levels; $i++) {
$dir .=3D "/";
$dir .=3D substr($file, $i * $chars, $chars);
return 0 unless -d $dir;
}
return -f "$dir/$file" ? 1 : 0;
}
# Return a quasi-hashed directory/file combo, creating if necessary
sub get_filename {
my ($file,$levels,$chars, $dir) =3D @_;
my $i;
$levels =3D 1 unless defined $levels;
$chars =3D 1 unless defined $chars;
$dir =3D $Vend::Cfg->{ScratchDir} unless $dir;
for($i =3D 0; $i < $levels; $i++) {
$dir .=3D "/";
$dir .=3D substr($file, $i * $chars, $chars);
mkdir $dir, 0777 unless -d $dir;
}
die "Couldn't make directory $dir (or parents): $!\n"
unless -d $dir;
return "$dir/$file";
}
# These were stolen from File::Spec
# Can't use that because it INSISTS on object
# calls without returning a blessed object
my $abspat =3D $^O =3D~ /win32/i ? '^([a-z]:)?[\\\\/]' : '^/';
sub file_name_is_absolute {
my($file) =3D @_;
$file =3D~ m{$abspat}oi ;
}
sub win_catfile {
my $file =3D pop @_;
return $file unless @_;
my $dir =3D catdir(@_);
$dir =3D~ s/(\\\.)$//;
$dir .=3D "\\" unless substr($dir,length($dir)-1,1) eq "\\";
return $dir.$file;
}
sub unix_catfile {
my $file =3D pop @_;
return $file unless @_;
my $dir =3D catdir(@_);
for ($dir) {
$_ .=3D "/" unless substr($_,length($_)-1,1) eq "/";
}
return $dir.$file;
}
sub unix_path {
my $path_sep =3D ":";
my $path =3D $ENV{PATH};
my @path =3D split $path_sep, $path;
foreach(@path) { $_ =3D '.' if $_ eq '' }
@path;
}
sub win_path {
local $^W =3D 1;
my $path =3D $ENV{PATH} || $ENV{Path} || $ENV{'path'};
my @path =3D split(';',$path);
foreach(@path) { $_ =3D '.' if $_ eq '' }
@path;
}
sub win_catdir {
my @args =3D @_;
for (@args) {
# append a slash to each argument unless it has one there
$_ .=3D "\\" if $_ eq '' or substr($_,-1) ne "\\";
}
my $result =3D canonpath(join('', @args));
$result;
}
sub win_canonpath {
my($path) =3D @_;
$path =3D~ s/^([a-z]:)/\u$1/;
$path =3D~ s|/|\\|g;
$path =3D~ s|\\+|\\|g ; # xx////xx -> xx/xx
$path =3D~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx
$path =3D~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx
$path =3D~ s|\\$||=20
unless $path =3D~ m#^([a-z]:)?\\#; # xx/ -> xx
$path .=3D '.' if $path =3D~ m#\\$#;
$path;
}
sub unix_canonpath {
my($path) =3D @_;
$path =3D~ s|/+|/|g ; # xx////xx -> xx/xx
$path =3D~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx
$path =3D~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx
$path =3D~ s|/$|| unless $path eq "/"; # xx/ -> xx
$path;
}
sub unix_catdir {
my @args =3D @_;
for (@args) {
# append a slash to each argument unless it has one there
$_ .=3D "/" if $_ eq '' or substr($_,-1) ne "/";
}
my $result =3D join('', @args);
# remove a trailing slash unless we are root
substr($result,-1) =3D ""
if length($result) > 1 && substr($result,-1) eq "/";
$result;
}
my $catdir_routine;
my $canonpath_routine;
my $catfile_routine;
my $path_routine;
if($^O =3D~ /win32/i) {
$catdir_routine =3D \&win_catdir;
$catfile_routine =3D \&win_catfile;
$path_routine =3D \&win_path;
$canonpath_routine =3D \&win_canonpath;
}
else {
$catdir_routine =3D \&unix_catdir;
$catfile_routine =3D \&unix_catfile;
$path_routine =3D \&unix_path;
$canonpath_routine =3D \&unix_canonpath;
}
sub path {
return &{$path_routine}(@_);
}
sub catfile {
return &{$catfile_routine}(@_);
}
sub catdir {
return &{$catdir_routine}(@_);
}
sub canonpath {
return &{$canonpath_routine}(@_);
}
#print "catfile a b c --> " . catfile('a', 'b', 'c') . "\n";
#print "catdir a b c --> " . catdir('a', 'b', 'c') . "\n";
#print "canonpath a/b//../../c --> " . canonpath('a/b/../../c') . "\n";
#print "file_name_is_absolute a/b/c --> " . file_name_is_absolute('a/b/c') =
"\n";
#print "file_name_is_absolute a:b/c --> " . file_name_is_absolute('a:b/c') =
"\n";
#print "file_name_is_absolute /a/b/c --> " . file_name_is_absolute('/a/b/c'=
) . "\n";
1;
__END__