First pass at adding key files
This commit is contained in:
dsainty
306
site/slowtwitch.com/cgi-bin/articles/GT/AutoLoader.pm
Normal file
306
site/slowtwitch.com/cgi-bin/articles/GT/AutoLoader.pm
Normal file
@ -0,0 +1,306 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::AutoLoader
|
||||
# Author: Jason Rhinelander
|
||||
# $Id: AutoLoader.pm,v 1.13 2005/03/21 06:57:58 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::AutoLoader;
|
||||
|
||||
use vars qw($AUTOLOAD %LOG %PACKAGES);
|
||||
use strict qw/vars subs/; # no strict 'refs' - we need several soft references here.
|
||||
|
||||
sub import {
|
||||
shift; # Discard the package, as 'use GT::AutoLoader' calls GT::AutoLoader->import(ARGS)
|
||||
my %opts = @_;
|
||||
|
||||
my $pkg = caller;
|
||||
++$PACKAGES{$pkg};
|
||||
|
||||
if ($opts{LOG} and ref $opts{LOG} eq 'CODE') {
|
||||
$LOG{$pkg} = delete $opts{LOG}; # Everything that requests a log will get one for all modules
|
||||
}
|
||||
|
||||
delete $opts{NAME} if $opts{NAME} and $opts{NAME} eq 'AUTOLOAD'; # Allows "if ($opts{NAME})" later on.
|
||||
|
||||
my $COMPILE;
|
||||
*{$pkg . ($opts{NAME} ? "::$opts{NAME}" : '::AUTOLOAD')} = sub {
|
||||
if ($opts{NAME} or !$AUTOLOAD) { # If they're using another name, it most likely means they are wrapping the AUTOLOAD, which means we have to check for $AUTOLOAD in their package.
|
||||
$AUTOLOAD = ${$pkg . '::AUTOLOAD'};
|
||||
}
|
||||
my ($func) = $AUTOLOAD =~ /([^:]+)$/; # How odd - we use $GT::AutoLoader::AUTOLOAD, even though this is run in some other package
|
||||
|
||||
if ($COMPILE = \%{$pkg . '::COMPILE'}) {
|
||||
if (defined $COMPILE->{$func}) {
|
||||
for (keys %LOG) { $LOG{$_}->($pkg, $func, 'COMPILE') }
|
||||
|
||||
_compile($COMPILE, $pkg, $func);
|
||||
|
||||
$AUTOLOAD = '';
|
||||
|
||||
goto &{"$pkg\::$func"};
|
||||
}
|
||||
}
|
||||
|
||||
if ($opts{NEXT}) {
|
||||
my ($pack, $func) = $opts{NEXT} =~ /(?:(.+)::)?([^:]+?)$/;
|
||||
$pack ||= $pkg;
|
||||
${$pack . '::AUTOLOAD'} = $AUTOLOAD;
|
||||
my $next = "$pack\::$func";
|
||||
$AUTOLOAD = '';
|
||||
goto &$next;
|
||||
}
|
||||
|
||||
# It doesn't exist in %COMPILE, which means we have to look through @ISA for another AUTOLOAD to pass this to
|
||||
if (my @inh = @{"$pkg\::ISA"}) {
|
||||
while (my $inh = shift @inh) {
|
||||
my $al = $inh . '::AUTOLOAD';
|
||||
if (defined &$al) {
|
||||
$$al = "$pkg\::$func"; # Sets $Other::Package::AUTOLOAD
|
||||
$AUTOLOAD = '';
|
||||
goto &$al;
|
||||
}
|
||||
elsif (my @isa = @{$inh . '::ISA'}) {
|
||||
unshift @inh, @isa;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my ($file, $line) = (caller)[1,2];
|
||||
$AUTOLOAD = '';
|
||||
die "$pkg ($$, GT::AutoLoader): Unknown method '$func' called at $file line $line.\n";
|
||||
};
|
||||
|
||||
my $compile = "$pkg\::COMPILE";
|
||||
*$compile = \%$compile; # Implements "use vars qw/%COMPILE/" for you
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
if ($^C) {
|
||||
eval <<'CHECK';
|
||||
sub CHECK {
|
||||
# ------------------------------------------------------------------------------
|
||||
# In Perl 5.6+ this allows you to do: perl -cMMy::Module -e0 to make sure all
|
||||
# your %COMPILE subs compile. In versions of Perl prior to 5.6, this is simply
|
||||
# treated as a sub named "CHECK", which is never called. $^C is also 5.6+
|
||||
# specific - whether or not you are running under "-c"
|
||||
compile_all();
|
||||
}
|
||||
CHECK
|
||||
}
|
||||
}
|
||||
|
||||
sub compile_all {
|
||||
my @pkg = @_;
|
||||
if (@pkg) {
|
||||
@pkg = grep +($PACKAGES{$_} or (warn "$_ is not loaded, does not use GT::AutoLoader, or is not a valid package" and 0)), @pkg;
|
||||
@pkg or die "No valid packages passed to compile_all()!";
|
||||
}
|
||||
else {
|
||||
@pkg = keys %PACKAGES;
|
||||
}
|
||||
|
||||
for my $pkg (@pkg) {
|
||||
my $COMPILE = \%{$pkg . '::COMPILE'} or next;
|
||||
for my $func (keys %$COMPILE) {
|
||||
_compile($COMPILE, $pkg, $func) if $COMPILE->{$func};
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _compile {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Compiles a subroutine from a module's %COMPILE into the module's package.
|
||||
# die()s if the subroutine cannot compile or still does not exist after
|
||||
# compiling. Takes three arguments: A reference to the packages %COMPILE hash,
|
||||
# the package, and the name of the function to load.
|
||||
#
|
||||
my ($COMPILE, $pkg, $func) = @_;
|
||||
|
||||
my $linenum = ($COMPILE->{$func} =~ s/^(\d+)//) ? $1+1 : 0;
|
||||
eval "package $pkg;\n#line $linenum$pkg\::$func\n$COMPILE->{$func}";
|
||||
if ($@) { die "Unable to load $pkg\::$func: $@" }
|
||||
if (not defined &{"$pkg\::$func"}) {
|
||||
die "Unable to load $pkg\::$func: Subroutine did not compile correctly (possible bad name).";
|
||||
}
|
||||
|
||||
undef $COMPILE->{$func}; # Leave the key in the compile hash so that things can test to see if it was defined in the compile hash
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::AutoLoader - load subroutines on demand
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package GT::Module;
|
||||
use GT::AutoLoader; # You now have an AUTOLOAD subroutine that will check for entries in %COMPILE
|
||||
|
||||
or
|
||||
|
||||
package GT::OtherModule;
|
||||
use GT::AutoLoader(NAME => '_AUTOLOAD'); # Import AUTOLOAD as _AUTOLOAD, define our own AUTOLOAD
|
||||
sub AUTOLOAD {
|
||||
...
|
||||
goto &_AUTOLOAD;
|
||||
}
|
||||
|
||||
then:
|
||||
|
||||
$COMPILE{sub} = __LINE__ . <<'END_OF_SUB';
|
||||
sub method_name {
|
||||
...
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The B<GT::AutoLoader> module works as a way to speed up your code. Currently,
|
||||
the only thing it does is scan for a %COMPILE hash in your package. If it finds
|
||||
it, it looks for the subroutine you called, and if found compiles and runs it.
|
||||
|
||||
If unable to find a subroutine to compile in %COMPILE, B<GT::AutoLoader> will
|
||||
scan your inheritance tree (@ISA) for another AUTOLOAD subroutine to pass this
|
||||
off to. If there isn't any, a fatal error occurs.
|
||||
|
||||
To use B<GT::AutoLoader>, in its standard behaviour, simply put:
|
||||
C<use GT::AutoLoader;> in your module. When you use GT::AutoLoader, two things
|
||||
will happen. First, an C<AUTOLOAD> subroutine will be imported into your
|
||||
namespace that will automatically compile your subroutines only when they are
|
||||
needed, thus speeding up compile time. Secondly, a %COMPILE hash will be defined
|
||||
in your package, eliminating the need for you to: use vars qw/%COMPILE/;
|
||||
|
||||
=head1 USE
|
||||
|
||||
You can pass options to GT::AutoLoader to change the behaviour of the module.
|
||||
Currently, logging is the only option, however more options (perhaps including
|
||||
a different compiling scheme) will be added at some future point.
|
||||
|
||||
Options are specified as import() arguments. For example:
|
||||
|
||||
use GT::AutoLoader(OPTION => "value");
|
||||
|
||||
=over 4
|
||||
|
||||
=item NAME
|
||||
|
||||
If you want to import the autoload subroutine as something other than
|
||||
'Package::AUTOLOAD', the 'NAME' option should be used. Its value is the name
|
||||
to import as. For example, to import a GT::AutoLoader AUTOLOAD named _AUTOLOAD
|
||||
(this is useful when declaring your own AUTOLOAD behaviour, but still using
|
||||
GT::AutoLoader's behaviour as a fallback), you would do something like:
|
||||
|
||||
use GT::AutoLoader(NAME => '_AUTOLOAD');
|
||||
|
||||
=item LOG
|
||||
|
||||
Takes a code reference as its value. The code reference will be called three
|
||||
arguments - the package name, the name of the function, and the autoload method
|
||||
(Currently only 'COMPILE'). Note that this will be called for ALL autoloaded
|
||||
subroutines, not just the ones in your package.
|
||||
|
||||
WARNING - you cannot put code in your log that relies on autoloaded methods -
|
||||
you'll end up throwing the program into an infinite loop.
|
||||
|
||||
For example, to get a line of debugging after each subroutine is compiled, you
|
||||
could C<use GT::AutoLoader> like this:
|
||||
|
||||
use GT::AutoLoader(LOG => sub {
|
||||
print "Compiled $_[1] in package $_[0]\n"
|
||||
});
|
||||
|
||||
=item NEXT
|
||||
|
||||
Normally, GT::AutoLoader will look for another AUTOLOAD to call in your
|
||||
package's @ISA inheritance tree. You can alter this behaviour and tell
|
||||
GT::AutoLoader what to call next using the NEXT option.
|
||||
|
||||
For example, if you have a sub _AUTOLOAD { } that you wanted to call if the
|
||||
method isn't found by GT::AutoLoader, you would use GT::AutoLoader like this:
|
||||
|
||||
use GT::AutoLoader(NEXT => 'Package::Name::_AUTOLOAD');
|
||||
|
||||
The _AUTOLOAD function in your package will now be called if GT::AutoLoader
|
||||
can't load the method on its own. $AUTOLOAD will be set for you in whichever
|
||||
package the function you provide is in. Note that if you simply want to use an
|
||||
inherited AUTOLOAD, you B<should not> use this option; GT::AutoLoader will
|
||||
handle that just fine on its own.
|
||||
|
||||
You may omit the package (Package::Name::) if the function is in your current
|
||||
package.
|
||||
|
||||
=back
|
||||
|
||||
=head1 compile_all
|
||||
|
||||
A function exists in GT::AutoLoader to compile all %COMPILE-subroutines. By
|
||||
default (without arguments) compile_all() compiles every %COMPILE-subroutine in
|
||||
every package that has used GT::AutoLoader. You can, however, pass in a list of
|
||||
packages which compile_all() will check instead of compiling everything. Note
|
||||
that GT::AutoLoader will only compile %COMPILE-subroutines in packages that
|
||||
have used GT::AutoLoader, so if you specify package "Foo", but "Foo" hasn't
|
||||
used GT::AutoLoader, it will be ignored.
|
||||
|
||||
You can do something like:
|
||||
|
||||
GT::AutoLoader::compile_all(__PACKAGE__) if MOD_PERL;
|
||||
|
||||
to have a GT::AutoLoader compile every %COMPILE-subroutine in the current
|
||||
package automatically under mod_perl, or you could add this code to your
|
||||
mod_perl startup file or test script:
|
||||
|
||||
GT::AutoLoader::compile_all;
|
||||
|
||||
Test scripts should definately use compile_all() to ensure that all subroutines
|
||||
compile correctly!
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
None.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Due to the nature of Perl's AUTOLOAD handling, you must take care when using
|
||||
GT::AutoLoader in a subclass. In short, subclassed methods B<MUST NOT> be put
|
||||
into the %COMPILE hash.
|
||||
|
||||
The problem is that since the subroutine does not exist in the package, Perl,
|
||||
while decending the inheritance tree, will not see it but will probably see the
|
||||
parent's method (unless nothing else has called the method, but you should
|
||||
never count on that), and call it rather than looking for your package's
|
||||
AUTOLOAD.
|
||||
|
||||
This isn't to say that subclasses cannot use AUTOLOAD - just that subclasses
|
||||
cannot use autoloaded methods (%COMPILE-subroutines) if a method of the same
|
||||
name exists in the parent class. Autoloaded function calls are not affected.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Base>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: AutoLoader.pm,v 1.13 2005/03/21 06:57:58 jagerman Exp $
|
||||
|
||||
=cut
|
||||
964
site/slowtwitch.com/cgi-bin/articles/GT/Base.pm
Normal file
964
site/slowtwitch.com/cgi-bin/articles/GT/Base.pm
Normal file
@ -0,0 +1,964 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Base
|
||||
# Author : Alex Krohn
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Base.pm,v 1.135 2007/11/10 06:46:21 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base module that handles common functions like initilization,
|
||||
# debugging, etc. Should not be used except as a base class.
|
||||
#
|
||||
|
||||
package GT::Base;
|
||||
# ===============================================================
|
||||
require 5.004; # We need perl 5.004 for a lot of the OO features.
|
||||
|
||||
use strict qw/vars subs/; # No refs as we do some funky stuff.
|
||||
use vars qw/$AUTOLOAD $DEBUG $VERSION $ATTRIB_CACHE %ERRORS @EXPORT_OK %EXPORT_TAGS @ISA/;
|
||||
use GT::AutoLoader(NEXT => 'GT::Base::_AUTOLOAD');
|
||||
use Exporter();
|
||||
|
||||
# We need to inherit from Exporter for ->require_version support
|
||||
@ISA = qw/Exporter/;
|
||||
|
||||
BEGIN {
|
||||
if ($ENV{MOD_PERL}) {
|
||||
eval { require mod_perl2 } or eval { require mod_perl };
|
||||
}
|
||||
require CGI::SpeedyCGI if $CGI::SpeedyCGI::i_am_speedy or $CGI::SpeedyCGI::_i_am_speedy;
|
||||
}
|
||||
use constants
|
||||
MOD_PERL => $ENV{MOD_PERL} ? $mod_perl2::VERSION || $mod_perl::VERSION : 0,
|
||||
SPEEDY => $CGI::SpeedyCGI::_i_am_speedy || $CGI::SpeedyCGI::i_am_speedy ? $CGI::SpeedyCGI::VERSION : 0;
|
||||
use constants
|
||||
PERSIST => MOD_PERL || SPEEDY;
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.135 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIB_CACHE = {};
|
||||
%ERRORS = (
|
||||
MKDIR => "Could not make directory '%s': %s",
|
||||
OPENDIR => "Could not open directory '%s': %s",
|
||||
RMDIR => "Could not remove directory '%s': %s",
|
||||
CHMOD => "Could not chmod '%s': %s",
|
||||
UNLINK => "Could not unlink '%s': %s",
|
||||
READOPEN => "Could not open '%s' for reading: %s",
|
||||
WRITEOPEN => "Could not open '%s' for writing: %s",
|
||||
OPEN => "Could not open '%s': %s",
|
||||
BADARGS => "Wrong argument passed to this subroutine. %s"
|
||||
);
|
||||
@EXPORT_OK = qw/MOD_PERL SPEEDY PERSIST $MOD_PERL $SPEEDY $PERSIST/;
|
||||
%EXPORT_TAGS = (
|
||||
all => \@EXPORT_OK,
|
||||
persist => [qw/MOD_PERL SPEEDY PERSIST/]
|
||||
);
|
||||
|
||||
# These three are for backwards-compatibility with what GT::Base used to
|
||||
# export; new code should import and use the constants of the same name.
|
||||
use vars qw/$MOD_PERL $SPEEDY $PERSIST/;
|
||||
$MOD_PERL = MOD_PERL;
|
||||
$SPEEDY = SPEEDY;
|
||||
$PERSIST = PERSIST;
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------
|
||||
# Create a base object and use set or init to initilize anything.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
|
||||
# Create self with our debug value.
|
||||
my $self = { _debug => defined ${"$class\:\:DEBUG"} ? ${"$class\:\:DEBUG"} : $DEBUG };
|
||||
bless $self, $class;
|
||||
$self->debug("Created new $class object.") if $self->{_debug} > 2;
|
||||
|
||||
# Set initial attributes, and then run init function or call set.
|
||||
$self->reset;
|
||||
if ($self->can('init')) {
|
||||
$self->init(@_);
|
||||
}
|
||||
else {
|
||||
$self->set(@_) if (@_);
|
||||
}
|
||||
|
||||
if (index($self, 'HASH') != -1) {
|
||||
$self->{_debug} = $self->{debug} if $self->{debug};
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# -------------------------------------------------------
|
||||
# Object is nuked.
|
||||
#
|
||||
(index($_[0], 'HASH') > -1) or return;
|
||||
if ($_[0]->{_debug} and $_[0]->{_debug} > 2) {
|
||||
my ($package, $filename, $line) = caller;
|
||||
$_[0]->debug("Destroyed $_[0] in package $package at $filename line $line.");
|
||||
}
|
||||
}
|
||||
|
||||
sub _AUTOLOAD {
|
||||
# -------------------------------------------------------
|
||||
# We use autoload to provide an accessor/setter for all
|
||||
# attributes.
|
||||
#
|
||||
my ($self, $param) = @_;
|
||||
my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/;
|
||||
|
||||
# If this is a known attribute, return/set it and save the function
|
||||
# to speed up future calls.
|
||||
my $autoload_attrib = 0;
|
||||
if (ref $self and index($self, 'HASH') != -1 and exists $self->{$attrib} and not exists $COMPILE{$attrib}) {
|
||||
$autoload_attrib = 1;
|
||||
}
|
||||
else {
|
||||
# Class method possibly.
|
||||
unless (ref $self) {
|
||||
my $attribs = $ATTRIB_CACHE->{$self} || _get_attribs($self);
|
||||
if (exists $attribs->{$attrib}) {
|
||||
$autoload_attrib = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
# This is an accessor, create a function for it.
|
||||
if ($autoload_attrib) {
|
||||
*{$AUTOLOAD} = sub {
|
||||
unless (ref $_[0]) { # Class Method
|
||||
my $attribs = $ATTRIB_CACHE->{$_[0]} || _get_attribs($_[0]);
|
||||
if (@_ > 1) {
|
||||
$_[0]->debug("Setting base attribute '$attrib' => '$_[1]'.") if defined ${$_[0] . '::DEBUG'} and ${$_[0] . '::DEBUG'} > 2;
|
||||
$ATTRIB_CACHE->{$_[0]}->{$attrib} = $_[1];
|
||||
}
|
||||
return $ATTRIB_CACHE->{$_[0]}->{$attrib};
|
||||
}
|
||||
if (@_ > 1) { # Instance Method
|
||||
$_[0]->debug("Setting '$attrib' => '$_[1]'.") if $_[0]->{_debug} and $_[0]->{_debug} > 2;
|
||||
$_[0]->{$attrib} = $_[1];
|
||||
}
|
||||
return $_[0]->{$attrib};
|
||||
};
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
# Otherwise we have an error, let's help the user out and try to
|
||||
# figure out what they were doing.
|
||||
_generate_fatal($self, $attrib, $param);
|
||||
}
|
||||
|
||||
sub set {
|
||||
# -------------------------------------------------------
|
||||
# Set one or more attributes.
|
||||
#
|
||||
return unless (@_);
|
||||
if ( !ref $_[0]) { class_set(@_); }
|
||||
else {
|
||||
my $self = shift;
|
||||
my $p = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', "Argument to set must be either hash, hash ref, array, array ref or CGI object.");
|
||||
my $attribs = $ATTRIB_CACHE->{ref $self} || _get_attribs(ref $self);
|
||||
my $f = 0;
|
||||
$self->{_debug} = $p->{debug} || 0 if exists $p->{debug};
|
||||
foreach my $attrib (keys %$attribs) {
|
||||
next unless exists $p->{$attrib};
|
||||
$self->debug("Setting '$attrib' to '${$p}{$attrib}'.") if $self->{_debug} and $self->{_debug} > 2;
|
||||
$self->{$attrib} = $p->{$attrib};
|
||||
$f++;
|
||||
}
|
||||
return $f;
|
||||
}
|
||||
}
|
||||
|
||||
sub common_param {
|
||||
# -------------------------------------------------------
|
||||
# Expects to find $self, followed by one or more arguments of
|
||||
# unknown types. Converts them to hash refs.
|
||||
#
|
||||
shift;
|
||||
my $out = {};
|
||||
return $out unless @_ and defined $_[0];
|
||||
CASE: {
|
||||
(ref $_[0] eq 'HASH') and do { $out = shift; last CASE };
|
||||
(UNIVERSAL::can($_[0], 'get_hash')) and do { $out = $_[0]->get_hash; last CASE };
|
||||
(UNIVERSAL::can($_[0], 'param')) and do { foreach ($_[0]->param) { my @vals = $_[0]->param($_); $out->{$_} = (@vals > 1) ? \@vals : $vals[0]; } last CASE };
|
||||
(defined $_[0] and not @_ % 2) and do { $out = {@_}; last CASE };
|
||||
return;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub reset {
|
||||
# -------------------------------------------------------
|
||||
# Resets all attribs in $self.
|
||||
#
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
my $attrib = $ATTRIB_CACHE->{$class} || _get_attribs($class);
|
||||
|
||||
# Deep copy hash and array refs only.
|
||||
while (my ($k, $v) = each %$attrib) {
|
||||
unless (ref $v) {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$self->{$k} = {};
|
||||
foreach my $k1 (keys %{$attrib->{$k}}) {
|
||||
$self->{$k}->{$k1} = $attrib->{$k}->{$k1};
|
||||
}
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$self->{$k} = [];
|
||||
foreach my $v1 (@{$attrib->{$k}}) {
|
||||
push @{$self->{$k}}, $v1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _get_attribs {
|
||||
# -------------------------------------------------------
|
||||
# Searches through ISA and returns this packages attributes.
|
||||
#
|
||||
my $class = shift;
|
||||
my $attrib = defined ${"$class\:\:ATTRIBS"} ? ${"$class\:\:ATTRIBS"} : {};
|
||||
my @pkg_isa = defined @{"$class\:\:ISA"} ? @{"$class\:\:ISA"} : ();
|
||||
|
||||
foreach my $pkg (@pkg_isa) {
|
||||
next if $pkg eq 'Exporter'; # Don't mess with Exporter.
|
||||
next if $pkg eq 'GT::Base';
|
||||
my $fattrib = defined ${"${pkg}::ATTRIBS"} ? ${"${pkg}::ATTRIBS"} : next;
|
||||
foreach (keys %{$fattrib}) {
|
||||
$attrib->{$_} = $fattrib->{$_} unless exists $attrib->{$_};
|
||||
}
|
||||
}
|
||||
$ATTRIB_CACHE->{$class} = $attrib;
|
||||
return $attrib;
|
||||
}
|
||||
|
||||
$COMPILE{debug} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub debug {
|
||||
# -------------------------------------------------------
|
||||
# Displays a debugging message.
|
||||
#
|
||||
my ($self, $msg) = @_;
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
# Add line numbers if asked for.
|
||||
if ($msg !~ /\r?\n$/) {
|
||||
my ($package, $file, $line) = caller;
|
||||
$msg .= " at $file line $line.\n";
|
||||
}
|
||||
# Remove windows linefeeds (breaks unix terminals).
|
||||
$msg =~ s/\r//g unless ($^O eq 'MSWin32');
|
||||
$msg =~ s/\n(?=[^ ])/\n\t/g;
|
||||
if ($SIG{__WARN__}) {
|
||||
CORE::warn("$pkg ($$): $msg");
|
||||
}
|
||||
else {
|
||||
print STDERR "$pkg ($$): $msg";
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{debug_level} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub debug_level {
|
||||
# -------------------------------------------------------
|
||||
# Set the debug level for either the class or object.
|
||||
#
|
||||
if (ref $_[0]) {
|
||||
$_[0]->{_debug} = shift if @_ > 1;
|
||||
return $_[0]->{_debug};
|
||||
}
|
||||
else {
|
||||
my $pkg = shift;
|
||||
if (@_) {
|
||||
my $level = shift;
|
||||
${"${pkg}::DEBUG"} = $level;
|
||||
}
|
||||
return ${"${pkg}::DEBUG"};
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{warn} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub warn { shift->error(shift, WARN => @_) }
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{fatal} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub fatal { shift->error(shift, FATAL => @_) }
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{error} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub error {
|
||||
# -------------------------------------------------------
|
||||
# Error handler.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($msg, $level, @args) = @_;
|
||||
my $pkg = ref $self || $self;
|
||||
$level = defined $level ? $level : 'FATAL';
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
|
||||
# Load the ERROR messages.
|
||||
$self->set_basic_errors;
|
||||
|
||||
# err_pkg stores the package just before the users program for displaying where the error was raised
|
||||
# think simplified croak.
|
||||
my $err_pkg = $pkg;
|
||||
if ($is_hash) {
|
||||
$err_pkg = defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg;
|
||||
}
|
||||
|
||||
# initilize vars to silence -w warnings.
|
||||
# msg_pkg stores which package error messages are stored, defaults to self, but doesn't have to be.
|
||||
${$pkg . '::ERROR_MESSAGE'} ||= '';
|
||||
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
||||
my $debug = $is_hash ? $self->{_debug} : ${$pkg . "::DEBUG"};
|
||||
|
||||
# cls_err stores the actual error hash (error_code => error_string). Initilize to prevent -w
|
||||
# warnings.
|
||||
${$msg_pkg . '::ERRORS'} ||= {};
|
||||
${$pkg . '::ERRORS'} ||= {};
|
||||
my $cls_err = ${$msg_pkg . '::ERRORS'};
|
||||
my $pkg_err = ${$pkg . '::ERRORS'} || $pkg;
|
||||
my %messages = %$cls_err;
|
||||
foreach (keys %$pkg_err) { $messages{$_} = $pkg_err->{$_}; }
|
||||
|
||||
# Return current error if not called with arguments.
|
||||
if ($is_hash) {
|
||||
$self->{_error} ||= [];
|
||||
if (@_ == 0) {
|
||||
my @err = @{$self->{_error}} ? @{$self->{_error}} : (${$msg_pkg . "::error"});
|
||||
return wantarray ? @err : defined($err[0]) ? $err[0] : undef;
|
||||
}
|
||||
}
|
||||
elsif (@_ == 0) {
|
||||
return ${$msg_pkg . '::errcode'};
|
||||
}
|
||||
|
||||
# Set a subroutine that will clear out the error class vars, and self vars under mod_perl.
|
||||
$self->register_persistent_cleanup(sub { $self->_cleanup_obj($msg_pkg, $is_hash) });
|
||||
|
||||
# store the error code.
|
||||
${$msg_pkg . '::errcode'} ||= '';
|
||||
${$msg_pkg . '::errcode'} = $msg;
|
||||
${$msg_pkg . '::errargs'} ||= '';
|
||||
if ($is_hash) {
|
||||
$self->{_errcode} = $msg;
|
||||
$self->{_errargs} = @args ? [@args] : [];
|
||||
}
|
||||
|
||||
# format the error message.
|
||||
if (keys %messages) {
|
||||
if (exists $messages{$msg}) {
|
||||
$msg = $messages{$msg};
|
||||
}
|
||||
$msg = $msg->(@args) if ref $msg eq 'CODE'; # Pass the sprintf arguments to the code ref
|
||||
$msg = @args ? sprintf($msg, map { defined $_ ? $_ : '[undefined]' } @args) : $msg;
|
||||
|
||||
$msg =~ s/\r\n?/\n/g unless $^O eq 'MSWin32';
|
||||
$msg =~ s/\n(?=[^ ])/\n\t/g;
|
||||
}
|
||||
|
||||
# set the formatted error to $msg_pkg::error.
|
||||
push @{$self->{_error}}, $msg if ($is_hash);
|
||||
|
||||
# If we have a fatal error, then we either send it to error_handler if
|
||||
# the user has a custom handler, or print our message and die.
|
||||
|
||||
# Initialize $error to silence -w warnings.
|
||||
${$msg_pkg . '::error'} ||= '';
|
||||
if (uc $level eq 'FATAL') {
|
||||
${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? _format_err($err_pkg, \$msg) : _format_err($err_pkg, $msg);
|
||||
|
||||
die(_format_err($err_pkg, $msg)) if in_eval();
|
||||
if (exists($SIG{__DIE__}) and $SIG{__DIE__}) {
|
||||
die _format_err($err_pkg, $msg);
|
||||
}
|
||||
else {
|
||||
print STDERR _format_err($err_pkg, $msg);
|
||||
die "\n";
|
||||
}
|
||||
}
|
||||
# Otherwise we set the error message, and print it if we are in debug mode.
|
||||
elsif (uc $level eq 'WARN') {
|
||||
${$msg_pkg . '::error'} = ref ${$msg_pkg . '::error'} ? \$msg : $msg;
|
||||
my $warning = _format_err($err_pkg, $msg);
|
||||
$debug and (
|
||||
$SIG{__WARN__}
|
||||
? CORE::warn $warning
|
||||
: print STDERR $warning
|
||||
);
|
||||
$debug and $debug > 1 and (
|
||||
$SIG{__WARN__}
|
||||
? CORE::warn stack_trace('GT::Base',1)
|
||||
: print STDERR stack_trace('GT::Base',1)
|
||||
);
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_cleanup_obj} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _cleanup_obj {
|
||||
# -------------------------------------------------------
|
||||
# Cleans up the self object under a persitant env.
|
||||
#
|
||||
my ($self, $msg_pkg, $is_hash) = @_;
|
||||
|
||||
${$msg_pkg . '::errcode'} = undef;
|
||||
${$msg_pkg . '::error'} = undef;
|
||||
${$msg_pkg . '::errargs'} = undef;
|
||||
if ($is_hash) {
|
||||
defined $self and $self->{_errcode} = undef;
|
||||
defined $self and $self->{_error} = undef;
|
||||
defined $self and $self->{_errargs} = undef;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{errcode} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub errcode {
|
||||
# -------------------------------------------------------
|
||||
# Returns the last error code generated.
|
||||
#
|
||||
my $self = shift;
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
my $pkg = ref $self || $self;
|
||||
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
||||
if (ref $self and $is_hash) {
|
||||
return $self->{_errcode};
|
||||
}
|
||||
else {
|
||||
return ${$msg_pkg . '::errcode'};
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{errargs} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub errargs {
|
||||
# -------------------------------------------------------
|
||||
# Returns the arguments from the last error. In list
|
||||
# context returns an array, in scalar context returns
|
||||
# an array reference.
|
||||
#
|
||||
my $self = shift;
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
my $pkg = ref $self || $self;
|
||||
my $msg_pkg = ${$pkg . "::ERROR_MESSAGE"} ? ${$pkg . "::ERROR_MESSAGE"} : $pkg;
|
||||
my $ret = [];
|
||||
if (ref $self and $is_hash) {
|
||||
$self->{_errargs} ||= [];
|
||||
$ret = $self->{_errargs};
|
||||
}
|
||||
else {
|
||||
${$msg_pkg . '::errcode'} ||= [];
|
||||
$ret = ${$msg_pkg . '::errargs'};
|
||||
}
|
||||
return wantarray ? @{$ret} : $ret;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{clear_errors} = __LINE__ . <<'END_OF_SUB';
|
||||
sub clear_errors {
|
||||
# -------------------------------------------------------
|
||||
# Clears the error stack
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{_error} = [];
|
||||
$self->{_errargs} = [];
|
||||
$self->{_errcode} = undef;
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{set_basic_errors} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub set_basic_errors {
|
||||
# -------------------------------------------------------
|
||||
# Sets basic error messages commonly used.
|
||||
#
|
||||
my $self = shift;
|
||||
my $class = ref $self || $self;
|
||||
if (${$class . '::ERROR_MESSAGE'}) {
|
||||
$class = ${$class . '::ERROR_MESSAGE'};
|
||||
}
|
||||
${$class . '::ERRORS'} ||= {};
|
||||
my $err = ${$class . '::ERRORS'};
|
||||
for my $key (keys %ERRORS) {
|
||||
$err->{$key} = $ERRORS{$key} unless exists $err->{$key};
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{whatis} = __LINE__ . <<'END_OF_SUB';
|
||||
sub whatis {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes a package name and returns a list of all packages inherited from, in
|
||||
# the order they would be checked by Perl, _including_ the package passed in.
|
||||
# The argument may be an object or a string, and this method can be called as
|
||||
# a function, class method, or instance method. When called as a method, the
|
||||
# argument is optional - if omitted, the class name will be used.
|
||||
# Duplicate classes are _not_ included.
|
||||
#
|
||||
shift if @_ > 1;
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
my @isa = $class;
|
||||
my %found;
|
||||
my $pstash;
|
||||
for (my $c = 0; $c < @isa; $c++) {
|
||||
my $is = $isa[$c];
|
||||
my @parts = split /::/, $is;
|
||||
my $pstash = $::{shift(@parts) . "::"};
|
||||
while (defined $pstash and @parts) {
|
||||
$pstash = $pstash->{shift(@parts) . "::"};
|
||||
}
|
||||
if (defined $pstash and $pstash->{ISA} and my @is = @{*{\$pstash->{ISA}}{ARRAY}}) {
|
||||
splice @isa, $c + 1, 0,
|
||||
grep $_ eq $class
|
||||
? die "Recursive inheritance detected in package $class"
|
||||
: !$found{$_}++,
|
||||
@is;
|
||||
}
|
||||
}
|
||||
@isa
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{in_eval} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub in_eval {
|
||||
# -------------------------------------------------------
|
||||
# Current perl has a variable for it, old perl, we need to look
|
||||
# through the stack trace. Ugh.
|
||||
#
|
||||
my $ineval;
|
||||
if ($] >= 5.005 and !MOD_PERL) { $ineval = defined($^S) ? $^S : (stack_trace('GT::Base',1) =~ /\(eval\)/) }
|
||||
elsif (MOD_PERL) {
|
||||
my $stack = stack_trace('GT::Base', 1);
|
||||
$ineval = $stack =~ m{
|
||||
\(eval\)
|
||||
(?!
|
||||
\s+called\ at\s+
|
||||
(?:
|
||||
/dev/null
|
||||
|
|
||||
-e
|
||||
|
|
||||
/\S*/(?:Apache2?|ModPerl)/(?:Registry(?:Cooker)?|PerlRun)\.pm
|
||||
|
|
||||
PerlHandler\ subroutine\ `(?:Apache2?|ModPerl)::Registry
|
||||
)
|
||||
)
|
||||
}x;
|
||||
}
|
||||
else {
|
||||
my $stack = stack_trace('GT::Base', 1);
|
||||
$ineval = $stack =~ /\(eval\)/;
|
||||
}
|
||||
return $ineval;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{register_persistent_cleanup} = __LINE__ . <<'END_OF_SUB';
|
||||
sub register_persistent_cleanup {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes a code reference and registers it for cleanup under mod_perl and
|
||||
# SpeedyCGI. Has no effect when not under those environments.
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
ref(my $code = shift) eq 'CODE'
|
||||
or __PACKAGE__->fatal(BADARGS => 'Usage: GT::Base->register_persistent_cleanup($coderef)');
|
||||
|
||||
if (MOD_PERL and MOD_PERL >= 1.999022) { # Final mod_perl 2 API
|
||||
require Apache2::ServerUtil;
|
||||
if (Apache2::ServerUtil::restart_count() != 1) {
|
||||
require Apache2::RequestUtil;
|
||||
require APR::Pool;
|
||||
Apache2::RequestUtil->request->pool->cleanup_register($code);
|
||||
}
|
||||
}
|
||||
elsif (MOD_PERL and MOD_PERL >= 1.99) { # mod_perl 2 API prior to 2.0.0-RC5
|
||||
require Apache2;
|
||||
require Apache::ServerUtil;
|
||||
if (Apache::ServerUtil::restart_count() != 1) {
|
||||
require APR::Pool;
|
||||
Apache->request->pool->cleanup_register($code);
|
||||
}
|
||||
}
|
||||
elsif (MOD_PERL and $Apache::Server::Starting != 1) {
|
||||
require Apache;
|
||||
Apache->request->register_cleanup($code);
|
||||
}
|
||||
elsif (SPEEDY) {
|
||||
CGI::SpeedyCGI->new->register_cleanup($code);
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{class_set} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub class_set {
|
||||
# -------------------------------------------------------
|
||||
# Set the class init attributes.
|
||||
#
|
||||
my $pkg = shift;
|
||||
my $attribs = $ATTRIB_CACHE->{$pkg} || _get_attribs($pkg);
|
||||
|
||||
if (ref $attribs ne 'HASH') { return; }
|
||||
|
||||
# Figure out what we were passed in.
|
||||
my $out = GT::Base->common_param(@_) or return;
|
||||
|
||||
# Set the attribs.
|
||||
foreach (keys %$out) {
|
||||
exists $attribs->{$_} and ($attribs->{$_} = $out->{$_});
|
||||
}
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{attrib} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub attrib {
|
||||
# -------------------------------------------------------
|
||||
# Returns a list of attributes.
|
||||
#
|
||||
my $class = ref $_[0] || $_[0];
|
||||
my $attribs = $ATTRIB_CACHE->{$class} || _get_attribs($class);
|
||||
return wantarray ? %$attribs : $attribs;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{stack_trace} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub stack_trace {
|
||||
# -------------------------------------------------------
|
||||
# If called with arguments, returns stack trace, otherwise
|
||||
# prints to stdout/stderr depending on whether in cgi or not.
|
||||
#
|
||||
my $pkg = shift || 'Unknown';
|
||||
my $raw = shift || 0;
|
||||
my $rollback = shift || 3;
|
||||
my ($ls, $spc, $fh);
|
||||
my $esc = sub {
|
||||
my $t = shift;
|
||||
$t =~ s/&/&/g;
|
||||
$t =~ s/</</g;
|
||||
$t =~ s/>/>/g;
|
||||
$t =~ s/"/"/g;
|
||||
$t;
|
||||
};
|
||||
if ($raw) {
|
||||
if (defined $ENV{REQUEST_METHOD}) {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
}
|
||||
else {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
$esc = sub { shift };
|
||||
}
|
||||
}
|
||||
elsif (defined $ENV{REQUEST_METHOD}) {
|
||||
print STDOUT "Content-type: text/html\n\n";
|
||||
$ls = '<br />';
|
||||
$spc = ' ';
|
||||
$fh = \*STDOUT;
|
||||
}
|
||||
else {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
$esc = sub { shift };
|
||||
$fh = \*STDERR;
|
||||
}
|
||||
my $out = $raw ? '' : "${ls}STACK TRACE$ls======================================$ls";
|
||||
{
|
||||
package DB;
|
||||
my $i = $rollback;
|
||||
local $@;
|
||||
while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) {
|
||||
my @args;
|
||||
for (@DB::args) {
|
||||
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
|
||||
my $print = $@ ? \$_ : $_;
|
||||
push @args, defined $print ? $print : '[undef]';
|
||||
}
|
||||
if (@args) {
|
||||
my $args = $esc->(join(", ", @args));
|
||||
$args =~ s/\n\s*\n/\n/g;
|
||||
$args =~ s/\n/\n$spc$spc$spc$spc/g;
|
||||
$out .= qq!$pkg ($$): $sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!;
|
||||
}
|
||||
else {
|
||||
$out .= qq!$pkg ($$): $sub called at $file line $line with no arguments.$ls!;
|
||||
}
|
||||
}
|
||||
}
|
||||
$raw ? return $out : print $fh $out;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_format_err} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _format_err {
|
||||
# -------------------------------------------------------
|
||||
# Formats an error message for output.
|
||||
#
|
||||
my ($pkg, $msg) = @_;
|
||||
my ($file, $line) = get_file_line($pkg);
|
||||
return "$pkg ($$): $msg at $file line $line.\n";
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{get_file_line} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub get_file_line {
|
||||
# -------------------------------------------------------
|
||||
# Find out what line error was generated in.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $pkg = shift || scalar caller;
|
||||
my %pkg;
|
||||
for (whatis($pkg)) {
|
||||
$pkg{$_}++;
|
||||
}
|
||||
my ($i, $last_pkg);
|
||||
while (my $pack = caller($i++)) {
|
||||
if ($pkg{$pack}) {
|
||||
$last_pkg = $i;
|
||||
}
|
||||
elsif ($last_pkg) {
|
||||
last; # We're one call back beyond the package being looked for
|
||||
}
|
||||
}
|
||||
unless (defined $last_pkg) {
|
||||
# You messed up by trying to pass in a package that was never called
|
||||
GT::Base->fatal("get_file_line() called with an invalid package ($pkg)");
|
||||
}
|
||||
(undef, my ($file, $line)) = caller($last_pkg);
|
||||
|
||||
return ($file, $line);
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_generate_fatal} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _generate_fatal {
|
||||
# -------------------------------------------------------------------
|
||||
# Generates a fatal error caused by misuse of AUTOLOAD.
|
||||
#
|
||||
my ($self, $attrib, $param) = @_;
|
||||
my $is_hash = index($self, 'HASH') != -1;
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
my @poss;
|
||||
if (UNIVERSAL::can($self, 'debug_level') and $self->debug_level) {
|
||||
my @class = @{$pkg . '::ISA'} || ();
|
||||
unshift @class, $pkg;
|
||||
for (@class) {
|
||||
my @subs = keys %{$_ . '::'};
|
||||
my %compiled = %{$_ . '::COMPILE'};
|
||||
for (keys %compiled) {
|
||||
push @subs, $_ if defined $compiled{$_};
|
||||
}
|
||||
for my $routine (@subs) {
|
||||
next if $attrib eq $routine;
|
||||
next unless $self;
|
||||
next unless defined $compiled{$_} or UNIVERSAL::can($self, $routine);
|
||||
if (GT::Base->_sndex($attrib) eq GT::Base->_sndex($routine)) {
|
||||
push @poss, $routine;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Generate an error message, with possible alternatives and die.
|
||||
my $err_pkg = $is_hash ? (defined $self->{_err_pkg} ? $self->{_err_pkg} : $pkg) : $pkg;
|
||||
my ($call_pkg, $file, $line) = caller(1);
|
||||
my $msg = @poss
|
||||
? " Perhaps you meant to call " . join(", or " => @poss) . ".\n"
|
||||
: '';
|
||||
die "$err_pkg ($$): Unknown method '$attrib' called at $file line $line.\n$msg";
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
$COMPILE{_sndex} = __LINE__ . <<'END_OF_FUNC';
|
||||
sub _sndex {
|
||||
# -------------------------------------------------------
|
||||
# Do a soundex lookup to suggest alternate methods the person
|
||||
# might have wanted.
|
||||
#
|
||||
my $self = shift;
|
||||
local $_ = shift;
|
||||
my $search_sound = uc;
|
||||
$search_sound =~ tr/A-Z//cd;
|
||||
if ($search_sound eq '') { $search_sound = 0 }
|
||||
else {
|
||||
my $f = substr($search_sound, 0, 1);
|
||||
$search_sound =~ tr/AEHIOUWYBFPVCGJKQSXZDTLMNR/00000000111122222222334556/;
|
||||
my $fc = substr($search_sound, 0, 1);
|
||||
$search_sound =~ s/^$fc+//;
|
||||
$search_sound =~ tr///cs;
|
||||
$search_sound =~ tr/0//d;
|
||||
$search_sound = $f . $search_sound . '000';
|
||||
$search_sound = substr($search_sound, 0, 4);
|
||||
}
|
||||
return $search_sound;
|
||||
}
|
||||
END_OF_FUNC
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Base - Common base module to be inherited by all classes.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Base;
|
||||
use vars qw/@ISA $ATTRIBS $ERRORS/
|
||||
@ISA = qw/GT::Base/;
|
||||
$ATTRIBS = {
|
||||
accessor => default,
|
||||
accessor2 => default,
|
||||
};
|
||||
$ERRORS = {
|
||||
BADARGS => "Invalid argument: %s passed to subroutine: %s",
|
||||
};
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Base is a base class that is used to provide common error handling,
|
||||
debugging, creators and accessor methods.
|
||||
|
||||
To use GT::Base, simply make your module inherit from GT::Base. That
|
||||
will provide the following functionality:
|
||||
|
||||
=head2 Debugging
|
||||
|
||||
Two new methods are available for debugging:
|
||||
|
||||
$self->debug($msg, [DEBUG_LEVEL]);
|
||||
|
||||
This will send a $msg to STDERR if the current debug level is greater
|
||||
then the debug level passed in (defaults to 1).
|
||||
|
||||
$self->debug_level(DEBUG_LEVEL);
|
||||
Class->debug_level(DEBUG_LEVEL);
|
||||
|
||||
You can call debug_level() to set or get the debug level. It can
|
||||
be set per object by calling it as an object method, or class wide
|
||||
which will initilize all new objects with that debug level (only if
|
||||
using the built in creator).
|
||||
|
||||
The debugging uses a package variable:
|
||||
|
||||
$Class::DEBUG = 0;
|
||||
|
||||
and assumes it exists.
|
||||
|
||||
=head2 Error Handling
|
||||
|
||||
Your object can now generate errors using the method:
|
||||
|
||||
$self->error(CODE, LEVEL, [args]);
|
||||
|
||||
CODE should be a key to a hash of error codes to user readable
|
||||
error messages. This hash should be stored in $ERRORS which is
|
||||
defined in your pacakge, or the package named in $ERROR_MESSAGE.
|
||||
|
||||
LEVEL should be either 'FATAL' or 'WARN'. If not specified it defaults
|
||||
to FATAL. If it's a fatal error, the program will print the message
|
||||
to STDERR and die.
|
||||
|
||||
args can be used to format the error message. For instance, you can
|
||||
defined commonly used errors like:
|
||||
|
||||
CANTOPEN => "Unable to open file: '%s': %s"
|
||||
|
||||
in your $ERRORS hash. Then you can call error like:
|
||||
|
||||
open FILE, "somefile.txt"
|
||||
or return $self->error(CANTOPEN => FATAL => "somefile.txt", "$!");
|
||||
|
||||
The error handler will format your message using sprintf(), so all
|
||||
regular printf formatting strings are allowed.
|
||||
|
||||
Since errors are kept within an array, too many errors can pose a
|
||||
memory problem. To clear the error stack simply call:
|
||||
|
||||
$self->clear_errors();
|
||||
|
||||
=head2 Error Trapping
|
||||
|
||||
You can specify at run time to trap errors.
|
||||
|
||||
$self->catch_errors(\&code_ref);
|
||||
|
||||
which sets a $SIG{__DIE__} handler. Any fatal errors that occur, will
|
||||
run your function. The function will not be run if the fatal was thrown
|
||||
inside of an eval though.
|
||||
|
||||
=head2 Stack Trace
|
||||
|
||||
You can print out a stack trace at any time by using:
|
||||
|
||||
$self->stack_trace(1);
|
||||
Class->stack_trace(1);
|
||||
|
||||
If you pass in 1, the stack trace will be returned as a string, otherwise
|
||||
it will be printed to STDOUT.
|
||||
|
||||
=head2 Accessor Methods
|
||||
|
||||
Using GT::Base automatically provides accessor methods for all your
|
||||
attributes. By specifying:
|
||||
|
||||
$ATTRIBS = {
|
||||
attrib => 'default',
|
||||
...
|
||||
};
|
||||
|
||||
in your package, you can now call:
|
||||
|
||||
my $val = $obj->attrib();
|
||||
$obj->attrib($set_val);
|
||||
|
||||
to set and retrieve the attributes for that value.
|
||||
|
||||
Note: This uses AUTOLOAD, so if you implement AUTOLOAD in your package,
|
||||
you must have it fall back to GT::Base::AUTOLOAD if it fails. This
|
||||
can be done with:
|
||||
|
||||
AUTOLOAD {
|
||||
...
|
||||
goto >::Base::AUTOLOAD;
|
||||
}
|
||||
|
||||
which will pass all arguments as well.
|
||||
|
||||
=head2 Parameter Parsing
|
||||
|
||||
GT::Base also provides a method to parse parameters. In your methods you
|
||||
can do:
|
||||
|
||||
my $self = shift;
|
||||
my $parm = $self->common_param(@_);
|
||||
|
||||
This will convert any of a hash reference, hash or CGI object into a hash
|
||||
reference.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Base.pm,v 1.135 2007/11/10 06:46:21 brewt Exp $
|
||||
|
||||
=cut
|
||||
1032
site/slowtwitch.com/cgi-bin/articles/GT/CGI.pm
Normal file
1032
site/slowtwitch.com/cgi-bin/articles/GT/CGI.pm
Normal file
File diff suppressed because it is too large
Load Diff
101
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Action.pm
Normal file
101
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Action.pm
Normal file
@ -0,0 +1,101 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Action
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Action.pm,v 1.8 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# An API to make writting CGIs easier.
|
||||
#
|
||||
|
||||
package GT::CGI::Action;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/@ISA @EXPORT/;
|
||||
use strict;
|
||||
|
||||
use GT::CGI::Action::Common;
|
||||
|
||||
use Carp;
|
||||
|
||||
@ISA = qw(GT::CGI::Action::Common);
|
||||
@EXPORT = qw(ACT_ERROR ACT_OK ACT_EXIT);
|
||||
|
||||
sub can_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $page = shift;
|
||||
croak "No page specified" unless defined $page;
|
||||
|
||||
my $pages = $self->config->{pages};
|
||||
return undef unless defined $pages and exists $pages->{$page};
|
||||
return $pages->{$page}[PAGE_CAN];
|
||||
}
|
||||
|
||||
sub can_action {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $action = shift;
|
||||
croak "No action specified" unless defined $action;
|
||||
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
my $actions = $self->config->{actions};
|
||||
return undef unless defined $actions and exists $actions->{$action};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub run_action {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $action = shift;
|
||||
croak "No page specified" unless defined $action;
|
||||
|
||||
my $actions = $self->config->{actions};
|
||||
croak "$action does not exist"
|
||||
unless defined $actions and exists $actions->{$action};
|
||||
|
||||
my ($class, $func) = ($actions->{$action}[ACT_FUNCTION] =~ /(.+)::([^:]+)/);
|
||||
eval "use $class();";
|
||||
die "$@\n" if $@;
|
||||
my $this = $class->new(%$self);
|
||||
$this->action($action);
|
||||
$this->$func(@_);
|
||||
return $this;
|
||||
}
|
||||
|
||||
# Shortcut function
|
||||
sub run_returns {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $obj = shift;
|
||||
croak "No object defined" unless defined $obj;
|
||||
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
|
||||
if ($obj->return == ACT_ERROR) {
|
||||
$self->print_page($obj->error_page);
|
||||
}
|
||||
elsif ($obj->return == ACT_OK) {
|
||||
$self->print_page($obj->success_page);
|
||||
}
|
||||
elsif ($obj->return != ACT_EXIT) {
|
||||
die "Unknown return from $obj";
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
286
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Action/Common.pm
Normal file
286
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Action/Common.pm
Normal file
@ -0,0 +1,286 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Action::Common
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Common.pm,v 1.14 2004/09/07 23:35:14 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Provides a base class for GT::CGI::Action objects
|
||||
#
|
||||
|
||||
package GT::CGI::Action::Common;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/@EXPORT @ISA/;
|
||||
use strict;
|
||||
use constants
|
||||
|
||||
# Index in config action values
|
||||
ACT_FUNCTION => 0,
|
||||
ACT_ERROR_PAGE => 1,
|
||||
ACT_SUCCESS_PAGE => 2,
|
||||
|
||||
# Index in config page values
|
||||
PAGE_CAN => 0,
|
||||
PAGE_FUNCTION => 1,
|
||||
|
||||
# Action returns
|
||||
ACT_ERROR => 0,
|
||||
ACT_OK => 1,
|
||||
ACT_EXIT => 3;
|
||||
|
||||
use Carp;
|
||||
use Exporter();
|
||||
|
||||
@ISA = qw/Exporter/;
|
||||
@EXPORT = qw(
|
||||
ACT_FUNCTION
|
||||
ACT_ERROR_PAGE
|
||||
ACT_SUCCESS_PAGE
|
||||
PAGE_CAN
|
||||
PAGE_FUNCTION
|
||||
ACT_EXIT
|
||||
ACT_OK
|
||||
ACT_ERROR
|
||||
);
|
||||
|
||||
sub new {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $class = shift;
|
||||
croak "Areguments to new() must be a hash" if @_ & 1;
|
||||
my %opts = @_;
|
||||
|
||||
my $guess_mime = exists($opts{guess_mime}) ? delete($opts{guess_mime}) : 1;
|
||||
|
||||
my $cgi = delete $opts{cgi};
|
||||
unless (defined $cgi) {
|
||||
require GT::CGI;
|
||||
$cgi = new GT::CGI;
|
||||
}
|
||||
|
||||
my $tpl = delete $opts{template};
|
||||
unless (defined $tpl) {
|
||||
require GT::Template;
|
||||
$tpl = new GT::Template;
|
||||
}
|
||||
|
||||
my $debug = delete $opts{debug};
|
||||
|
||||
my $tags = delete $opts{tags};
|
||||
$tags = {} unless defined $tags;
|
||||
|
||||
my $config = delete $opts{config};
|
||||
croak "No config specified"
|
||||
unless defined $config;
|
||||
|
||||
my $action = delete $opts{action};
|
||||
my $heap = delete $opts{heap};
|
||||
|
||||
croak "Unknown arguments: ", sort keys %opts if keys %opts;
|
||||
|
||||
my $self = bless {
|
||||
cgi => $cgi,
|
||||
template => $tpl,
|
||||
tags => $tags,
|
||||
guess_mime => $guess_mime,
|
||||
action => $action,
|
||||
debug => $debug,
|
||||
heap => $heap
|
||||
}, $class;
|
||||
$self->config($config);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub config {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{config} = shift;
|
||||
unless (ref $self->{config}) {
|
||||
require GT::Config;
|
||||
$self->{config} = GT::Config->load($self->{config}, {
|
||||
inheritance => 1,
|
||||
cache => 1,
|
||||
create_ok => 0,
|
||||
strict => 0,
|
||||
debug => $self->{debug},
|
||||
compile_subs => 0,
|
||||
});
|
||||
}
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{config};
|
||||
}
|
||||
|
||||
sub tags {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my %tags;
|
||||
if (ref($_[0]) eq 'HASH') {
|
||||
%tags = %{shift()};
|
||||
}
|
||||
else {
|
||||
croak "Arguments to tags() must be a hash or hash ref" if @_ & 1;
|
||||
%tags = @_;
|
||||
}
|
||||
@{$self->{tags}}{keys %tags} = (values %tags)
|
||||
if keys %tags;
|
||||
return $self->{tags};
|
||||
}
|
||||
|
||||
sub cgi {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{cgi} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{cgi};
|
||||
}
|
||||
|
||||
sub heap {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{heap} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{heap};
|
||||
}
|
||||
|
||||
sub action {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{action} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{action};
|
||||
}
|
||||
|
||||
sub guess_mime {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{guess_mime} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{guess_mime};
|
||||
}
|
||||
|
||||
sub debug {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{debug} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{debug};
|
||||
}
|
||||
|
||||
sub template {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{template} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{template};
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(message => "message");
|
||||
sub info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
$self->tags(message => $message);
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(message => "message"); $self->print_page("page");
|
||||
sub print_info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $page = shift;
|
||||
croak "No page specified" unless defined $page;
|
||||
$self->info(@_);
|
||||
$self->print_page($page);
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(error => "message");
|
||||
sub error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $error = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
$self->tags(error => $error);
|
||||
}
|
||||
|
||||
# Shortcut to $self->tags(error => "message"); $self->print_page("page");
|
||||
sub print_error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $page = shift;
|
||||
croak "No page specified" unless defined $page;
|
||||
$self->info(@_);
|
||||
$self->print_page($page);
|
||||
}
|
||||
|
||||
# Shortcut to print $self->cgi->cookie(..)->cookie_header, "\r\n";
|
||||
sub print_cookie {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
print $self->cgi->cookie(@_)->cookie_header, "\r\n";
|
||||
}
|
||||
|
||||
sub print_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $page = shift;
|
||||
croak "No page specified to print" unless defined $page;
|
||||
$self->tags(page => $page);
|
||||
|
||||
if (defined $self->{config}{pages}{$page}[PAGE_FUNCTION]) {
|
||||
my ($class, $func) = ($self->{config}{pages}{$page}[PAGE_FUNCTION] =~ /(.+)::([^:]+)/);
|
||||
eval "use $class();";
|
||||
die "$@\n" if $@;
|
||||
my $this = $class->new(%$self);
|
||||
$this->$func(@_);
|
||||
}
|
||||
|
||||
if ($self->guess_mime) {
|
||||
require GT::MIMETypes;
|
||||
my $type = GT::MIMETypes->guess_type($page);
|
||||
print $self->cgi->header($type);
|
||||
if ($type =~ /text/) {
|
||||
return $self->template->parse_print($page, $self->tags);
|
||||
}
|
||||
else {
|
||||
local *FH;
|
||||
open FH, "<$page"
|
||||
or die "Could not open $page; Reason: $!";
|
||||
my $buff;
|
||||
binmode STDOUT;
|
||||
while (read(FH, $buff, 4096)) {
|
||||
print STDOUT $buff;
|
||||
}
|
||||
close FH;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $self->cgi->header;
|
||||
}
|
||||
$self->template->parse_print($page, $self->tags);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
106
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Action/Plugin.pm
Normal file
106
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Action/Plugin.pm
Normal file
@ -0,0 +1,106 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Action::Plugin
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Plugin.pm,v 1.5 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
#
|
||||
|
||||
package GT::CGI::Action::Plugin;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/@ISA @EXPORT/;
|
||||
use strict;
|
||||
|
||||
use GT::CGI::Action::Common;
|
||||
|
||||
use Carp;
|
||||
|
||||
@ISA = qw(GT::CGI::Action::Common);
|
||||
@EXPORT = qw(ACT_ERROR ACT_OK ACT_EXIT);
|
||||
|
||||
sub return {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{return} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
return $self->{return};
|
||||
}
|
||||
|
||||
sub info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::info(@_) if @_;
|
||||
$self->return(ACT_OK);
|
||||
}
|
||||
|
||||
sub print_info {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::print_info(@_);
|
||||
$self->return(ACT_EXIT);
|
||||
}
|
||||
|
||||
sub error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::error(@_) if @_;
|
||||
$self->return(ACT_ERROR);
|
||||
}
|
||||
|
||||
sub print_error {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->SUPER::print_error(@_);
|
||||
$self->return(ACT_ERROR);
|
||||
}
|
||||
|
||||
sub exit {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->return(ACT_EXIT);
|
||||
}
|
||||
|
||||
sub error_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{error_page} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
if (defined $self->{error_page}) {
|
||||
return $self->{error_page};
|
||||
}
|
||||
croak "No action was ever specified" unless defined $self->action;
|
||||
return $self->{config}{actions}{$self->action}[ACT_ERROR_PAGE];
|
||||
|
||||
}
|
||||
|
||||
sub success_page {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{success_page} = shift;
|
||||
croak "Unknown arguments: @_" if @_;
|
||||
}
|
||||
if (defined $self->{success_page}) {
|
||||
return $self->{success_page};
|
||||
}
|
||||
croak "No action was ever specified" unless defined $self->action;
|
||||
return $self->{config}{actions}{$self->action}[ACT_SUCCESS_PAGE];
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
103
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Cookie.pm
Normal file
103
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Cookie.pm
Normal file
@ -0,0 +1,103 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Cookie
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Cookie.pm,v 1.7 2008/06/09 23:39:47 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Handles cookie creation and formatting
|
||||
#
|
||||
|
||||
package GT::CGI::Cookie;
|
||||
#================================================================================
|
||||
|
||||
use strict;
|
||||
use GT::CGI;
|
||||
use GT::Base;
|
||||
use vars qw/@ISA $ATTRIBS @MON @WDAY/;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
|
||||
$ATTRIBS = {
|
||||
-name => '',
|
||||
-value => '',
|
||||
-expires => '',
|
||||
-path => '',
|
||||
-domain => '',
|
||||
-secure => '',
|
||||
-httponly => '',
|
||||
};
|
||||
@MON = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
|
||||
@WDAY = qw/Sun Mon Tue Wed Thu Fri Sat/;
|
||||
|
||||
sub cookie_header {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns a cookie header.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# make sure we have a name to use
|
||||
$self->{-name} or return;
|
||||
|
||||
my $name = GT::CGI::escape($self->{-name});
|
||||
my $value = GT::CGI::escape($self->{-value});
|
||||
|
||||
# build the header that creates the cookie
|
||||
my $header = "Set-Cookie: $name=$value";
|
||||
|
||||
$self->{-expires} and $header .= "; expires=" . $self->format_date('-', $self->{-expires});
|
||||
if (my $path = $self->{-path}) { $path =~ s/[\x00-\x1f].*//s; $header .= "; path=$path"; }
|
||||
if (my $domain = $self->{-domain}) { $domain =~ s/[\x00-\x1f].*//s; $header .= "; domain=$domain"; }
|
||||
$self->{-secure} and $header .= "; secure";
|
||||
$self->{-httponly} and $header .= "; httponly";
|
||||
|
||||
return $header;
|
||||
}
|
||||
|
||||
sub format_date {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a string in http_gmt format, but accepts one in unknown format.
|
||||
# Wed, 23 Aug 2000 21:20:14 GMT
|
||||
#
|
||||
my ($self, $sep, $datestr) = @_;
|
||||
my $unix_time = defined $datestr ? $self->expire_calc($datestr) : time;
|
||||
|
||||
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($unix_time);
|
||||
$year += 1900;
|
||||
|
||||
return sprintf(
|
||||
"%s, %02d$sep%s$sep%04d %02d:%02d:%02d GMT",
|
||||
$WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec
|
||||
);
|
||||
}
|
||||
*_format_date = \&format_date; # deprecated
|
||||
|
||||
sub expire_calc {
|
||||
# -------------------------------------------------------------------
|
||||
# Calculates when a date based on +- times. See CGI.pm for more info.
|
||||
#
|
||||
my ($self, $time) = @_;
|
||||
my %mult = (s => 1, m => 60, h => 3600, d => 86400, M => 2592000, y => 31536000);
|
||||
my $offset;
|
||||
|
||||
if (!$time or lc $time eq 'now') {
|
||||
$offset = 0;
|
||||
}
|
||||
elsif ($time =~ /^\d/) {
|
||||
return $time;
|
||||
}
|
||||
elsif ($time=~/^([+-]?(?:\d+(?:\.\d*)?|\.\d+))([smhdMy]?)/) {
|
||||
$offset = $1 * ($mult{$2} || 1);
|
||||
}
|
||||
else {
|
||||
return $time;
|
||||
}
|
||||
return time + $offset;
|
||||
}
|
||||
*_expire_calc = \&expire_calc; # deprecated
|
||||
|
||||
1;
|
||||
502
site/slowtwitch.com/cgi-bin/articles/GT/CGI/EventLoop.pm
Normal file
502
site/slowtwitch.com/cgi-bin/articles/GT/CGI/EventLoop.pm
Normal file
@ -0,0 +1,502 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::EventLoop
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: EventLoop.pm,v 1.5 2004/09/07 23:35:14 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Impliments an EventLoop API for CGI programming
|
||||
#
|
||||
|
||||
package GT::CGI::EventLoop;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/$ATTRIBS $ERRORS @EXPORT_OK %EXPORT_TAGS/;
|
||||
use strict;
|
||||
use bases 'GT::Base' => ''; # GT::Base inherits from Exporter
|
||||
use constants
|
||||
STOP => 1,
|
||||
EXIT => 2,
|
||||
CONT => 3,
|
||||
HEAP => 0,
|
||||
EVENT => 1,
|
||||
IN => 2,
|
||||
CGI => 3,
|
||||
ARG0 => 4,
|
||||
ARG1 => 5,
|
||||
ARG2 => 6,
|
||||
ARG3 => 7,
|
||||
ARG4 => 8,
|
||||
ARG5 => 9,
|
||||
ARG6 => 10,
|
||||
ARG7 => 11,
|
||||
ARG8 => 12,
|
||||
ARG9 => 13;
|
||||
|
||||
use GT::CGI;
|
||||
use GT::MIMETypes;
|
||||
|
||||
$ERRORS = {
|
||||
NOACTION => 'No action was passed from CGI input and no default action was set',
|
||||
NOFUNC => 'No function in %s'
|
||||
};
|
||||
|
||||
$ATTRIBS = {
|
||||
do => 'do',
|
||||
format_page_tags => undef,
|
||||
default_do => undef,
|
||||
init_events => undef,
|
||||
init_events_name => undef,
|
||||
default_page => 'home',
|
||||
default_group => undef,
|
||||
default_page_pre_event => undef,
|
||||
default_page_post_event => undef,
|
||||
default_group_pre_event => undef,
|
||||
default_group_post_event => undef,
|
||||
needs_array_input => undef,
|
||||
plugin_object => undef,
|
||||
template_path => undef,
|
||||
pre_package => '',
|
||||
cgi => undef,
|
||||
in => {},
|
||||
heap => {},
|
||||
page_events => {},
|
||||
page_pre_events => {},
|
||||
page_post_events => {},
|
||||
group_pre_events => {},
|
||||
group_post_events => {},
|
||||
groups => {},
|
||||
group => undef,
|
||||
page => undef,
|
||||
print_page => \>::CGI::EventLoop::print_page,
|
||||
status => CONT,
|
||||
cookies => []
|
||||
};
|
||||
|
||||
@EXPORT_OK = qw/
|
||||
STOP EXIT CONT
|
||||
HEAP EVENT IN CGI
|
||||
ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9
|
||||
/;
|
||||
|
||||
%EXPORT_TAGS = (
|
||||
all => [@EXPORT_OK],
|
||||
status => [qw/STOP EXIT CONT/],
|
||||
args => [qw/
|
||||
HEAP EVENT IN CGI
|
||||
ARG0 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9
|
||||
/]
|
||||
);
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->set( @_ ) if @_;
|
||||
$self->{cgi} ||= new GT::CGI;
|
||||
for ( $self->{cgi}->param ) {
|
||||
my @val = $self->{cgi}->param($_);
|
||||
my $val;
|
||||
my $match;
|
||||
for my $field ( @{$self->{needs_array_input}} ) {
|
||||
if ( $_ eq $field ) {
|
||||
$match = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ( !$match ) {
|
||||
$val = $val[0];
|
||||
}
|
||||
else {
|
||||
$val = \@val;
|
||||
}
|
||||
$self->{in}{$_} = $val;
|
||||
}
|
||||
}
|
||||
|
||||
sub mainloop {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->init( @_ ) if @_;
|
||||
|
||||
if ( !defined $self->{in}{$self->{do}} ) {
|
||||
if ( defined $self->{default_do} ) {
|
||||
$self->{in}{$self->{do}} = $self->{default_do};
|
||||
}
|
||||
else {
|
||||
$self->fatal( 'NOACTION' );
|
||||
}
|
||||
}
|
||||
if ( $self->{init_events} ) {
|
||||
local $self->{in}{$self->{do}} = $self->{init_events_name} if $self->{init_events_name};
|
||||
|
||||
$self->dispatch( $self->{init_events} );
|
||||
return if $self->{status} == EXIT;
|
||||
}
|
||||
$self->_call_group;
|
||||
$self->_call_page;
|
||||
}
|
||||
|
||||
sub do_param {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if ( @_ ) {
|
||||
$self->add_hidden( $self->{do} => $_[0] );
|
||||
}
|
||||
return $self->{in}{$self->{do}};
|
||||
}
|
||||
|
||||
sub stop { $_[0]->{status} = STOP }
|
||||
sub exit { $_[0]->{status} = EXIT }
|
||||
sub cont { $_[0]->{status} = CONT }
|
||||
|
||||
sub _call_group {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
$self->{group} ||= $self->{in}{$self->{do}} || $self->{default_do};
|
||||
my $orig_group = $self->{group};
|
||||
# FIXME Add infinite recursion checks!
|
||||
for ( keys %{$self->{groups}} ) {
|
||||
if ( index( $self->{group}, $_ ) == 0 ) {
|
||||
if ( exists $self->{group_pre_events}{$_} ) {
|
||||
$self->dispatch( $self->{group_pre_events}{$_} );
|
||||
return if $self->{status} == EXIT;
|
||||
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
elsif ( defined $self->{default_group_pre_event} ) {
|
||||
$self->dispatch( $self->{default_group_pre_event} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
$self->dispatch( $self->{groups}{$_} );
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
if ( exists $self->{group_post_events}{$_} ) {
|
||||
$self->dispatch( $self->{group_post_events}{$_} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
elsif ( defined $self->{default_group_post_event} ) {
|
||||
$self->dispatch( $self->{default_group_post_event} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# Default group
|
||||
$self->dispatch( $self->{default_group} ) if $self->{default_group};
|
||||
if ( $self->{default_group} and $self->{group} ne $orig_group ) {
|
||||
return $self->_call_group;
|
||||
}
|
||||
}
|
||||
|
||||
sub _call_page {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
if ( !$self->{page} ) {
|
||||
$self->page( $self->{default_page} );
|
||||
}
|
||||
my $orig_page = $self->{page};
|
||||
if ( exists $self->{page_pre_events}{$self->{page}} ) {
|
||||
$self->dispatch( $self->{page_pre_events}{$self->{page}} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{page} ne $orig_page ) {
|
||||
return $self->_call_page;
|
||||
}
|
||||
}
|
||||
elsif ( defined $self->{default_page_pre_event} ) {
|
||||
$self->dispatch( $self->{default_page_pre_event} );
|
||||
return if $self->{status} == EXIT;
|
||||
if ( $self->{page} ne $orig_page ) {
|
||||
return $self->_call_page;
|
||||
}
|
||||
}
|
||||
$self->{print_page}->( $self );
|
||||
|
||||
# Run post page events, can't change the page on a post event
|
||||
if ( exists $self->{page_post_events}{$self->{page}} ) {
|
||||
$self->dispatch( $self->{page_post_events}{$self->{page}} );
|
||||
}
|
||||
elsif ( defined $self->{default_page_post_event} ) {
|
||||
$self->dispatch( $self->{default_page_post_event} );
|
||||
}
|
||||
}
|
||||
|
||||
sub cookie_jar {
|
||||
# --------------------------------------------------------------------
|
||||
# $obj->cookie_jar($cookie_object);
|
||||
# ---------------------------------
|
||||
# Stores cookies for printing when print_page is called.
|
||||
# $cookie_object should be a GT::CGI::Cookie object. Passing undef
|
||||
# will empty the cookies array ref.
|
||||
#
|
||||
my $self = shift;
|
||||
if ( !defined( $_[0] ) and @_ > 0 ) {
|
||||
$self->{cookies} = [];
|
||||
}
|
||||
elsif ( @_ > 0 ) {
|
||||
push( @{$self->{cookies}}, $_[0] );
|
||||
}
|
||||
return $self->{cookies};
|
||||
}
|
||||
|
||||
sub add_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if ( @_ and !defined( $_[0] ) ) {
|
||||
$self->{hidden} = {};
|
||||
}
|
||||
elsif ( @_ ) {
|
||||
$self->{hidden}{$_[0]} = $_[1];
|
||||
}
|
||||
}
|
||||
|
||||
sub remove_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return delete $self->{hidden}{$_[0]};
|
||||
}
|
||||
|
||||
sub get_url_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
my $ret = '';
|
||||
for ( keys %{$self->{hidden}} ) {
|
||||
next unless defined $self->{hidden}{$_};
|
||||
$ret .= $self->{cgi}->escape( $_ ).'='.$self->{cgi}->escape( $self->{hidden}{$_} ).';';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub get_form_hidden {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
my $ret = '';
|
||||
for ( keys %{$self->{hidden}} ) {
|
||||
next unless defined $self->{hidden}{$_};
|
||||
$ret .= '<input type="hidden" name="'.$self->{cgi}->html_escape( $_ ).'" value="'.$self->{cgi}->html_escape( $self->{hidden}{$_} ).'">';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub page {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if ( @_ > 0 ) {
|
||||
$self->{page} = $self->guess_page( $_[0] );
|
||||
$self->debug( "Set page to $self->{page}" ) if $self->{_debug};
|
||||
$self->yield( $self->{page_events} ) if $self->{page_events};
|
||||
}
|
||||
return $self->{page};
|
||||
}
|
||||
|
||||
sub guess_page {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, $page ) = @_;
|
||||
if ( -e "$self->{template_path}/$page.htm" ) {
|
||||
$page = "$page.htm";
|
||||
}
|
||||
elsif ( -e "$self->{template_path}/$page.html" ) {
|
||||
$page = "$page.html";
|
||||
}
|
||||
return $page;
|
||||
}
|
||||
|
||||
sub tags {
|
||||
# --------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my ( %tags ) = ref( $_[0] ) eq 'HASH' ? %{$_[0]} : @_;
|
||||
for ( keys %tags ) {
|
||||
$self->{tags}{$_} = $tags{$_};
|
||||
}
|
||||
return $self->{tags};
|
||||
}
|
||||
|
||||
sub default_tags {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %tags ) = @_;
|
||||
|
||||
my $set;
|
||||
for ( keys %tags ) {
|
||||
$set->{$_} = ( defined( $self->{in}{$_} ) and length( $self->{in}{$_} ) ? $self->{in}{$_} : $tags{$_} );
|
||||
}
|
||||
$self->tags( %$set );
|
||||
}
|
||||
|
||||
sub print_page {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
my $form_hidden = $self->get_form_hidden;
|
||||
my $url_hidden = $self->get_url_hidden;
|
||||
my $tags = $self->tags( url_hidden => \$url_hidden, form_hidden => \$form_hidden );
|
||||
$tags = $self->yield( $self->{format_page_tags}, $tags ) if defined $self->{format_page_tags};
|
||||
my $page = $self->page || 'index.htm';
|
||||
|
||||
# Cookies can be set with CGI input
|
||||
my $cookies = [];
|
||||
if ( $self->{in}{'set-cookie'} ) {
|
||||
foreach my $key ( keys %{$self->{in}} ) {
|
||||
if ( $key =~ /^cookie-(.*)/ ) {
|
||||
push @$cookies, $self->{cgi}->cookie( -name => $1, -value => $self->{in}{$key}, -path => '/' );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# See if we have any cookies in out cookie jar (used through program operation to set cookies without printing
|
||||
# a header)
|
||||
if ( @{$self->cookie_jar} ) {
|
||||
push @$cookies, @{$self->cookie_jar};
|
||||
}
|
||||
|
||||
# If we have cookie header to print print them
|
||||
print @{$cookies}
|
||||
? $self->{cgi}->header(
|
||||
-cookie => $cookies,
|
||||
-type => GT::MIMETypes->guess_type( $page )
|
||||
)
|
||||
: $self->{cgi}->header( GT::MIMETypes->guess_type( $page ) );
|
||||
|
||||
my $base = $self->{template_path};
|
||||
|
||||
# Make sure the template exists and is readable
|
||||
-e "$base/$page" or die "No page ($base/$page)";
|
||||
-r _ or die "Page isn't readable by this process ($< $>) ($base/$page)";
|
||||
|
||||
require GT::Template;
|
||||
GT::Template->parse( $page, $tags, {
|
||||
root => $base,
|
||||
escape => 1,
|
||||
print => 1,
|
||||
heap => [ $self->func_args ]
|
||||
} );
|
||||
|
||||
}
|
||||
|
||||
sub page_pre_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{page_pre_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{page_pre_events}{$self->guess_page( $_ )} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{page_pre_events};
|
||||
}
|
||||
|
||||
sub page_post_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{page_post_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{page_post_events}{$self->guess_page( $_ )} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{page_post_events};
|
||||
}
|
||||
|
||||
sub group_pre_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{group_pre_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{group_pre_events}{$_} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{group_pre_events};
|
||||
}
|
||||
|
||||
sub group_post_events {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, %in ) = @_;
|
||||
if ( keys %in ) {
|
||||
$self->{group_post_events} = {};
|
||||
for ( keys %in ) {
|
||||
my $val = ref( $in{$_} ) eq 'ARRAY' ? $in{$_} : [ $in{$_} ];
|
||||
$self->{group_post_events}{$_} = $val;
|
||||
}
|
||||
}
|
||||
return $self->{group_post_events};
|
||||
}
|
||||
|
||||
sub dispatch {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, $pfunc, @args ) = @_;
|
||||
$pfunc = ref( $pfunc ) eq 'ARRAY' ? $pfunc : [ $pfunc ];
|
||||
for ( @$pfunc ) {
|
||||
$self->yield( $_, @args );
|
||||
return if $self->{status} == EXIT or $self->{status} == STOP;
|
||||
}
|
||||
}
|
||||
|
||||
sub yield {
|
||||
# --------------------------------------------------------------------
|
||||
my ( $self, $pfunc, @args ) = @_;
|
||||
if ( !ref( $pfunc ) ) {
|
||||
$self->debug( "Yielding $pfunc" ) if $self->{_debug} > 1;
|
||||
my ( $pkg, $func );
|
||||
if ( index( $pfunc, '::' ) != -1 ) {
|
||||
($pkg, $func) = $pfunc =~ /^(.*)::(.*)$/;
|
||||
}
|
||||
else {
|
||||
$func = $pfunc;
|
||||
}
|
||||
defined( $func ) or $self->fatal( 'NOFUNC', $pfunc );
|
||||
$pkg = $self->{pre_package}.$pkg if $self->{pre_package} and $pkg;
|
||||
$pkg ||= $self->{pre_package} if $self->{pre_package};
|
||||
$pkg ||= 'main';
|
||||
$pkg =~ s/::$//;
|
||||
no strict 'refs';
|
||||
unless ( defined %{$pkg . '::'} ) {
|
||||
eval "require $pkg";
|
||||
die "Could not compile $pkg; Reason: $@" if $@;
|
||||
}
|
||||
if ( defined $self->{plugin_object} ) {
|
||||
$self->debug( "dispatching --> $pkg\::$func" ) if $self->{_debug};
|
||||
return $self->{plugin_object}->dispatch( $pkg.'::'.$func, \&{$pkg.'::'.$func}, $self->func_args(@args) );
|
||||
}
|
||||
else {
|
||||
no strict 'refs';
|
||||
$self->debug( "Calling $pkg\::$func" ) if $self->{_debug};
|
||||
return &{$pkg.'::'.$func}( $self->func_args(@args) );
|
||||
}
|
||||
$self->yield( $_, @args );
|
||||
}
|
||||
elsif ( ref( $pfunc ) eq 'CODE' ) {
|
||||
$self->debug( "In yeild with code ref.") if $self->{_debug};
|
||||
if ( defined $self->{plugin_object} ) {
|
||||
$self->debug( "dispatching --> $self->{in}{$self->{do}}" ) if $self->{_debug};
|
||||
return $self->{plugin_object}->dispatch( $self->{in}{$self->{do}}, $pfunc, $self->func_args(@args) );
|
||||
}
|
||||
else {
|
||||
$self->debug( "Calling code ref" ) if $self->{_debug};
|
||||
return $pfunc->( $self->func_args(@args) );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub func_args { $_[0]->{heap}, $_[0], $_[0]->{in}, $_[0]->{cgi}, @_[1 .. $#_] }
|
||||
|
||||
1;
|
||||
|
||||
|
||||
70
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Fh.pm
Normal file
70
site/slowtwitch.com/cgi-bin/articles/GT/CGI/Fh.pm
Normal file
@ -0,0 +1,70 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Fh
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Fh.pm,v 1.2 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Magic filehandle that prints the name, but is still a filehandle for reads -
|
||||
# just like CGI.pm.
|
||||
#
|
||||
package GT::CGI::Fh;
|
||||
# ===================================================================
|
||||
use strict 'vars', 'subs';
|
||||
use vars qw/$FH/;
|
||||
use Fcntl qw/O_RDWR O_EXCL/;
|
||||
use overload
|
||||
'""' => \&as_string,
|
||||
'cmp' => \&compare,
|
||||
'fallback' => 1;
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------------------
|
||||
# Create a new filehandle based on a counter, and the filename.
|
||||
#
|
||||
my ($pkg, $name, $file, $delete) = @_;
|
||||
my $fname = sprintf("FH%05d%s", ++$FH, $name);
|
||||
|
||||
$fname =~ s/([:'%])/sprintf '%%%02X', ord $1/eg;
|
||||
my $fh = \do { local *{$fname}; *{$fname} };
|
||||
|
||||
sysopen($fh, $file, O_RDWR | O_EXCL, 0600) or die "Can't open file: $file ($!)";
|
||||
unlink($file) if $delete;
|
||||
bless $fh, $pkg;
|
||||
|
||||
return $fh;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
# -------------------------------------------------------------------
|
||||
# Return the filename, strip off leading junk first.
|
||||
#
|
||||
my $self = shift;
|
||||
my $fn = $$self;
|
||||
$fn =~ s/%(..)/ chr(hex($1)) /eg;
|
||||
$fn =~ s/^\*GT::CGI::Fh::FH\d{5}//;
|
||||
return $fn;
|
||||
}
|
||||
|
||||
sub compare {
|
||||
# -------------------------------------------------------------------
|
||||
# Do comparisions, uses as_string to get file name first.
|
||||
#
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
return "$self" cmp $value;
|
||||
}
|
||||
|
||||
DESTROY {
|
||||
# -------------------------------------------------------------------
|
||||
# Close file handle.
|
||||
#
|
||||
my $self = shift;
|
||||
close $self;
|
||||
}
|
||||
|
||||
1;
|
||||
270
site/slowtwitch.com/cgi-bin/articles/GT/CGI/MultiPart.pm
Normal file
270
site/slowtwitch.com/cgi-bin/articles/GT/CGI/MultiPart.pm
Normal file
@ -0,0 +1,270 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::MultiPart
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: MultiPart.pm,v 1.12 2008/07/14 23:40:31 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Multipart form handling for GT::CGI objects.
|
||||
#
|
||||
# This is taken almost entirely from CGI.pm, and is loaded on demand.
|
||||
#
|
||||
|
||||
package GT::CGI::MultiPart;
|
||||
# ==============================================================================
|
||||
use strict 'vars', 'subs';
|
||||
use GT::CGI;
|
||||
use GT::Base;
|
||||
use GT::TempFile();
|
||||
use vars qw/$DEBUG $ERRORS @ISA $ATTRIBS $CRLF/;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
use constants
|
||||
BLOCK_SIZE => 4096,
|
||||
MAX_READS => 2000;
|
||||
$CRLF = "\015\012";
|
||||
$ATTRIBS = {
|
||||
fh => undef, # web request on stdin
|
||||
buffer => '', # buffer to hold tmp data
|
||||
length => 0, # length of file to parse
|
||||
boundary => undef, # mime boundary to look for
|
||||
fillunit => BLOCK_SIZE, # amount to read per chunk
|
||||
safety => 0 # safety counter
|
||||
};
|
||||
$ERRORS = {
|
||||
NOBOUNDARY => "Unable to find a MIME boundary in environment. Content-type looks like: %s",
|
||||
CLIENTABORT => "Unable to read data from server. Still have %s bytes to read, but got 0. Data in buffer is: %s",
|
||||
BADMULTIPART => "Invalid multipart message. Nothing left to read, and can't find closing boundary. Data in buffer is: %s"
|
||||
};
|
||||
|
||||
sub parse {
|
||||
# -------------------------------------------------------------------
|
||||
# Parses a multipart form to handle file uploads.
|
||||
#
|
||||
my ($class, $cgi, $callback) = @_;
|
||||
|
||||
# We override any fatal handlers as our handlers typically create a CGI object
|
||||
# avoiding a nasty loop.
|
||||
local $SIG{__DIE__} = 'DEFAULT';
|
||||
|
||||
# We only load the multipart parser if we have multipart code.
|
||||
my $parser = $class->new or return;
|
||||
|
||||
my ($header, $name, $value, $filename);
|
||||
until ($parser->eof) {
|
||||
$header = $parser->read_header or return die "BADREQUEST";
|
||||
if ($header->{'Content-Disposition'} =~ m/ name=(?:"([^"]*)"|((?!")[^;]*))/) {
|
||||
$name = length $1 ? $1 : $2;
|
||||
}
|
||||
|
||||
$filename = '';
|
||||
if ($header->{'Content-Disposition'} =~ m/ filename=(?:"([^"]*)"|((?!")[^;]*))/) {
|
||||
$filename = length $1 ? $1 : $2;
|
||||
|
||||
# Strip off any paths from the filename (IE sends the full path to the file).
|
||||
$filename =~ s|^.*[/\\]|| if $filename;
|
||||
}
|
||||
|
||||
$name .= $GT::CGI::TAINTED;
|
||||
$filename .= $GT::CGI::TAINTED;
|
||||
|
||||
# Not a file, just regular form data.
|
||||
if (! defined $filename or $filename eq '') {
|
||||
$value = $parser->read_body;
|
||||
|
||||
# Netscape 6 does some fun things with line feeds in multipart form data
|
||||
$value =~ s/\r\r/\r/g; # What it does on unix
|
||||
$value =~ s/\r\n/\n/g if $^O eq 'MSWin32';
|
||||
unless ($cgi->{params}->{$name}) {
|
||||
push @{$cgi->{param_order}}, $name;
|
||||
}
|
||||
unshift @{$cgi->{params}->{$name}}, $value;
|
||||
next;
|
||||
}
|
||||
|
||||
# Print out the data to a temp file.
|
||||
local $\;
|
||||
my $tmp_file = new GT::TempFile;
|
||||
require GT::CGI::Fh;
|
||||
my $fh = GT::CGI::Fh->new($filename, $$tmp_file, 0);
|
||||
binmode $fh;
|
||||
my $data;
|
||||
my $bytes_read = 0;
|
||||
while (defined($data = $parser->read)) {
|
||||
if (defined $callback and (ref $callback eq 'CODE')) {
|
||||
$bytes_read += length $data;
|
||||
$callback->($filename, \$data, $bytes_read);
|
||||
}
|
||||
print $fh $data;
|
||||
}
|
||||
seek $fh, 0, 0;
|
||||
unless ($cgi->{params}->{$name}) {
|
||||
push @{$cgi->{param_order}}, $name;
|
||||
}
|
||||
unshift @{$cgi->{params}->{$name}}, $fh;
|
||||
}
|
||||
}
|
||||
|
||||
sub init {
|
||||
# -------------------------------------------------------------------
|
||||
# Initilize our object.
|
||||
#
|
||||
$DEBUG = $GT::CGI::DEBUG;
|
||||
|
||||
my $self = shift;
|
||||
|
||||
# Get the boundary marker.
|
||||
my $boundary;
|
||||
if (defined $ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /boundary=\"?([^\";,]+)\"?/) {
|
||||
$boundary = $1 . $GT::CGI::TAINTED;
|
||||
}
|
||||
else {
|
||||
return $self->error("NOBOUNDARY", "FATAL", $ENV{CONTENT_TYPE});
|
||||
}
|
||||
$self->{boundary} = "--$boundary";
|
||||
|
||||
# Get our filehandle.
|
||||
binmode(STDIN);
|
||||
|
||||
# And if the boundary is > the BLOCK_SIZE, adjust.
|
||||
if (length $boundary > $self->{fillunit}) {
|
||||
$self->{fillunit} = length $boundary;
|
||||
}
|
||||
|
||||
# Set the content-length.
|
||||
$self->{length} = $ENV{CONTENT_LENGTH} || 0;
|
||||
|
||||
# Read the preamble and the topmost (boundary) line plus the CRLF.
|
||||
while ($self->read) { }
|
||||
}
|
||||
|
||||
sub fill_buffer {
|
||||
# -------------------------------------------------------------------
|
||||
# Fill buffer.
|
||||
#
|
||||
my ($self, $bytes) = @_;
|
||||
|
||||
return unless $self->{length};
|
||||
|
||||
my $boundary_length = length $self->{boundary};
|
||||
my $buffer_length = length $self->{buffer};
|
||||
my $bytes_to_read = $bytes - $buffer_length + $boundary_length + 2;
|
||||
$bytes_to_read = $self->{length} if $self->{length} < $bytes_to_read;
|
||||
|
||||
my $bytes_read = read(STDIN, $self->{buffer}, $bytes_to_read, $buffer_length);
|
||||
if (! defined $self->{buffer}) {
|
||||
$self->{buffer} = '';
|
||||
}
|
||||
if ($bytes_read == 0) {
|
||||
if ($self->{safety}++ > MAX_READS) {
|
||||
return $self->error(CLIENTABORT => FATAL => $self->{length}, $self->{buffer});
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{safety} = 0;
|
||||
}
|
||||
|
||||
$self->{length} -= $bytes_read;
|
||||
}
|
||||
|
||||
sub read {
|
||||
# -------------------------------------------------------------------
|
||||
# Read some input.
|
||||
#
|
||||
my $self = shift;
|
||||
my $bytes = $self->{fillunit};
|
||||
|
||||
# Load up self->{buffer} with data.
|
||||
$self->fill_buffer($bytes);
|
||||
|
||||
# find the boundary (if exists).
|
||||
my $start = index($self->{buffer}, $self->{boundary});
|
||||
|
||||
# Make sure the post was formed properly.
|
||||
unless (($start >= 0) or ($self->{length} > 0)) {
|
||||
return $self->error(BADMULTIPART => FATAL => $self->{buffer});
|
||||
}
|
||||
|
||||
if ($start == 0) {
|
||||
# Quit if we found the last boundary at the beginning.
|
||||
if (index($self->{buffer},"$self->{boundary}--") == 0) {
|
||||
$self->{buffer} = '';
|
||||
$self->{length} = 0;
|
||||
return;
|
||||
}
|
||||
# Otherwise remove the boundary (+2 to remove line feeds).
|
||||
substr($self->{buffer}, 0, length ($self->{boundary}) + 2) = '';
|
||||
return;
|
||||
}
|
||||
|
||||
my $bytes_to_return;
|
||||
if ($start > 0) {
|
||||
$bytes_to_return = $start > $bytes ? $bytes : $start;
|
||||
}
|
||||
else {
|
||||
$bytes_to_return = $bytes - length($self->{boundary}) + 1;
|
||||
}
|
||||
|
||||
my $return = substr($self->{buffer}, 0, $bytes_to_return);
|
||||
substr($self->{buffer}, 0, $bytes_to_return) = '';
|
||||
|
||||
return $start > 0 ? substr($return, 0, -2) : $return;
|
||||
}
|
||||
|
||||
sub read_header {
|
||||
# -------------------------------------------------------------------
|
||||
# Reads the header.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($ok, $bad, $end, $safety) = (0, 0);
|
||||
until ($ok or $bad) {
|
||||
$self->fill_buffer($self->{fillunit});
|
||||
|
||||
$ok++ if ($end = index($self->{buffer}, "$CRLF$CRLF")) >= 0;
|
||||
$ok++ if $self->{buffer} eq '';
|
||||
$bad++ if !$ok and $self->{length} <= 0;
|
||||
return if $safety++ >= 10;
|
||||
}
|
||||
|
||||
return if $bad;
|
||||
|
||||
my $header = substr($self->{buffer}, 0, $end + 2);
|
||||
substr($self->{buffer}, 0, $end + 4) = '';
|
||||
|
||||
my %header;
|
||||
my $token = '[-\w!\#$%&\'*+.^_\`|{}~]';
|
||||
$header =~ s/$CRLF\s+/ /og;
|
||||
while ($header =~ /($token+):\s+([^$CRLF]*)/go) {
|
||||
my ($field_name, $field_value) = ($1 . $GT::CGI::TAINTED, $2 . $GT::CGI::TAINTED);
|
||||
$field_name =~ s/\b(\w)/\u$1/g;
|
||||
$header{$field_name} = $field_value;
|
||||
}
|
||||
return \%header;
|
||||
}
|
||||
|
||||
sub read_body {
|
||||
# -------------------------------------------------------------------
|
||||
# Reads a body and returns as a single scalar value.
|
||||
#
|
||||
my $self = shift;
|
||||
my $data = '';
|
||||
my $return = '';
|
||||
while (defined($data = $self->read)) {
|
||||
$return .= $data;
|
||||
}
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub eof {
|
||||
# -------------------------------------------------------------------
|
||||
# Return true when we've finished reading.
|
||||
#
|
||||
my $self = shift;
|
||||
return 1 if length $self->{buffer} == 0 and $self->{length} <= 0;
|
||||
}
|
||||
|
||||
1;
|
||||
245
site/slowtwitch.com/cgi-bin/articles/GT/Cache.pm
Normal file
245
site/slowtwitch.com/cgi-bin/articles/GT/Cache.pm
Normal file
@ -0,0 +1,245 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Cache
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Cache.pm,v 1.13 2004/01/13 01:35:15 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements a tied hash cache that will not grow forever, but expire
|
||||
# old/unused entries. Useful under mod_perl.
|
||||
#
|
||||
|
||||
package GT::Cache;
|
||||
# ===============================================================
|
||||
use vars qw /$DEBUG $VERSION $CACHE_SIZE/;
|
||||
use strict;
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.13 $ =~ /(\d+)\.(\d+)/;
|
||||
$CACHE_SIZE = 500;
|
||||
|
||||
##
|
||||
# tie %cache, 'GT::Cache', $size, \&function;
|
||||
# ----------------------------
|
||||
# Is called when you tie a hash to this
|
||||
# class. The size should be the size limit
|
||||
# you want on your hash. If not specified
|
||||
# this will default to the CLASS variable
|
||||
# $CACH_SIZE which is initialized to 500
|
||||
##
|
||||
sub TIEHASH {
|
||||
my $this = shift;
|
||||
my $size = shift || $CACHE_SIZE;
|
||||
my $code = shift || sub {undef};
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {
|
||||
cache_size => $size,
|
||||
popularity => [],
|
||||
content => {},
|
||||
indices => {},
|
||||
is_indexed => 0,
|
||||
size => 0,
|
||||
code => $code,
|
||||
}, $class;
|
||||
$#{$self->{popularity}} = $size;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub FETCH {
|
||||
my ($self, $key) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
unless (exists $self->{content}->{$key}) {
|
||||
my $val = $self->{code}->($key);
|
||||
defined $val or return undef;
|
||||
$self->STORE ($key, $val);
|
||||
return $val;
|
||||
}
|
||||
if ($self->{is_indexed}) {
|
||||
my ($pos1, $pos2, $replace);
|
||||
|
||||
$pos1 = $self->{content}->{$key}->[1];
|
||||
$pos2 = $pos1 + (int (rand( ($self->{cache_size} - $pos1) / 2) )) || 1;
|
||||
|
||||
$replace = ${$self->{popularity}}[$pos2];
|
||||
|
||||
${$self->{popularity}}[$pos2] = $key;
|
||||
$self->{content}->{$key}->[1] = $pos2;
|
||||
if (defined $replace) {
|
||||
${$self->{popularity}}[$pos1] = $replace;
|
||||
$self->{content}->{$replace}->[1] = $pos1;
|
||||
}
|
||||
}
|
||||
return $self->{content}->{$key}->[0];
|
||||
}
|
||||
|
||||
##
|
||||
# %cash = (key1 => $field1, key2 => $val2);
|
||||
# -----------------------------------------
|
||||
# $cash{key} = $val;
|
||||
# ------------------
|
||||
# Called when you store something in the hash.
|
||||
# This will check the number of elements in the
|
||||
# hash and delete the oldest one if the limit.
|
||||
# is reached.
|
||||
##
|
||||
sub STORE {
|
||||
my ($self, $key, $value) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
my ($replace, $insid);
|
||||
if ($self->{is_indexed}) {
|
||||
$insid = int (rand($self->{cache_size} / 2)) || 1;
|
||||
if (defined ($replace = ${$self->{popularity}}[$insid])) {
|
||||
delete $self->{content}->{$replace};
|
||||
undef ${$self->{popularity}}[$insid];
|
||||
}
|
||||
${$self->{popularity}}[$insid] = $key;
|
||||
$self->{content}->{$key} = [$value, $insid];
|
||||
}
|
||||
else {
|
||||
${$self->{popularity}}[$self->{size}] = $key;
|
||||
$self->{content}->{$key} = [$value, $self->{size}];
|
||||
if ($self->{size} == $self->{cache_size}) {
|
||||
for (0 .. $#{$self->{popularity}}) {
|
||||
next unless defined $self->{popularity}[$_];
|
||||
$self->{content}{$self->{popularity}[$_]}[1] = $_;
|
||||
}
|
||||
$self->{is_indexed} = 1;
|
||||
}
|
||||
$self->{size}++;
|
||||
}
|
||||
}
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $key) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
exists $self->{content}->{$key} or return undef;
|
||||
$self->{size}--;
|
||||
my $aref = delete $self->{content}->{$key};
|
||||
undef $self->{popularity}->[$aref->[1]];
|
||||
return $aref->[0];
|
||||
}
|
||||
|
||||
sub CLEAR {
|
||||
my $self = shift;
|
||||
$self->{content} = {};
|
||||
$self->{size} = 0;
|
||||
$self->{popularity} = [];
|
||||
$self->{is_indexed} = 0;
|
||||
}
|
||||
|
||||
sub EXISTS {
|
||||
my ($self, $key) = @_;
|
||||
if (ref $key) {
|
||||
require GT::Dumper;
|
||||
my $dmp = new GT::Dumper (
|
||||
{
|
||||
data => $key,
|
||||
sort => 1
|
||||
}
|
||||
);
|
||||
my $new = $dmp->dump;
|
||||
$key = $new;
|
||||
}
|
||||
return exists $self->{content}->{$key} ? 1 : 0;
|
||||
}
|
||||
|
||||
sub FIRSTKEY {
|
||||
my $self = shift;
|
||||
my $c = keys %{$self->{content}};
|
||||
return scalar each %{$self->{content}};
|
||||
}
|
||||
|
||||
sub NEXTKEY {return scalar each %{shift()->{content}}}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Cache - Tied hash which caches output of functions.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Cache;
|
||||
my %cache;
|
||||
tie %cache, 'GT::Cache', $size, \&function;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Cache implements a simple but quick caching scheme for remembering
|
||||
the results of functions. It also implements a max size to prevent
|
||||
the cache from growing and drops least frequently requested entries
|
||||
first, making it very useful under mod_perl.
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
use GT::Cache;
|
||||
my %cache;
|
||||
tie %cache, 'GT::Cache', 100, \&complex_func;
|
||||
|
||||
while (<>) {
|
||||
print "RESULT: ", $cache{$_}, "\n";
|
||||
}
|
||||
|
||||
sub complex_func {
|
||||
my $input = shift;
|
||||
# .. do complex work.
|
||||
return $output;
|
||||
}
|
||||
|
||||
This will cache the results of complex_func, and only run it when
|
||||
the input is different. It stores a max of 100 entries at a time,
|
||||
with the least frequently requested getting dropped first.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
Currently, you can only pass as input to the function a single
|
||||
scalar, and the output must be a single scalar. See the
|
||||
Memoize module in CPAN for a much more robust implementation.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Cache.pm,v 1.13 2004/01/13 01:35:15 jagerman Exp $
|
||||
|
||||
=cut
|
||||
929
site/slowtwitch.com/cgi-bin/articles/GT/Config.pm
Normal file
929
site/slowtwitch.com/cgi-bin/articles/GT/Config.pm
Normal file
@ -0,0 +1,929 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Config
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Config.pm,v 1.47 2007/02/24 00:59:17 sbeck Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# A module for handling loading and caching of configuration files.
|
||||
#
|
||||
|
||||
package GT::Config;
|
||||
# ===============================================================
|
||||
|
||||
use strict;
|
||||
|
||||
use GT::Base qw/PERSIST/; # Due to the nature of the config file's hash-like interface, we can't inherit from GT::Base - it sets things in $self. We do need GT::Base for its in_eval function though.
|
||||
use GT::Template::Inheritance;
|
||||
use GT::AutoLoader;
|
||||
|
||||
use constants
|
||||
DATA => 0,
|
||||
INHERITED => 1,
|
||||
FILES => 2,
|
||||
FILES_MOD => 3,
|
||||
CODE_STR => 4;
|
||||
|
||||
use vars qw(%ATT %ATTRIBS %CACHE %SUB_CACHE $error $ERRORS $VERSION);
|
||||
|
||||
# %ATT stores the default attribute values
|
||||
# %ATTRIBS stores the attributes of each object. Since each object works exactly
|
||||
# like a hash ref of the data it represents, these attributes cannot be stored
|
||||
# in $self.
|
||||
# %CACHE is used to cache any data of objects using the 'cache' option. Each
|
||||
# file in here has an array ref value - the first value is a hash ref of the
|
||||
# data, the second a hash ref of inherited keys, the third an array of the
|
||||
# files inherited from, and the fourth a hash of [size, last modification
|
||||
# time] pairs of those files.
|
||||
# %SUB_CACHE is exactly like %CACHE, except that values starting with 'sub {'
|
||||
# will be compiled into code refs. Each array ref has a fifth value - a hash
|
||||
# reference list that stores the original value of any code refs that have
|
||||
# been compiled. %SUB_CACHE is only used when you use 'compile_subs'. Also,
|
||||
# because different packages can be specified, this stores which package the
|
||||
# code ref was compiled in.
|
||||
# $error stores any error that occurs. If a load error happens, you'll need to
|
||||
# use $error to get the error message (when not using the 'create_ok' option).
|
||||
# $ERRORS stores all the error codes
|
||||
# $VERSION - $Id: Config.pm,v 1.47 2007/02/24 00:59:17 sbeck Exp $ - The version.
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.47 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
%ATT = (
|
||||
inheritance => 0, # If set, looks for .tplinfo files for inheritance.
|
||||
local => 0, # If set, will look for "local" directories containing the file. The file will be saved in a "local" subdirectory of the directory given.
|
||||
cache => 1, # If set, GT::Config will look in the cache for the object; objects are always stored in the cache, so that ->load(cache => 0) can be used to reload a file.
|
||||
create_ok => 0, # If set, you'll get a GT::Config object even if the file doesn't exist. You can then save() it to create the file. If not set, a fatal error occurs if the file cannot be located. Note that if the file exists, but has a syntax error, or cannot be read, a fatal error will occur regardless of this option.
|
||||
empty => 0, # If specified, nothing will be read from disk - can be used to force a new, blank config file
|
||||
chmod => 0666, # The octal permissions to set on the file immediately after saving
|
||||
strict => 0, # If true, a fatal error will occur when attempting to access a key that does not exist.
|
||||
debug => 0, # If true, warnings and debugging will be printing to STDERR
|
||||
tmpfile => undef, # Possible values: 0, undef, 1. 0 = no tempfile, undef = tempfile if dir writable, 1 = always tempfile
|
||||
header => '', # Can be set to anything. When saving, this will go before the data. Keep in mind, this has to be correct Perl. [localtime] in here will be replaced with scalar localtime() when saving.
|
||||
compile_subs => '', # Must be set to a package. If set, any value that starts with 'sub {' will be compiled into a code ref, in the package specified.
|
||||
sort_order => undef, # Passed to GT::Dumper->dump as 'order' value if set
|
||||
tab => "\t", # What to use for a "tab" in the config file. Defaults to an actual tab.
|
||||
);
|
||||
|
||||
# Other attributes used internally:
|
||||
# filename => '', # Whatever you give as the filename
|
||||
# file => '', # Just the filename (no path)
|
||||
# path => '', # The path of the filename
|
||||
# files => {}, # A hash of filename => last_mod_time (may contain multiple entries to support inheritance).
|
||||
# file_order => [], # The order of the files in 'files'
|
||||
# data => {}, # The actual data of the config file.
|
||||
# inherited => {}, # Each base key inherited will have $key => 1 in here. Inherited keys are not saved, unless they are changed between load time and save time.
|
||||
# compiled => {}, # Any keys that start with 'sub {' will be compiled into code refs if the compile_subs option is on. The code reference is saved here so that recompiling is not necessary
|
||||
|
||||
$ERRORS = {
|
||||
CANT_LOAD => q _Unable to load '%s': %s._,
|
||||
CANT_COMPILE => q _Unable to compile '%s': %s._,
|
||||
CANT_FIND => q _Config file '%s' does not exist in directory '%s' or has incorrect permissions set._,
|
||||
CANT_WRITE => q _Unable to open '%s' for writing: %s._,
|
||||
CANT_PRINT => q _Unable to write to file '%s': %s._,
|
||||
CANT_RENAME => q _Unable to move '%s' to '%s': %s._,
|
||||
WRITE_MISMATCH => q _Unable to save '%s': wrote %d bytes, but file is %d bytes_,
|
||||
CANT_CREATE_DIR => q _Unable to create directory '%s': %s._,
|
||||
NOT_HASH => q _Config file '%s' did not return a hash reference._,
|
||||
BAD_ARGS => q _Bad arguments. Usage: %s_,
|
||||
NOT_FILE => q _'%s' does not look like a valid filename_,
|
||||
RECURSION => q _Recursive inheritance detected and interrupted: '%s'_,
|
||||
UNKNOWN_OPT => q _Unknown option '%s' passed to %s_,
|
||||
BAD_KEY => q _The key you attempted to access, '%s', does not exist in '%s'_,
|
||||
CANT_COMPILE_CODE => q _Unable to compile '%s' in file '%s': %s_
|
||||
};
|
||||
|
||||
sub load {
|
||||
my $class = shift;
|
||||
|
||||
my (%attribs, %data);
|
||||
|
||||
tie %data, $class, \%attribs;
|
||||
my $self = bless \%data, ref $class || $class;
|
||||
|
||||
$ATTRIBS{$self} = \%attribs; # hehehe ;-)
|
||||
|
||||
my $filename = shift or return $self->error(BAD_ARGS => FATAL => 'GT::Config->load("/path/to/config/file", { opts })');
|
||||
$attribs{filename} = $filename;
|
||||
$attribs{filename_given} = $filename;
|
||||
|
||||
@attribs{'path', 'file'} = ($filename =~ m|^(.*?)[\\/]?([^\\/]+)$|) or return $self->error(NOT_FILE => FATAL => $filename);
|
||||
$attribs{path} = '.' unless length $attribs{path};
|
||||
$filename = $attribs{filename} = "$attribs{path}/$attribs{file}"; # _load_data/_load_tree depend on it being like this.
|
||||
|
||||
my $opts = shift || {};
|
||||
ref $opts eq 'HASH' or return $self->error(BAD_ARGS => FATAL => 'GT::Config->load("/path/to/config/file", { opts })');
|
||||
|
||||
for (keys %ATT) {
|
||||
if (/^(?:inheritance|local|cache|create_ok|strict|empty)$/) {
|
||||
$attribs{$_} = exists $opts->{$_} ? (delete $opts->{$_} ? 1 : 0) : $ATT{$_};
|
||||
}
|
||||
elsif ($_ eq 'tmpfile') {
|
||||
if (exists $opts->{$_}) {
|
||||
my $tmpfile = delete $opts->{$_};
|
||||
$attribs{$_} = defined($tmpfile) ? $tmpfile ? 1 : 0 : undef;
|
||||
}
|
||||
else {
|
||||
$attribs{$_} = $ATT{$_};
|
||||
}
|
||||
}
|
||||
else {
|
||||
$attribs{$_} = exists $opts->{$_} ? delete $opts->{$_} : $ATT{$_};
|
||||
}
|
||||
}
|
||||
|
||||
$self->debug("Received '$filename' for the file to load", 2) if $attribs{debug} >= 2;
|
||||
|
||||
if (keys %$opts) {
|
||||
$self->error(UNKNOWN_OPT => FATAL => keys %$opts => ref($self) . '->load');
|
||||
}
|
||||
|
||||
$self->debug("Loading '$filename' with options: inheritance => '$attribs{inheritance}', local => '$attribs{local}', cache => '$attribs{cache}', create_ok => '$attribs{create_ok}', empty => '$attribs{empty}', chmod => '$attribs{chmod}', strict => '$attribs{strict}', debug => '$attribs{debug}', compile_subs => '$attribs{compile_subs}'") if $attribs{debug};
|
||||
$self->debug("Header: '$attribs{header}'", 2) if $attribs{debug} >= 2;
|
||||
|
||||
if ($attribs{empty}) {
|
||||
# An empty config file doesn't get added to the cache
|
||||
$self->debug("Not loading any data or cache - 'empty' specified") if $attribs{debug};
|
||||
}
|
||||
elsif ($attribs{cache} and $attribs{compile_subs} and $SUB_CACHE{$attribs{compile_subs}}->{$filename} and my $debug_unchanged = $self->_is_unchanged(@{$SUB_CACHE{$attribs{compile_subs}}->{$filename}}[FILES, FILES_MOD])) {
|
||||
$self->debug("Loading '$filename' from compiled sub cache") if $attribs{debug};
|
||||
@attribs{qw{data inherited file_order files compiled}} = @{$SUB_CACHE{$attribs{compile_subs}}->{$filename}};
|
||||
$attribs{cache_hit} = 1;
|
||||
}
|
||||
elsif ($attribs{cache} and not $attribs{compile_subs} and $CACHE{$filename} and $debug_unchanged = $self->_is_unchanged(@{$CACHE{$filename}}[FILES, FILES_MOD])) {
|
||||
$self->debug("Loading '$filename' from regular cache") if $attribs{debug};
|
||||
@attribs{qw{data inherited file_order files}} = @{$CACHE{$filename}};
|
||||
$attribs{cache_hit} = 1;
|
||||
}
|
||||
else {
|
||||
$self->debug("Not loading '$filename' from cache") if $attribs{debug};
|
||||
if ($attribs{debug} > 1) { # If the debug level is > 1, display some debugging as to _why_ we aren't loading from cache
|
||||
$self->debug("Reason: Caching disabled") if not $attribs{cache};
|
||||
if ($attribs{compile_subs} and not $SUB_CACHE{$attribs{compile_subs}}->{$filename}) { $self->debug("Reason: Not in compiled sub cache") }
|
||||
elsif (not $attribs{compile_subs} and not $CACHE{$filename}) { $self->debug("Reason: Not in regular cache") }
|
||||
$self->debug("Reason: File (or inherited files) have changed") if ($attribs{compile_subs} ? $SUB_CACHE{$attribs{compile_subs}}->{$filename} : $CACHE{$filename}) and not $debug_unchanged;
|
||||
}
|
||||
$self->_load_data($filename) or return;
|
||||
if (@{$attribs{file_order}}) { # Don't cache it if it is a new object
|
||||
if ($attribs{compile_subs}) {
|
||||
$self->debug("Adding '$filename' (compile package '$attribs{compile_subs}') to the compiled sub cache") if $attribs{debug};
|
||||
$SUB_CACHE{$attribs{compile_subs}}->{$filename} = [@attribs{qw{data inherited file_order files compiled}}];
|
||||
}
|
||||
else {
|
||||
$self->debug("Adding '$filename' to the regular cache") if $attribs{debug};
|
||||
$CACHE{$filename} = [@attribs{qw{data inherited file_order files}}];
|
||||
}
|
||||
}
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{save} = __LINE__ . <<'END_OF_SUB';
|
||||
sub save {
|
||||
require GT::Dumper;
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
my ($d, $i) = @$att{'data', 'inherited'};
|
||||
|
||||
my %data;
|
||||
for (keys %$d) { # Strip out all inherited data
|
||||
next if $i->{$_};
|
||||
|
||||
$data{$_} = $d->{$_};
|
||||
}
|
||||
|
||||
my $filename = $att->{path};
|
||||
|
||||
local $!;
|
||||
if ($att->{local}) {
|
||||
$filename .= "/local";
|
||||
if (!-d $filename) { # $filename is misleading - it's currently a path
|
||||
# Attempt to create the "local" directory
|
||||
mkdir($filename, 0777) or return $self->error(CANT_CREATE_DIR => FATAL => $filename => "$!");
|
||||
CORE::chmod(0777, $filename);
|
||||
}
|
||||
}
|
||||
|
||||
my $tmpfile = $att->{tmpfile};
|
||||
if (not defined $tmpfile) {
|
||||
# Base whether or not we use the tempfile on whether or not we can
|
||||
# write to the base directory of the file:
|
||||
$tmpfile = -w $filename;
|
||||
}
|
||||
|
||||
$filename .= "/$att->{file}";
|
||||
|
||||
$self->debug("Saving '$filename'") if $att->{debug};
|
||||
|
||||
my $localtime = scalar localtime;
|
||||
my $header = $att->{header};
|
||||
if ($header) {
|
||||
$header =~ s/\[localtime\]/$localtime/g;
|
||||
$header .= "\n" unless $header =~ /\n$/;
|
||||
}
|
||||
|
||||
my $write_filename = $tmpfile ? "$filename.tmp.$$." . time . "." . int rand 10000 : $filename;
|
||||
my $printed = 0;
|
||||
my $windows = $^O eq 'MSWin32';
|
||||
|
||||
local *FILE;
|
||||
open FILE, "> $write_filename" or return $self->error(CANT_WRITE => FATAL => $write_filename => "$!");
|
||||
# Print header, if any:
|
||||
if ($header) {
|
||||
$printed += length $header;
|
||||
$printed += $header =~ y/\n// if $windows; # Windows does \n => \r\n translation on FH output
|
||||
unless (print FILE $header) {
|
||||
my $err = "$!";
|
||||
close FILE;
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
||||
}
|
||||
}
|
||||
# Print actual data:
|
||||
my $dump = GT::Dumper->dump(
|
||||
var => '',
|
||||
data => \%data,
|
||||
sort => 1,
|
||||
$att->{sort_order} ? (order => $att->{sort_order}) : (),
|
||||
tab => $att->{tab}
|
||||
);
|
||||
$printed += length $dump;
|
||||
$printed += $dump =~ y/\n// if $windows;
|
||||
unless (print FILE $dump) {
|
||||
my $err = "$!";
|
||||
close FILE;
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
||||
}
|
||||
# Print the vim info line at the bottom:
|
||||
my $viminfo = "\n# vim:syn=perl:ts=4:noet\n";
|
||||
$printed += length $viminfo;
|
||||
$printed += $viminfo =~ y/\n// if $windows;
|
||||
unless (print FILE $viminfo) {
|
||||
my $err = "$!";
|
||||
close FILE;
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(CANT_PRINT => FATAL => $write_filename => $err);
|
||||
}
|
||||
|
||||
close FILE;
|
||||
|
||||
# Check that the file is the right size, because print() returns true if a
|
||||
# _partial_ print succeeded. Ideally we would check -s on the filehandle after
|
||||
# each print, but of course that doesn't work on Windows.
|
||||
unless ((my $actual = -s $write_filename) == $printed) {
|
||||
unlink $write_filename if $tmpfile;
|
||||
return $self->error(WRITE_MISMATCH => FATAL => $write_filename => $printed => $actual);
|
||||
}
|
||||
|
||||
if ($tmpfile) {
|
||||
$self->debug("'$write_filename' saved; renaming to '$filename'") if $att->{debug} > 1;
|
||||
unless (rename $write_filename, $filename) {
|
||||
my $err = "$!";
|
||||
unlink $write_filename;
|
||||
return $self->error(CANT_RENAME => FATAL => $write_filename => $filename => $err);
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $att->{chmod}) {
|
||||
my $mode = (stat $filename)[2] & 07777;
|
||||
CORE::chmod($att->{chmod}, $filename) unless $att->{chmod} == $mode;
|
||||
}
|
||||
$self->debug("'$filename' saved, $printed bytes.") if $att->{debug};
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Returns true if the current object was loaded from cache, false otherwise.
|
||||
sub cache_hit { $ATTRIBS{$_[0]}->{cache_hit} }
|
||||
|
||||
sub _is_unchanged {
|
||||
my ($self, $old_order, $old_mod) = @_;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$self->debug("Checking for any changes in the file (or inherited files)") if $att->{debug};
|
||||
|
||||
my @old_order = @$old_order; # Copy the old file_order and file modification
|
||||
my %old_mod = %$old_mod; # times. _load_tree will replace them.
|
||||
|
||||
my $just_do_ok = not (PERSIST or $att->{inheritance} or $att->{local} or $att->{create_ok});
|
||||
|
||||
$self->_load_tree($just_do_ok);
|
||||
|
||||
if (@{$att->{file_order}} != @old_order) {
|
||||
$self->debug("The old order and the new differ: Old: (@old_order) New: (@{$att->{file_order}})") if $att->{debug};
|
||||
return;
|
||||
}
|
||||
for (0 .. $#old_order) {
|
||||
if ($old_order[$_] ne $att->{file_order}->[$_]) {
|
||||
$self->debug("The old order and the new differ: Old: (@old_order) New: (@{$att->{file_order}})") if $att->{debug};
|
||||
return; # The inherited files are not the same as before
|
||||
}
|
||||
elsif ($att->{debug} >= 2) {
|
||||
$self->debug("Old order and new order do not differ. Old: (@old_order) New: (@{$att->{file_order}})");
|
||||
}
|
||||
|
||||
if ($old_mod{$old_order[$_]}->[0] != $att->{files}->{$old_order[$_]}->[0]) {
|
||||
$self->debug("The file size of $old_order[$_] has changed: Old: $old_mod{$old_order[$_]}->[0], New: $att->{files}->{$old_order[$_]}->[0]") if $att->{debug};
|
||||
return; # The inherited files have changed in size
|
||||
}
|
||||
elsif ($old_mod{$old_order[$_]}->[1] != $att->{files}->{$old_order[$_]}->[1]) {
|
||||
$self->debug("The modification time of $old_order[$_] has changed: Old: $old_mod{$old_order[$_]}->[1], New: $att->{files}->{$old_order[$_]}->[1]") if $att->{debug};
|
||||
return; # The inherited files have a changed mtime
|
||||
}
|
||||
elsif ($att->{debug} >= 2) {
|
||||
$self->debug("The file size and modification time of $old_order[$_] has not changed");
|
||||
}
|
||||
}
|
||||
|
||||
$self->debug("No changes have been made") if $att->{debug};
|
||||
1; # Here's the prize. Nothing is changed.
|
||||
}
|
||||
|
||||
sub _load_data {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
my $just_do_ok = not (PERSIST or $att->{inheritance} or $att->{local} or $att->{create_ok});
|
||||
|
||||
$self->_load_tree($just_do_ok) or return;
|
||||
|
||||
if ($just_do_ok and not @{$att->{file_order}}) {
|
||||
push @{$att->{file_order}}, $att->{filename_given};
|
||||
}
|
||||
|
||||
for my $file (@{$att->{file_order}}) {
|
||||
local ($@, $!, $^W);
|
||||
$self->debug("do()ing '$file'") if $att->{debug} >= 2;
|
||||
my $data = do $file;
|
||||
if (!$data and $@) {
|
||||
return $self->error(CANT_LOAD => FATAL => $file => "$@");
|
||||
}
|
||||
elsif (!$data and $!) {
|
||||
return $self->error(CANT_COMPILE => FATAL => $file => "$!");
|
||||
}
|
||||
elsif (ref $data ne 'HASH') {
|
||||
return $self->error(NOT_HASH => FATAL => $file);
|
||||
}
|
||||
if ($just_do_ok or $file eq ($att->{local} ? "$att->{path}/local/$att->{file}" : $att->{filename})) {
|
||||
$att->{data} = $data;
|
||||
}
|
||||
else {
|
||||
for (keys %$data) {
|
||||
next if exists $att->{data}->{$_};
|
||||
$att->{data}->{$_} = $data->{$_};
|
||||
$att->{inherited}->{$_} = 1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1; # Returning true means loading was successful.
|
||||
}
|
||||
|
||||
sub _load_tree {
|
||||
my $self = shift;
|
||||
my $just_do_ok = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
my $root = $att->{path};
|
||||
my $file = $att->{file};
|
||||
|
||||
if ($att->{inheritance}) {
|
||||
$att->{file_order} = [GT::Template::Inheritance->get_all_paths(file => $att->{file}, path => $att->{path})];
|
||||
|
||||
unless (@{$att->{file_order}} or $att->{create_ok} or $just_do_ok) {
|
||||
return $self->error('CANT_FIND' => 'FATAL', $att->{file}, $att->{path});
|
||||
# No files found!
|
||||
}
|
||||
|
||||
for (@{$att->{file_order}}) {
|
||||
$att->{files}->{$_} = [(stat($_))[7, 9]];
|
||||
}
|
||||
}
|
||||
else {
|
||||
$att->{file_order} = [];
|
||||
if (-e "$root/local/$file") {
|
||||
push @{ $att->{file_order} }, "$root/local/$file";
|
||||
$att->{files}{"$root/local/$file"} = [(stat(_))[7, 9]];
|
||||
}
|
||||
if (-e "$root/$file") {
|
||||
push @{ $att->{file_order} }, "$root/$file";
|
||||
$att->{files}{"$root/$file"} = [(stat(_))[7, 9]];
|
||||
}
|
||||
if (!$att->{create_ok} and !$just_do_ok and !@{ $att->{file_order} }) {
|
||||
return $self->error(CANT_FIND => FATAL => $att->{file}, $att->{path});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
$COMPILE{inheritance} = __LINE__ . <<'END_OF_SUB';
|
||||
sub inheritance {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$att->{inheritance};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{tmpfile} = __LINE__ . <<'END_OF_SUB';
|
||||
sub tmpfile {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{tmpfile};
|
||||
my $tmpfile = shift;
|
||||
$tmpfile = defined($tmpfile) ? $tmpfile ? 1 : 0 : undef;
|
||||
$att->{tmpfile} = $tmpfile;
|
||||
return $ret;
|
||||
}
|
||||
$att->{tmpfile};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Must be specified in load() - this only retrieves the value
|
||||
$COMPILE{create_ok} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_ok {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$att->{create_ok};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{chmod} = __LINE__ . <<'END_OF_SUB';
|
||||
sub chmod {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{chmod};
|
||||
$att->{chmod} = shift;
|
||||
return $ret;
|
||||
}
|
||||
$att->{chmod};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Must be specified in load()
|
||||
$COMPILE{cache} = __LINE__ . <<'END_OF_SUB';
|
||||
sub cache {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
$att->{cache};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{strict} = __LINE__ . <<'END_OF_SUB';
|
||||
sub strict {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{strict} ? 1 : 0;
|
||||
$att->{strict} = shift() ? 1 : 0;
|
||||
return $ret;
|
||||
}
|
||||
$att->{strict};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{debug_level} = __LINE__ . <<'END_OF_SUB';
|
||||
sub debug_level {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{debug};
|
||||
$att->{debug} = shift;
|
||||
return $ret;
|
||||
}
|
||||
$att->{debug};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{debug} = __LINE__ . <<'END_OF_SUB';
|
||||
sub debug {
|
||||
# -------------------------------------------------------
|
||||
# Displays a debugging message.
|
||||
#
|
||||
my ($self, $msg, $min) = @_;
|
||||
my $att = $ATTRIBS{$self};
|
||||
|
||||
$min ||= 1;
|
||||
return if $att->{debug} < $min;
|
||||
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
# Add line numbers if no \n on the debug message
|
||||
if (substr($msg, -1) ne "\n") {
|
||||
my ($file, $line) = (caller)[1,2];
|
||||
$msg .= " at $file line $line.\n";
|
||||
}
|
||||
|
||||
# Remove windows linefeeds (breaks unix terminals).
|
||||
$msg =~ s/\r//g unless $^O eq 'MSWin32';
|
||||
|
||||
print STDERR "$pkg ($$): $msg";
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{header} = __LINE__ . <<'END_OF_SUB';
|
||||
sub header {
|
||||
my $self = shift;
|
||||
my $att = $ATTRIBS{$self};
|
||||
if (@_) {
|
||||
my $ret = $att->{header};
|
||||
$att->{header} = shift || '';
|
||||
return $ret;
|
||||
}
|
||||
$att->{header};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Be sure to delete the object from %ATTRIBS.
|
||||
sub DESTROY {
|
||||
delete $ATTRIBS{$_[0]} if keys %ATTRIBS and exists $ATTRIBS{$_[0]};
|
||||
}
|
||||
|
||||
$COMPILE{error} = __LINE__ . <<'END_OF_SUB';
|
||||
sub error {
|
||||
my ($self, $code, $type, @args) = @_;
|
||||
$type = $type && uc $type eq 'WARN' ? 'WARN' : 'FATAL';
|
||||
my $pkg = ref $self || $self;
|
||||
|
||||
$error = _format_err($pkg, $code, @args);
|
||||
|
||||
if ($type eq 'FATAL') {
|
||||
die $error if GT::Base::in_eval();
|
||||
|
||||
if ($SIG{__DIE__}) {
|
||||
die $error;
|
||||
}
|
||||
else {
|
||||
print STDERR $error;
|
||||
die "\n";
|
||||
}
|
||||
}
|
||||
elsif ($ATTRIBS{$self}->{debug}) { # A warning, and debugging is on
|
||||
if ($SIG{__WARN__}) {
|
||||
CORE::warn $error;
|
||||
}
|
||||
else {
|
||||
print STDERR $error;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _format_err {
|
||||
# -------------------------------------------------------
|
||||
# Formats an error message for output.
|
||||
#
|
||||
my ($pkg, $code, @args) = @_;
|
||||
my $msg = sprintf($ERRORS->{$code} || $code, @args);
|
||||
|
||||
my ($file, $line) = GT::Base::get_file_line($pkg);
|
||||
return "$pkg ($$): $msg at $file line $line.\n";
|
||||
}
|
||||
|
||||
# Tied hash handling
|
||||
sub TIEHASH { bless $_[1], $_[0] }
|
||||
sub STORE {
|
||||
$_[0]->{data}->{$_[1]} = $_[2];
|
||||
delete $_[0]->{inherited}->{$_[1]};
|
||||
delete $_[0]->{compiled}->{$_[1]};
|
||||
}
|
||||
sub FETCH {
|
||||
my $att = shift; # $_[0] is NOT $self - it is the attribute hashref
|
||||
my $key = shift;
|
||||
|
||||
if ($att->{strict} and not exists $att->{data}->{$key}) {
|
||||
return GT::Config->error(BAD_KEY => FATAL => $key, $att->{filename});
|
||||
}
|
||||
elsif ($att->{compile_subs} and not ref $att->{data}->{$key} and substr($att->{data}->{$key}, 0, 5) eq 'sub {') {
|
||||
return $att->{compiled}->{$key} if exists $att->{compiled}->{$key};
|
||||
|
||||
my ($code, $err);
|
||||
# Perl breaks when the eval below contains a 'use' statement. Somehow, Perl
|
||||
# thinks it's deeper (in terms of { ... }) than it really is, and so ends up
|
||||
# either exiting the subroutine prematurely, or, if we try to work around that
|
||||
# by using another subroutine, or returning early, by jumping back one
|
||||
# subroutine too many with its return value. So, to get around the whole
|
||||
# problem, we wrap the code in double-evals if it contains 'use' or 'BEGIN'.
|
||||
# It won't _break_ anything, but unfortunately it does slow compiled_subs
|
||||
# globals a little bit slower.
|
||||
if ($att->{data}->{$key} =~ /\b(use|no)\s+[\w:]/ or $att->{data}->{$key} =~ /\bBEGIN\b/) {
|
||||
$code = eval "package $att->{compile_subs}; my \$ret = eval qq|\Q$att->{data}->{$key}\E|; die qq|\$\@\n| if \$\@; \$ret;";
|
||||
}
|
||||
else {
|
||||
$code = eval "package $att->{compile_subs}; $att->{data}->{$key};";
|
||||
}
|
||||
$err = "$@";
|
||||
|
||||
# Perl prior to 5.6.1 breaks on this:
|
||||
# perl -e 'my $c = eval "package SomePkg; sub bar { use NotThere }"; eval "package OtherPkg; print 1"; die "$@" if $@'
|
||||
# From that, we die with: syntax error at (eval 2) line 1, near "package OtherPkg"
|
||||
# This little hack fixes it, but don't ask me why:
|
||||
eval "package Hack;" if $] < 5.006001;
|
||||
|
||||
if (ref $code ne 'CODE') {
|
||||
GT::Config->error(CANT_COMPILE_CODE => WARN => $key, $att->{filename}, $err);
|
||||
my $error = "Unable to compile '$key': $err";
|
||||
$code = sub { $error };
|
||||
}
|
||||
|
||||
return $att->{compiled}->{$key} = $code;
|
||||
}
|
||||
|
||||
$att->{data}->{$key};
|
||||
}
|
||||
|
||||
sub FIRSTKEY { keys %{$_[0]->{data}}; each %{$_[0]->{data}} }
|
||||
sub NEXTKEY { each %{$_[0]->{data}} }
|
||||
sub EXISTS { exists $_[0]->{data}->{$_[1]} }
|
||||
sub DELETE {
|
||||
my $val;
|
||||
$val = $_[0]->FETCH($_[1]) if defined wantarray;
|
||||
delete $_[0]->{inherited}->{$_[1]};
|
||||
delete $_[0]->{data}->{$_[1]};
|
||||
delete $_[0]->{compiled}->{$_[1]};
|
||||
$val;
|
||||
}
|
||||
sub CLEAR { %{$_[0]->{data}} = %{$_[0]->{inherited}} = %{$_[0]->{compiled}} = () }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Config - Dumped-hash configuration handler
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Config;
|
||||
my $Config = GT::Config->load($config_file);
|
||||
...
|
||||
print $Config->{variable};
|
||||
...
|
||||
$Config->{othervar} = "something";
|
||||
...
|
||||
$Config->save;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Config provides a simple way to handle loading config files. It can load
|
||||
and save any config file consisting of a dumped hash. You can then use the
|
||||
object as if it were the actual hash reference from the config file. It
|
||||
supports template set inheritance (see L<GT::Template>) and mtime-based
|
||||
caching.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 load
|
||||
|
||||
There is no C<new()> method. To get a new config object you do:
|
||||
|
||||
$Config = GT::Config->load("/path/to/config/file", { options });
|
||||
|
||||
The first argument is the full path to the file to open to read the
|
||||
configuration. The file does not necessarily have to exist - see the options
|
||||
below.
|
||||
|
||||
The second argument is a hash reference of options, and is optional. The
|
||||
possible options are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item inheritance
|
||||
|
||||
If provided as something true, GT::Config will scan for .tplinfo files looking
|
||||
for inherited template sets. This is typically used for loading globals.txt or
|
||||
language.txt files from Gossamer Threads products' template sets.
|
||||
|
||||
Defaults to off.
|
||||
|
||||
=item local
|
||||
|
||||
If provided as something true, GT::Config will look for a "local" directory
|
||||
containing the file. When using inheritance, a "local" directory will also be
|
||||
looked for in each inherited configuration file. However, regardless of the
|
||||
C<inheritance> option, "local" configuration files always inherit from their
|
||||
non-local counterpart.
|
||||
|
||||
Additionally, this option causes GT::Config to save the file into a "local"
|
||||
directory. Also note that the "local" file will _only_ contain keys that were
|
||||
already in the local file, or were assigned to the config object after loading
|
||||
the file.
|
||||
|
||||
Defaults to off.
|
||||
|
||||
=item cache
|
||||
|
||||
If provided, will look in the internal cache for a cached copy of the file. If
|
||||
none is found, a new GT::Config object will be constructed as usual, then saved
|
||||
in the cache.
|
||||
|
||||
Defaults to on. You must pass C<cache =E<gt> 0> to disable cached loading.
|
||||
Note that new objects are always stored in the cache, allowing you to specify
|
||||
C<cache =E<gt> 0> to force a reload of a cached file.
|
||||
|
||||
=item create_ok
|
||||
|
||||
If set, you'll still get back a GT::Config hash even if the file doesn't exist.
|
||||
You can then save() the object to create a new config file. If this option is
|
||||
not set, a fatal error will occur when attempting to load a file that does not
|
||||
exist.
|
||||
|
||||
Defaults to off. Pass in C<create_ok =E<gt> 1> if the config file doesn't
|
||||
necessarily have to exist (i.e. when creating a new config file).
|
||||
|
||||
=item empty
|
||||
|
||||
The C<empty> option is used to create a new, blank config file - it can be
|
||||
thought of as a forced version of the C<create_ok> option. It won't read
|
||||
B<any> files during loading (and as such completely ignores the C<inheritance>
|
||||
and C<cache> options). This is mainly intended to be used when a complete
|
||||
replacement of a file is desired, regardless of what is currently on disk.
|
||||
|
||||
=item chmod
|
||||
|
||||
The C<chmod> option is used to specify the mode of the saved file. It must be
|
||||
passed in octal form, such as 0644 (but B<not> in string form, such as
|
||||
C<"0644">). The default is 0666, to allow writing by any users. Though not
|
||||
terribly secure, this is the sort of environment most CGI scripts require.
|
||||
Setting a chmod value of undef instructs GT::Config to not perform a chmod.
|
||||
|
||||
=item strict
|
||||
|
||||
If set, a fatal error will occur when attempting to access a key of the config
|
||||
file that does not exist. Note, however, that this only covers the first level
|
||||
data structions - C<$CFG-E<gt>{foo}-E<gt>{bar}> will not fatal if C<foo> is a
|
||||
hash ref, but C<bar> is not set in that hash reference. C<$CFG-E<gt>{foo}>
|
||||
(and C<$CFG-E<gt>{foo}-E<gt>{bar}>) will fatal if the key C<foo> does not exist
|
||||
in the config data.
|
||||
|
||||
=item debug
|
||||
|
||||
If provided, debugging information will be printed. This will also cause a
|
||||
warning to occur if L<"fatal"> is disabled and load fails.
|
||||
|
||||
Defaults to disabled. Should not be used in production code, except when
|
||||
debugging.
|
||||
|
||||
=item tmpfile
|
||||
|
||||
Instructs GT::Config to attempt to use a temporary file when saving. If used,
|
||||
the contents will be written to a temporary file, then, if successfully
|
||||
written, the temporary file will be moved to overwrite the real file. This
|
||||
solves a couple of problems. Firstly, a full disk will never result in a
|
||||
partial file as if the entire file is not written to the temporary file, it
|
||||
will not overwrite the file already stored on disk. Secondly, it avoids a
|
||||
potential problem with multiple processes attempting to write to the file at
|
||||
the same time.
|
||||
|
||||
The following values are accepted:
|
||||
|
||||
0 - Do not use a temporary file
|
||||
undef - Use a temporary file if the base directory is writable
|
||||
1 - Always use a temporary file
|
||||
|
||||
The default is C<undef>, which will attempt to use a temporary file is
|
||||
possible, but won't fail if the script has permission to modify existing files,
|
||||
but not to create new ones.
|
||||
|
||||
=item header
|
||||
|
||||
If provided, when saving a file this header will be written above the data.
|
||||
Keep in mind that the file must be Perl-compilable, so be careful if you are
|
||||
doing anything more than comments.
|
||||
|
||||
Note that the header may contain the string C<[localtime]>, which will be
|
||||
replaced with the return value of C<scalar localtime()> when saving, which is
|
||||
generally a value such as: C<Sun Jan 25 15:12:26 2004>.
|
||||
|
||||
=item tab
|
||||
|
||||
If provided, this will set what to use for tabs when calling save(). Defaults
|
||||
to an actual tab, since that cuts down the file size over using multiple
|
||||
spaces, while leaving the file readable.
|
||||
|
||||
=item compile_subs
|
||||
|
||||
If provided, any data starting with C<sub {> will be compiled into a
|
||||
subroutine. This compilation does not happen until the variable is accessed,
|
||||
at which point a fatal error will occur if the code could not be compiled. The
|
||||
code referenced will be cached (if using caching), but will be saved as the
|
||||
original string (starting with C<sub {>) when L<saving|"save">.
|
||||
|
||||
B<NOTE:> The argument to compile_subs must be a valid perl package; the code
|
||||
reference will be compiled in that package. For example,
|
||||
C<compile_subs =E<gt> 'GForum::Post'> will compile the code ref in the
|
||||
GForum::Post package. You need to do this to provide access to globals
|
||||
variables such as $DB, $IN, etc.
|
||||
|
||||
=item sort_order
|
||||
|
||||
If provided, the option will be passed through as the 'order' option of
|
||||
GT::Dumper for hash key ordering. See L<GT::Dumper>. GT::Config always sorts
|
||||
hash keys - this can be used when the default alphanumeric sort is not
|
||||
sufficient.
|
||||
|
||||
=back
|
||||
|
||||
=head2 save
|
||||
|
||||
To save a config file, simply call C<$object-E<gt>save()>. If the object uses
|
||||
inheritance, only those keys that were not inherited (or were modified from the
|
||||
inherited ones) will be saved.
|
||||
|
||||
$Config->save();
|
||||
|
||||
B<NOTE>: B<ALWAYS SAVE AFTER MAKING ANY CHANGES!!!>. If you do not save after
|
||||
making changes, the data retrieved from the cache may not be the same as the
|
||||
data stored in the configuration file on disk. After making ANY changes make
|
||||
absolutely sure that you either undo the change or save the configuration file.
|
||||
|
||||
=head2 cache_hit
|
||||
|
||||
Returns whether or not the current object was loaded from cache (1) or loaded
|
||||
from disk (undef).
|
||||
|
||||
=head2 inheritance
|
||||
|
||||
Returns the inheritance status (1 or 0) of the object.
|
||||
|
||||
=head2 create_ok
|
||||
|
||||
Returns the status (1 or 0) of the "create_ok" flag.
|
||||
|
||||
=head2 tmpfile
|
||||
|
||||
With no arguments, returns whether or not the object will attempt to use a
|
||||
temporary file when saving. Possible values are:
|
||||
|
||||
0 - Do not use a temporary file
|
||||
undef - Use a temporary file if the base directory is writable
|
||||
1 - Always use a temporary file
|
||||
|
||||
You can pass in a single argument of one of the above values to set whether or
|
||||
not the object will use a temporary file when saving.
|
||||
|
||||
=head2 cache
|
||||
|
||||
This method returns whether or not the object is cached. This cannot be
|
||||
enabled/disabled after loading a config file; you must specify it as an
|
||||
argument to C<load()> instead.
|
||||
|
||||
=head2 debug_level
|
||||
|
||||
This method returns the current debug level.
|
||||
|
||||
You may provide one argument which sets a new debug level.
|
||||
|
||||
0 means no debugging, 1 means basic debugging, 2 means heavy debugging.
|
||||
|
||||
If setting a new debug level, the old debug level is returned.
|
||||
|
||||
=head2 header
|
||||
|
||||
This method returns or sets the header that will be printed when saving.
|
||||
|
||||
With no arguments, returns the header.
|
||||
|
||||
You may provide one argument which sets a new header. Keep in mind that the
|
||||
file must be Perl-compilable, so take care if doing anything other than
|
||||
comments.
|
||||
|
||||
If providing a new header, the old header is returned.
|
||||
|
||||
Note that the header may contain the value C<[localtime]>, which will be
|
||||
replaced with the return value of C<scalar localtime()> when saving.
|
||||
|
||||
=head2 sort_order
|
||||
|
||||
This method returns or sets a code reference to be passed through as the
|
||||
'order' option of GT::Dumper for hash key ordering. See L<GT::Dumper>.
|
||||
GT::Config always sorts hash keys - this can be used when the default
|
||||
alphanumeric sort is not sufficient.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::Template::Inheritance>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
$Id: Config.pm,v 1.47 2007/02/24 00:59:17 sbeck Exp $
|
||||
|
||||
=cut
|
||||
1240
site/slowtwitch.com/cgi-bin/articles/GT/Date.pm
Normal file
1240
site/slowtwitch.com/cgi-bin/articles/GT/Date.pm
Normal file
File diff suppressed because it is too large
Load Diff
180
site/slowtwitch.com/cgi-bin/articles/GT/Delay.pm
Normal file
180
site/slowtwitch.com/cgi-bin/articles/GT/Delay.pm
Normal file
@ -0,0 +1,180 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Delay
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Delay.pm,v 1.4 2004/01/13 01:35:15 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Generic delayed-loading module wrapper.
|
||||
#
|
||||
|
||||
package GT::Delay;
|
||||
use strict;
|
||||
use Carp();
|
||||
|
||||
my %Delayed;
|
||||
|
||||
sub GT::Delay {
|
||||
# We don't define any subroutines in GT::Delay, since even ->new should be
|
||||
# allowed in some circumstances. Takes three arguments - the package to load
|
||||
# (i.e. 'GT::SQL'), the type of blessed reference used for that object ('HASH',
|
||||
# 'ARRAY', and 'SCALAR' are supported), and any number of arguments to pass
|
||||
# into the ->new method of the package.
|
||||
#
|
||||
my ($package, $type, @args) = @_;
|
||||
$type ||= 'HASH';
|
||||
$type eq 'HASH' || $type eq 'ARRAY' || $type eq 'SCALAR' or Carp::croak('Unknown bless type: ' . $type . '. See the GT::Delay manpage');
|
||||
|
||||
my $self = bless($type eq 'HASH' ? {} : $type eq 'ARRAY' ? [] : \my $foo);
|
||||
$Delayed{$self} = [$package, $type, \@args];
|
||||
$self;
|
||||
}
|
||||
|
||||
AUTOLOAD {
|
||||
# When a method is called we create a real object, copy it into $self, and
|
||||
# rebless $self into the package. This has to be done to get around a case
|
||||
# such as: my $foo = GT::Delay(...); my $bar = $foo; $bar->meth;
|
||||
# Even changing $_[0] would not affect $foo, and if $foo was used would result
|
||||
# in _two_ of the delayed modules.
|
||||
#
|
||||
my $self = $_[0];
|
||||
my ($package, $type, $args) = @{delete $Delayed{$self}};
|
||||
|
||||
(my $module = $package) =~ s|::|/|g;
|
||||
$module .= '.pm';
|
||||
require $module;
|
||||
|
||||
my $copy = $package->new(@$args);
|
||||
|
||||
eval {
|
||||
if ($type eq 'HASH') { %$self = %$copy }
|
||||
elsif ($type eq 'ARRAY') { @$self = @$copy }
|
||||
else { $$self = $$copy }
|
||||
};
|
||||
|
||||
$@ and Carp::croak("$package type does not appear to be $type. Delayed loading failed");
|
||||
|
||||
bless $self, ref $copy;
|
||||
|
||||
my $method = substr($GT::Delay::AUTOLOAD, rindex($GT::Delay::AUTOLOAD, ':') + 1);
|
||||
if (my $subref = $self->can($method)) {
|
||||
goto &$subref;
|
||||
}
|
||||
elsif ($self->can('AUTOLOAD')) {
|
||||
shift;
|
||||
$self->$method(@_);
|
||||
}
|
||||
else {
|
||||
Carp::croak(qq|Can't locate object method "$method" via package "| . ref($self) . '"');
|
||||
}
|
||||
}
|
||||
|
||||
DESTROY {
|
||||
delete $Delayed{$_[0]} if exists $Delayed{$_[0]};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Delay - Generic delayed module loading
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Delay;
|
||||
|
||||
my $obj = GT::Delay('GT::Foo', 'HASH', foo => "bar", bar => 12);
|
||||
|
||||
... # time passes without using $obj
|
||||
|
||||
$obj->method();
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a simple way to handle delayed module loading in a fairly
|
||||
generic way. Your object will only be a very lightweight GT::Delay object
|
||||
until you call a method on it, at which point the desired module will be loaded,
|
||||
your object will be changed into an object of the desired type.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
There is only one usable function provided by this module, GT::Delay() (not
|
||||
GT::Delay::Delay as this module attempts to leave the GT::Delay namespace as
|
||||
empty as possible).
|
||||
|
||||
=head2 GT::Delay
|
||||
|
||||
GT::Delay is used to create a new delayed object. It takes at least two
|
||||
arguments. The first is the package to load, such as 'GT::Foo' to require
|
||||
GT/Foo.pm and create a new GT::Foo object. The second is the type of blessed
|
||||
data structure a 'GT::Foo' object really is. This can be one of either 'HASH',
|
||||
'ARRAY', or 'SCALAR'. Any additional arguments are kept and passed in as
|
||||
arguments to the new() method of the object when created.
|
||||
|
||||
The object type ('HASH', 'ARRAY', or 'SCALAR') is needed is to get around a
|
||||
caveat of references - if $a and $b both point to the same reference, $b cannot
|
||||
be changed from $a - which makes it impossible to just get a new object and
|
||||
replace $_[0] with that object, because although that would change one of
|
||||
either $a or $b, it wouldn't change the other and you could easily end up with
|
||||
two separate objects. When a method is called, the new object is created, then
|
||||
copied into the original object which is then reblessed into the desired
|
||||
package. This doesn't change either $a or $b, but rather changes the reference
|
||||
they point to. You have to pass the object type because the reference must be
|
||||
reblessed, but the underlying data type cannot change. Unfortunately, this
|
||||
approach has a few caveats of its own, listed below.
|
||||
|
||||
=head1 CAVEATS and LIMITATIONS
|
||||
|
||||
Modules that are created by a method other than new() are not supported.
|
||||
|
||||
Modules that use a namespace different from the module location are not
|
||||
supported. For example, a package Foo::Bar::Blah located in Foo/Bar.pm. If
|
||||
you have such a module that would benefit from delayed loading, you need to
|
||||
rethink your package/filename naming scheme, or not use this module. It _is_
|
||||
possible to do this with a hack such as:
|
||||
C<$INC{'Foo/Bar/Blah.pm'} = './Foo/Bar.pm';> - but other than for testing,
|
||||
doing such a thing is strongly discouraged.
|
||||
|
||||
Objects cannot have their elements directly accessed - for example,
|
||||
C<$obj-E<gt>{foo}>. But, since that is bad practise anyway, it isn't that much
|
||||
of a limitation. That said, objects _can_ be accessed directly _after_ any
|
||||
method has been called.
|
||||
|
||||
Modules that store a string or integer form of $self (GT::Config does this to
|
||||
store object attributes) will not work, since the working object will not be
|
||||
the same object create a new(), but rather a copy.
|
||||
|
||||
Modules with DESTROY methods that do things to references in $self (for
|
||||
example, C<delete $self-E<gt>{foo}-E<gt>{bar}> - though C<delete
|
||||
$self-E<gt>{foo}> would be safe) will most likely not work properly as the copy
|
||||
is not deep - i.e. references are copied as-is.
|
||||
|
||||
Along the same lines as the previous point, the first object will be destroyed
|
||||
before the first method call goes through, so modules that do things (e.g.
|
||||
delete files, close filehandles, etc.) in DESTROY will most likely not work.
|
||||
|
||||
Any module that doesn't fall into any of the points above will be perfectly
|
||||
well supported by this module.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Delay.pm,v 1.4 2004/01/13 01:35:15 jagerman Exp $
|
||||
|
||||
=cut
|
||||
386
site/slowtwitch.com/cgi-bin/articles/GT/Dumper.pm
Normal file
386
site/slowtwitch.com/cgi-bin/articles/GT/Dumper.pm
Normal file
@ -0,0 +1,386 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Dumper
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Dumper.pm,v 1.39 2007/02/10 15:59:02 sbeck Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements a data dumper, useful for converting complex Perl
|
||||
# data structures to strings, which can then be eval()ed back to
|
||||
# the original value.
|
||||
#
|
||||
|
||||
package GT::Dumper;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw /$DEBUG $ATTRIBS $VERSION @EXPORT @ISA $EOL/;
|
||||
use GT::Base;
|
||||
use Exporter;
|
||||
use overload;
|
||||
|
||||
$EOL = "\n";
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.39 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
var => '$VAR',
|
||||
data => undef,
|
||||
sort => 1,
|
||||
order => undef,
|
||||
compress => undef,
|
||||
structure => undef,
|
||||
tab => ' '
|
||||
};
|
||||
@EXPORT = qw/Dumper/;
|
||||
@ISA = qw/Exporter GT::Base/;
|
||||
|
||||
sub Dumper {
|
||||
# -----------------------------------------------------------
|
||||
# Dumper acts similar to Dumper in Data::Dumper when called as a
|
||||
# class method. If called as a instance method it assumes you
|
||||
# have set the options for the dump and does not change them.
|
||||
# It only takes a single argument - the variable to dump.
|
||||
#
|
||||
my $self;
|
||||
if (@_ == 2 and UNIVERSAL::isa($_[0], __PACKAGE__)) {
|
||||
$self = shift;
|
||||
$self->{data} = shift;
|
||||
}
|
||||
elsif (@_ == 1) {
|
||||
$self = GT::Dumper->new(data => shift);
|
||||
}
|
||||
else {
|
||||
die "Bad args to Dumper()";
|
||||
}
|
||||
return $self->dump;
|
||||
}
|
||||
|
||||
sub dump {
|
||||
# -----------------------------------------------------------
|
||||
# my $dump = $class->dump(%opts);
|
||||
# --------------------------------
|
||||
# Returns the data structure specified in %opts flatened.
|
||||
# %opts is optional if you have created an object with the
|
||||
# options.
|
||||
#
|
||||
my $this = shift;
|
||||
|
||||
# See if options were passed in
|
||||
my $self;
|
||||
if (!ref $this) {
|
||||
$self = $this->new(@_);
|
||||
}
|
||||
else {
|
||||
$self = $this;
|
||||
if (@_) {
|
||||
my $data = $self->common_param(@_) or return $self->fatal(BADARGS => '$dumper->dump(%opts)');
|
||||
$self->set($data);
|
||||
}
|
||||
}
|
||||
|
||||
my $level = 0;
|
||||
my $ret = '';
|
||||
if ($self->{var} and not $self->{structure}) {
|
||||
$ret .= ($self->{compress} ? "$self->{var}=" : "$self->{var} = ");
|
||||
}
|
||||
$self->_dump_value($level + 1, $self->{data}, \$ret);
|
||||
$ret .= ';' unless $self->{structure};
|
||||
$ret .= $EOL unless $self->{structure} or $self->{compress};
|
||||
|
||||
return $ret ? $ret : 1;
|
||||
}
|
||||
|
||||
sub dump_structure {
|
||||
my ($self, $data) = @_;
|
||||
return $self->dump(structure => 1, data => $data);
|
||||
}
|
||||
|
||||
sub _dump_value {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to decide what to dump.
|
||||
#
|
||||
my ($self, $level, $val, $ret, $n) = @_;
|
||||
my $was;
|
||||
my $ref = ref $val;
|
||||
if ($ref and overload::StrVal($val) =~ /=/) { $self->_dump_obj( $level + 1, $val, $ret) }
|
||||
elsif ($ref eq 'HASH') { $self->_dump_hash( $level + 1, $val, $ret) }
|
||||
elsif ($ref eq 'ARRAY') { $self->_dump_array($level + 1, $val, $ret) }
|
||||
elsif ($ref eq 'SCALAR' or $ref eq 'REF' or $ref eq 'LVALUE') {
|
||||
$self->_dump_scalar($level, $val, $ret)
|
||||
}
|
||||
elsif ($ref eq 'CODE') { $$ret .= 'sub { () }' }
|
||||
else { $$ret .= _escape($val) }
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_scalar {
|
||||
# -----------------------------------------------------------
|
||||
# Dump a scalar reference.
|
||||
#
|
||||
my ($self, $level, $val, $ret, $n) = @_;
|
||||
my $v = $$val;
|
||||
$$ret .= '\\';
|
||||
$self->_dump_value($level, $v, $ret, 1);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_hash {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to for through a hash and dump it.
|
||||
#
|
||||
my ($self, $level, $hash_ref, $ret) = @_;
|
||||
$$ret .= '{';
|
||||
my $lines;
|
||||
if ($self->{sort}) {
|
||||
for (sort { ref($self->{order}) eq 'CODE' ? $self->{order}->($a, $b, $hash_ref->{$a}, $hash_ref->{$b}) : $a cmp $b } keys %{$hash_ref}) {
|
||||
$$ret .= "," if $lines++;
|
||||
$$ret .= $EOL . ($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
my $key = _escape($_);
|
||||
$$ret .= $self->{compress} ? "$key," : "$key => ";
|
||||
$self->_dump_value($level + 1, $hash_ref->{$_}, $ret, 1);
|
||||
}
|
||||
}
|
||||
else {
|
||||
for (keys %{$hash_ref}) {
|
||||
$$ret .= "," if $lines++;
|
||||
$$ret .= $EOL . ($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
my $key = _escape($_);
|
||||
$$ret .= $self->{compress} ? "$key," : "$key => ";
|
||||
$self->_dump_value($level + 1, $hash_ref->{$_}, $ret, 1);
|
||||
}
|
||||
}
|
||||
$$ret .= $EOL if $lines and not $self->{compress};
|
||||
$$ret .= ($lines and not $self->{compress}) ? (($self->{tab} x (($level - 1) / 2)) . "}") : "}";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_array {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to for through an array and dump it.
|
||||
#
|
||||
my ($self, $level, $array_ref, $ret) = @_;
|
||||
$$ret .= "[";
|
||||
my $lines;
|
||||
for (@{$array_ref}) {
|
||||
$$ret .= "," if $lines++;
|
||||
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
$self->_dump_value($level + 1, $_, $ret, 1);
|
||||
}
|
||||
$$ret .= ($lines and not $self->{compress}) ? $EOL.(($self->{tab} x (($level - 1) / 2)) . "]") : "]";
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _dump_obj {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to dump an object.
|
||||
#
|
||||
my ($self, $level, $obj, $ret) = @_;
|
||||
my $class = ref $obj;
|
||||
$$ret .= "bless(";
|
||||
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
my $strval = overload::StrVal($obj);
|
||||
if ($strval =~ /ARRAY\(/) { $self->_dump_array($level + 2, \@{$obj}, $ret) }
|
||||
elsif ($strval =~ /HASH\(/) { $self->_dump_hash( $level + 2, \%{$obj}, $ret) }
|
||||
elsif ($strval =~ /SCALAR\(/ or $obj =~ /REF\(/ or $obj =~ /LVALUE\(/)
|
||||
{ $self->_dump_value($level + 2, $$obj, $ret) }
|
||||
$$ret .= ",";
|
||||
$$ret .= $EOL.($self->{tab} x ($level / 2)) unless $self->{compress};
|
||||
$$ret .= _escape($class);
|
||||
$$ret .= $EOL.($self->{tab} x (($level - 1) / 2)) unless $self->{compress};
|
||||
$$ret .= ")";
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
sub _escape {
|
||||
# -----------------------------------------------------------
|
||||
# Internal method to escape a dumped value.
|
||||
my ($val) = @_;
|
||||
defined($val) or return 'undef';
|
||||
$val =~ s/('|\\(?=['\\]|$))/\\$1/g;
|
||||
return "'$val'";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Dumper - Convert Perl data structures into a string.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Dumper;
|
||||
print Dumper($complex_var);
|
||||
print GT::Dumper->dump ( var => '$MYVAR', data => $complex_var);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Dumper by default exports a method Dumper() which will
|
||||
behave similar to Data::Dumper's Dumper(). It differs in that
|
||||
it will only take a single argument, and the variable dumped
|
||||
will be $VAR instead of $VAR1. Also, to provide easier control
|
||||
to change the variable name that gets dumped, you can use:
|
||||
|
||||
GT::Dumper->dump ( var => string, data => yourdata );
|
||||
|
||||
and the dump will start with string = instead of $VAR = .
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
use GT::Dumper;
|
||||
my %foo;
|
||||
my @bar = (1, 2, 3);
|
||||
$foo{alpha} = \@bar;
|
||||
$foo{beta} = 'a string';
|
||||
print Dumper(\%foo);
|
||||
|
||||
This will print:
|
||||
|
||||
$VAR = {
|
||||
'beta' => 'a string',
|
||||
'alpha' => [
|
||||
'1',
|
||||
'2',
|
||||
'3',
|
||||
],
|
||||
};
|
||||
|
||||
=head1 METHODS/FUNCTIONS
|
||||
|
||||
=head2 Dumper
|
||||
|
||||
Dumper() is exported by default when using GT::Dumper. It takes a single
|
||||
variable and returns a string representation of the variable. The string can
|
||||
then be eval()'ed back into the same data structure.
|
||||
|
||||
It takes only one argument - the variable to dump. The return is a string of
|
||||
the form:
|
||||
|
||||
$VAR = DATA
|
||||
|
||||
where 'DATA' is the actual data structure of the variable. A more powerful and
|
||||
customizable dumping method is the L</"dump"> method.
|
||||
|
||||
=head2 dump
|
||||
|
||||
dump() provides a more customizable method to dumping a data structure. Through
|
||||
the various options available, listed below, the output of a data structure
|
||||
dump can be formatted in several different ways.
|
||||
|
||||
The options are as follows. Only the L</"data"> option is required.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * data
|
||||
|
||||
The data option takes a data structure to dump. It is required.
|
||||
|
||||
=item * var
|
||||
|
||||
By default, a dump is output as an assignment to C<$VAR>. For example, dumping
|
||||
the string C<foo> would return: C<$VAR = 'foo'>. You can change and even omit
|
||||
the assignment using the C<var> option. To specify a different variable, you
|
||||
simply specify it as the value here. To have 'foo' dump as just C<'foo'>
|
||||
instead of C<$VAR = 'foo'>, specify var as an empty string, or undef.
|
||||
|
||||
=item * tab
|
||||
|
||||
When indenting for complex data structures (array refs, hash refs, etc.) an
|
||||
indent is used. By default, the indent is 4 spaces, however you can change this
|
||||
by using the C<tab> option.
|
||||
|
||||
=item * sort
|
||||
|
||||
The C<sort> option enables hash key sorting. It is not on by default - to
|
||||
enable, simply specify the sort option with 1 as the value. The default sort
|
||||
method is case-sensitive alphabetical. See the L</"order"> option for
|
||||
specifying your own sort order.
|
||||
|
||||
=item * order
|
||||
|
||||
When sorting, it is sometimes desirable to use a custom sort order rather than
|
||||
the default case-sensitive alphabetical sort. The C<order> option takes a code
|
||||
reference and enables custom sort ordering. The code reference will be passed 4
|
||||
variables. The first and second are the two items being compared - $a and $b in
|
||||
Perl's sort mechanism. The third and fourth are the values in the hash being
|
||||
sorted. The code reference, like a Perl sort routine, should return -1 if $a
|
||||
should come before $b, 0 if $a and $b are equivelant in your sort order, and 1
|
||||
if $b should come before $a. Because of scoping and package issues in Perl, it
|
||||
is not possible to directly use $a and $b.
|
||||
|
||||
=item * compress
|
||||
|
||||
The default dump method is to use ' => ' between hash key and value, to use
|
||||
indenting, and to add a line break after each dumped element. You can turn all
|
||||
of these off by using the compress option.
|
||||
|
||||
Compression removes all non-essential characters from the output, thus reducing
|
||||
data size, however also generally making the dump very difficult to read. If
|
||||
enabled, the dumping behaviour is changed as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * assignment
|
||||
|
||||
If using a var (ie. C<$VAR = DATA>), the spaces around the = will be stripped.
|
||||
The output will look like: C<$VAR=DATA>
|
||||
|
||||
=item * hash keys
|
||||
|
||||
Instead of placing the 4 characters ' => ' between hash keys and values, a
|
||||
single ',' will be used.
|
||||
|
||||
=item * tabs
|
||||
|
||||
Tabs will not be used.
|
||||
|
||||
=item * newlines
|
||||
|
||||
Normally, a newline character is added after each dumped element. Compress
|
||||
turns this off.
|
||||
|
||||
=back
|
||||
|
||||
=item * structure
|
||||
|
||||
The structure option causes the dump to be a valid perl structure rather than a
|
||||
valid perl statement. This differs in two ways - for one, the C<var> option is
|
||||
ignored - it is treated as if a blank C<var> was entered, thereby not returning
|
||||
an assignment. The other difference is that an an ordinary dump adds a
|
||||
semicolon and newline at the end of the dump, but these are not added when the
|
||||
structure option is enabled.
|
||||
|
||||
=back
|
||||
|
||||
=head2 dump_structure
|
||||
|
||||
This is a quick method to do a structure dump. It takes one argument - the data
|
||||
to dump. Calling:
|
||||
$class->dump_structure($DATA);
|
||||
is identical to calling:
|
||||
$class->dump(data => $DATA, structure => 1);
|
||||
See the L</"structure"> option.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Data::Dumper>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Dumper.pm,v 1.39 2007/02/10 15:59:02 sbeck Exp $
|
||||
|
||||
=cut
|
||||
865
site/slowtwitch.com/cgi-bin/articles/GT/File/Diff.pm
Normal file
865
site/slowtwitch.com/cgi-bin/articles/GT/File/Diff.pm
Normal file
@ -0,0 +1,865 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::File::Diff
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Diff.pm,v 1.2 2004/01/13 01:35:16 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Generic diff module.
|
||||
# This module is based entirely on Algorithm::Diff v1.15.
|
||||
#
|
||||
package GT::File::Diff;
|
||||
|
||||
use vars qw($VERSION @EXPORT_OK @ISA @EXPORT);
|
||||
use integer; # see below in _replaceNextLargerWith() for mod to make
|
||||
# if you don't use this
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw();
|
||||
@EXPORT_OK = qw(LCS diff traverse_sequences traverse_balanced sdiff);
|
||||
$VERSION = sprintf('%d.%02d', (q$Revision: 1.2 $ =~ /\d+/g));
|
||||
|
||||
# McIlroy-Hunt diff algorithm
|
||||
# Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
|
||||
# by Ned Konz, perl@bike-nomad.com
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Algorithm::Diff - Compute `intelligent' differences between two files / lists
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::File::Diff qw(diff sdiff LCS traverse_sequences
|
||||
traverse_balanced);
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2 );
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
$lcsref = LCS( \@seq1, \@seq2 );
|
||||
|
||||
$lcsref = LCS( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
@diffs = diff( \@seq1, \@seq2 );
|
||||
|
||||
@diffs = diff( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
@sdiffs = sdiff( \@seq1, \@seq2 );
|
||||
|
||||
@sdiffs = sdiff( \@seq1, \@seq2, $key_generation_function );
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback,
|
||||
DISCARD_A => $callback,
|
||||
DISCARD_B => $callback,
|
||||
} );
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback,
|
||||
DISCARD_A => $callback,
|
||||
DISCARD_B => $callback,
|
||||
},
|
||||
$key_generation_function );
|
||||
|
||||
traverse_balanced( \@seq1, \@seq2,
|
||||
{ MATCH => $callback,
|
||||
DISCARD_A => $callback,
|
||||
DISCARD_B => $callback,
|
||||
CHANGE => $callback,
|
||||
} );
|
||||
|
||||
=head1 INTRODUCTION
|
||||
|
||||
(by Mark-Jason Dominus)
|
||||
|
||||
I once read an article written by the authors of C<diff>; they said
|
||||
that they hard worked very hard on the algorithm until they found the
|
||||
right one.
|
||||
|
||||
I think what they ended up using (and I hope someone will correct me,
|
||||
because I am not very confident about this) was the `longest common
|
||||
subsequence' method. in the LCS problem, you have two sequences of
|
||||
items:
|
||||
|
||||
a b c d f g h j q z
|
||||
|
||||
a b c d e f g i j k r x y z
|
||||
|
||||
and you want to find the longest sequence of items that is present in
|
||||
both original sequences in the same order. That is, you want to find
|
||||
a new sequence I<S> which can be obtained from the first sequence by
|
||||
deleting some items, and from the secend sequence by deleting other
|
||||
items. You also want I<S> to be as long as possible. In this case
|
||||
I<S> is
|
||||
|
||||
a b c d f g j z
|
||||
|
||||
From there it's only a small step to get diff-like output:
|
||||
|
||||
e h i k q r x y
|
||||
+ - + + - + + +
|
||||
|
||||
This module solves the LCS problem. It also includes a canned
|
||||
function to generate C<diff>-like output.
|
||||
|
||||
It might seem from the example above that the LCS of two sequences is
|
||||
always pretty obvious, but that's not always the case, especially when
|
||||
the two sequences have many repeated elements. For example, consider
|
||||
|
||||
a x b y c z p d q
|
||||
a b c a x b y c z
|
||||
|
||||
A naive approach might start by matching up the C<a> and C<b> that
|
||||
appear at the beginning of each sequence, like this:
|
||||
|
||||
a x b y c z p d q
|
||||
a b c a b y c z
|
||||
|
||||
This finds the common subsequence C<a b c z>. But actually, the LCS
|
||||
is C<a x b y c z>:
|
||||
|
||||
a x b y c z p d q
|
||||
a b c a x b y c z
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
This module provides three exportable functions, which we'll deal with in
|
||||
ascending order of difficulty: C<LCS>,
|
||||
C<diff>, C<sdiff>, C<traverse_sequences>, and C<traverse_balanced>.
|
||||
|
||||
=head2 C<LCS>
|
||||
|
||||
Given references to two lists of items, LCS returns an array containing their
|
||||
longest common subsequence. In scalar context, it returns a reference to
|
||||
such a list.
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2 );
|
||||
$lcsref = LCS( \@seq1, \@seq2 );
|
||||
|
||||
C<LCS> may be passed an optional third parameter; this is a CODE
|
||||
reference to a key generation function. See L</KEY GENERATION
|
||||
FUNCTIONS>.
|
||||
|
||||
@lcs = LCS( \@seq1, \@seq2, $keyGen );
|
||||
$lcsref = LCS( \@seq1, \@seq2, $keyGen );
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation
|
||||
routine.
|
||||
|
||||
=head2 C<diff>
|
||||
|
||||
@diffs = diff( \@seq1, \@seq2 );
|
||||
$diffs_ref = diff( \@seq1, \@seq2 );
|
||||
|
||||
C<diff> computes the smallest set of additions and deletions necessary
|
||||
to turn the first sequence into the second, and returns a description
|
||||
of these changes. The description is a list of I<hunks>; each hunk
|
||||
represents a contiguous section of items which should be added,
|
||||
deleted, or replaced. The return value of C<diff> is a list of
|
||||
hunks, or, in scalar context, a reference to such a list.
|
||||
|
||||
Here is an example: The diff of the following two sequences:
|
||||
|
||||
a b c e h j l m n p
|
||||
b c d e f j k l m r s t
|
||||
|
||||
Result:
|
||||
|
||||
[
|
||||
[ [ '-', 0, 'a' ] ],
|
||||
|
||||
[ [ '+', 2, 'd' ] ],
|
||||
|
||||
[ [ '-', 4, 'h' ] ,
|
||||
[ '+', 4, 'f' ] ],
|
||||
|
||||
[ [ '+', 6, 'k' ] ],
|
||||
|
||||
[ [ '-', 8, 'n' ],
|
||||
[ '-', 9, 'p' ],
|
||||
[ '+', 9, 'r' ],
|
||||
[ '+', 10, 's' ],
|
||||
[ '+', 11, 't' ],
|
||||
]
|
||||
]
|
||||
|
||||
There are five hunks here. The first hunk says that the C<a> at
|
||||
position 0 of the first sequence should be deleted (C<->). The second
|
||||
hunk says that the C<d> at position 2 of the second sequence should
|
||||
be inserted (C<+>). The third hunk says that the C<h> at position 4
|
||||
of the first sequence should be removed and replaced with the C<f>
|
||||
from position 4 of the second sequence. The other two hunks similarly.
|
||||
|
||||
C<diff> may be passed an optional third parameter; this is a CODE
|
||||
reference to a key generation function. See L</KEY GENERATION
|
||||
FUNCTIONS>.
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation
|
||||
routine.
|
||||
|
||||
=head2 C<sdiff>
|
||||
|
||||
@sdiffs = sdiff( \@seq1, \@seq2 );
|
||||
$sdiffs_ref = sdiff( \@seq1, \@seq2 );
|
||||
|
||||
C<sdiff> computes all necessary components to show two sequences
|
||||
and their minimized differences side by side, just like the
|
||||
Unix-utility I<sdiff> does:
|
||||
|
||||
same same
|
||||
before | after
|
||||
old < -
|
||||
- > new
|
||||
|
||||
It returns a list of array refs, each pointing to an array of
|
||||
display instructions. In scalar context it returns a reference
|
||||
to such a list.
|
||||
|
||||
Display instructions consist of three elements: A modifier indicator
|
||||
(C<+>: Element added, C<->: Element removed, C<u>: Element unmodified,
|
||||
C<c>: Element changed) and the value of the old and new elements, to
|
||||
be displayed side by side.
|
||||
|
||||
An C<sdiff> of the following two sequences:
|
||||
|
||||
a b c e h j l m n p
|
||||
b c d e f j k l m r s t
|
||||
|
||||
results in
|
||||
|
||||
[ [ '-', 'a', '' ],
|
||||
[ 'u', 'b', 'b' ],
|
||||
[ 'u', 'c', 'c' ],
|
||||
[ '+', '', 'd' ],
|
||||
[ 'u', 'e', 'e' ],
|
||||
[ 'c', 'h', 'f' ],
|
||||
[ 'u', 'j', 'j' ],
|
||||
[ '+', '', 'k' ],
|
||||
[ 'u', 'l', 'l' ],
|
||||
[ 'u', 'm', 'm' ],
|
||||
[ 'c', 'n', 'r' ],
|
||||
[ 'c', 'p', 's' ],
|
||||
[ '+', '', 't' ] ]
|
||||
|
||||
C<sdiff> may be passed an optional third parameter; this is a CODE
|
||||
reference to a key generation function. See L</KEY GENERATION
|
||||
FUNCTIONS>.
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation
|
||||
routine.
|
||||
|
||||
=head2 C<traverse_sequences>
|
||||
|
||||
C<traverse_sequences> is the most general facility provided by this
|
||||
module; C<diff> and C<LCS> are implemented as calls to it.
|
||||
|
||||
Imagine that there are two arrows. Arrow A points to an element of sequence A,
|
||||
and arrow B points to an element of the sequence B. Initially, the arrows
|
||||
point to the first elements of the respective sequences. C<traverse_sequences>
|
||||
will advance the arrows through the sequences one element at a time, calling an
|
||||
appropriate user-specified callback function before each advance. It
|
||||
willadvance the arrows in such a way that if there are equal elements C<$A[$i]>
|
||||
and C<$B[$j]> which are equal and which are part of the LCS, there will be
|
||||
some moment during the execution of C<traverse_sequences> when arrow A is
|
||||
pointing to C<$A[$i]> and arrow B is pointing to C<$B[$j]>. When this happens,
|
||||
C<traverse_sequences> will call the C<MATCH> callback function and then it will
|
||||
advance both arrows.
|
||||
|
||||
Otherwise, one of the arrows is pointing to an element of its sequence that is
|
||||
not part of the LCS. C<traverse_sequences> will advance that arrow and will
|
||||
call the C<DISCARD_A> or the C<DISCARD_B> callback, depending on which arrow it
|
||||
advanced. If both arrows point to elements that are not part of the LCS, then
|
||||
C<traverse_sequences> will advance one of them and call the appropriate
|
||||
callback, but it is not specified which it will call.
|
||||
|
||||
The arguments to C<traverse_sequences> are the two sequences to traverse, and a
|
||||
hash which specifies the callback functions, like this:
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback_1,
|
||||
DISCARD_A => $callback_2,
|
||||
DISCARD_B => $callback_3,
|
||||
} );
|
||||
|
||||
Callbacks for MATCH, DISCARD_A, and DISCARD_B are invoked with at least the
|
||||
indices of the two arrows as their arguments. They are not expected to return
|
||||
any values. If a callback is omitted from the table, it is not called.
|
||||
|
||||
Callbacks for A_FINISHED and B_FINISHED are invoked with at least the
|
||||
corresponding index in A or B.
|
||||
|
||||
If arrow A reaches the end of its sequence, before arrow B does,
|
||||
C<traverse_sequences> will call the C<A_FINISHED> callback when it advances
|
||||
arrow B, if there is such a function; if not it will call C<DISCARD_B> instead.
|
||||
Similarly if arrow B finishes first. C<traverse_sequences> returns when both
|
||||
arrows are at the ends of their respective sequences. It returns true on
|
||||
success and false on failure. At present there is no way to fail.
|
||||
|
||||
C<traverse_sequences> may be passed an optional fourth parameter; this is a
|
||||
CODE reference to a key generation function. See L</KEY GENERATION FUNCTIONS>.
|
||||
|
||||
Additional parameters, if any, will be passed to the key generation function.
|
||||
|
||||
=head2 C<traverse_balanced>
|
||||
|
||||
C<traverse_balanced> is an alternative to C<traverse_sequences>. It
|
||||
uses a different algorithm to iterate through the entries in the
|
||||
computed LCS. Instead of sticking to one side and showing element changes
|
||||
as insertions and deletions only, it will jump back and forth between
|
||||
the two sequences and report I<changes> occurring as deletions on one
|
||||
side followed immediatly by an insertion on the other side.
|
||||
|
||||
In addition to the
|
||||
C<DISCARD_A>,
|
||||
C<DISCARD_B>, and
|
||||
C<MATCH>
|
||||
callbacks supported by C<traverse_sequences>, C<traverse_balanced> supports
|
||||
a C<CHANGE> callback indicating that one element got C<replaced> by another:
|
||||
|
||||
traverse_sequences( \@seq1, \@seq2,
|
||||
{ MATCH => $callback_1,
|
||||
DISCARD_A => $callback_2,
|
||||
DISCARD_B => $callback_3,
|
||||
CHANGE => $callback_4,
|
||||
} );
|
||||
|
||||
If no C<CHANGE> callback is specified, C<traverse_balanced>
|
||||
will map C<CHANGE> events to C<DISCARD_A> and C<DISCARD_B> actions,
|
||||
therefore resulting in a similar behaviour as C<traverse_sequences>
|
||||
with different order of events.
|
||||
|
||||
C<traverse_balanced> might be a bit slower than C<traverse_sequences>,
|
||||
noticable only while processing huge amounts of data.
|
||||
|
||||
The C<sdiff> function of this module
|
||||
is implemented as call to C<traverse_balanced>.
|
||||
|
||||
=head1 KEY GENERATION FUNCTIONS
|
||||
|
||||
C<diff>, C<LCS>, and C<traverse_sequences> accept an optional last parameter.
|
||||
This is a CODE reference to a key generating (hashing) function that should
|
||||
return a string that uniquely identifies a given element. It should be the
|
||||
case that if two elements are to be considered equal, their keys should be the
|
||||
same (and the other way around). If no key generation function is provided,
|
||||
the key will be the element as a string.
|
||||
|
||||
By default, comparisons will use "eq" and elements will be turned into keys
|
||||
using the default stringizing operator '""'.
|
||||
|
||||
Where this is important is when you're comparing something other than strings.
|
||||
If it is the case that you have multiple different objects that should be
|
||||
considered to be equal, you should supply a key generation function. Otherwise,
|
||||
you have to make sure that your arrays contain unique references.
|
||||
|
||||
For instance, consider this example:
|
||||
|
||||
package Person;
|
||||
|
||||
sub new
|
||||
{
|
||||
my $package = shift;
|
||||
return bless { name => '', ssn => '', @_ }, $package;
|
||||
}
|
||||
|
||||
sub clone
|
||||
{
|
||||
my $old = shift;
|
||||
my $new = bless { %$old }, ref($old);
|
||||
}
|
||||
|
||||
sub hash
|
||||
{
|
||||
return shift()->{'ssn'};
|
||||
}
|
||||
|
||||
my $person1 = Person->new( name => 'Joe', ssn => '123-45-6789' );
|
||||
my $person2 = Person->new( name => 'Mary', ssn => '123-47-0000' );
|
||||
my $person3 = Person->new( name => 'Pete', ssn => '999-45-2222' );
|
||||
my $person4 = Person->new( name => 'Peggy', ssn => '123-45-9999' );
|
||||
my $person5 = Person->new( name => 'Frank', ssn => '000-45-9999' );
|
||||
|
||||
If you did this:
|
||||
|
||||
my $array1 = [ $person1, $person2, $person4 ];
|
||||
my $array2 = [ $person1, $person3, $person4, $person5 ];
|
||||
GT::File::Diff::diff( $array1, $array2 );
|
||||
|
||||
everything would work out OK (each of the objects would be converted
|
||||
into a string like "Person=HASH(0x82425b0)" for comparison).
|
||||
|
||||
But if you did this:
|
||||
|
||||
my $array1 = [ $person1, $person2, $person4 ];
|
||||
my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
|
||||
GT::File::Diff::diff( $array1, $array2 );
|
||||
|
||||
$person4 and $person4->clone() (which have the same name and SSN)
|
||||
would be seen as different objects. If you wanted them to be considered
|
||||
equivalent, you would have to pass in a key generation function:
|
||||
|
||||
my $array1 = [ $person1, $person2, $person4 ];
|
||||
my $array2 = [ $person1, $person3, $person4->clone(), $person5 ];
|
||||
GT::File::Diff::diff( $array1, $array2, \&Person::hash );
|
||||
|
||||
This would use the 'ssn' field in each Person as a comparison key, and
|
||||
so would consider $person4 and $person4->clone() as equal.
|
||||
|
||||
You may also pass additional parameters to the key generation function
|
||||
if you wish.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This version by Ned Konz, perl@bike-nomad.com
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Copyright (c) 2000-2002 Ned Konz. All rights reserved.
|
||||
This program is free software;
|
||||
you can redistribute it and/or modify it under the same terms
|
||||
as Perl itself.
|
||||
|
||||
=head1 CREDITS
|
||||
|
||||
Versions through 0.59 (and much of this documentation) were written by:
|
||||
|
||||
Mark-Jason Dominus, mjd-perl-diff@plover.com
|
||||
|
||||
This version borrows the documentation and names of the routines
|
||||
from Mark-Jason's, but has all new code in Diff.pm.
|
||||
|
||||
This code was adapted from the Smalltalk code of
|
||||
Mario Wolczko <mario@wolczko.com>, which is available at
|
||||
ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st
|
||||
|
||||
C<sdiff> and C<traverse_balanced> were written by Mike Schilli
|
||||
<m@perlmeister.com>.
|
||||
|
||||
The algorithm is that described in
|
||||
I<A Fast Algorithm for Computing Longest Common Subsequences>,
|
||||
CACM, vol.20, no.5, pp.350-353, May 1977, with a few
|
||||
minor improvements to improve the speed.
|
||||
|
||||
=cut
|
||||
|
||||
# Create a hash that maps each element of $aCollection to the set of positions
|
||||
# it occupies in $aCollection, restricted to the elements within the range of
|
||||
# indexes specified by $start and $end.
|
||||
# The fourth parameter is a subroutine reference that will be called to
|
||||
# generate a string to use as a key.
|
||||
# Additional parameters, if any, will be passed to this subroutine.
|
||||
#
|
||||
# my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
|
||||
|
||||
sub _withPositionsOfInInterval
|
||||
{
|
||||
my $aCollection = shift; # array ref
|
||||
my $start = shift;
|
||||
my $end = shift;
|
||||
my $keyGen = shift;
|
||||
my %d;
|
||||
my $index;
|
||||
for ( $index = $start ; $index <= $end ; $index++ )
|
||||
{
|
||||
my $element = $aCollection->[$index];
|
||||
my $key = &$keyGen( $element, @_ );
|
||||
if ( exists( $d{$key} ) )
|
||||
{
|
||||
unshift ( @{ $d{$key} }, $index );
|
||||
}
|
||||
else
|
||||
{
|
||||
$d{$key} = [$index];
|
||||
}
|
||||
}
|
||||
return wantarray ? %d : \%d;
|
||||
}
|
||||
|
||||
# Find the place at which aValue would normally be inserted into the array. If
|
||||
# that place is already occupied by aValue, do nothing, and return undef. If
|
||||
# the place does not exist (i.e., it is off the end of the array), add it to
|
||||
# the end, otherwise replace the element at that point with aValue.
|
||||
# It is assumed that the array's values are numeric.
|
||||
# This is where the bulk (75%) of the time is spent in this module, so try to
|
||||
# make it fast!
|
||||
|
||||
sub _replaceNextLargerWith
|
||||
{
|
||||
my ( $array, $aValue, $high ) = @_;
|
||||
$high ||= $#$array;
|
||||
|
||||
# off the end?
|
||||
if ( $high == -1 || $aValue > $array->[-1] )
|
||||
{
|
||||
push ( @$array, $aValue );
|
||||
return $high + 1;
|
||||
}
|
||||
|
||||
# binary search for insertion point...
|
||||
my $low = 0;
|
||||
my $index;
|
||||
my $found;
|
||||
while ( $low <= $high )
|
||||
{
|
||||
$index = ( $high + $low ) / 2;
|
||||
|
||||
# $index = int(( $high + $low ) / 2); # without 'use integer'
|
||||
$found = $array->[$index];
|
||||
|
||||
if ( $aValue == $found )
|
||||
{
|
||||
return undef;
|
||||
}
|
||||
elsif ( $aValue > $found )
|
||||
{
|
||||
$low = $index + 1;
|
||||
}
|
||||
else
|
||||
{
|
||||
$high = $index - 1;
|
||||
}
|
||||
}
|
||||
|
||||
# now insertion point is in $low.
|
||||
$array->[$low] = $aValue; # overwrite next larger
|
||||
return $low;
|
||||
}
|
||||
|
||||
# This method computes the longest common subsequence in $a and $b.
|
||||
|
||||
# Result is array or ref, whose contents is such that
|
||||
# $a->[ $i ] == $b->[ $result[ $i ] ]
|
||||
# foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined.
|
||||
|
||||
# An additional argument may be passed; this is a hash or key generating
|
||||
# function that should return a string that uniquely identifies the given
|
||||
# element. It should be the case that if the key is the same, the elements
|
||||
# will compare the same. If this parameter is undef or missing, the key
|
||||
# will be the element as a string.
|
||||
|
||||
# By default, comparisons will use "eq" and elements will be turned into keys
|
||||
# using the default stringizing operator '""'.
|
||||
|
||||
# Additional parameters, if any, will be passed to the key generation routine.
|
||||
|
||||
sub _longestCommonSubsequence
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $keyGen = shift; # code ref
|
||||
my $compare; # code ref
|
||||
|
||||
# set up code refs
|
||||
# Note that these are optimized.
|
||||
if ( !defined($keyGen) ) # optimize for strings
|
||||
{
|
||||
$keyGen = sub { $_[0] };
|
||||
$compare = sub { my ( $a, $b ) = @_; $a eq $b };
|
||||
}
|
||||
else
|
||||
{
|
||||
$compare = sub {
|
||||
my $a = shift;
|
||||
my $b = shift;
|
||||
&$keyGen( $a, @_ ) eq &$keyGen( $b, @_ );
|
||||
};
|
||||
}
|
||||
|
||||
my ( $aStart, $aFinish, $bStart, $bFinish, $matchVector ) =
|
||||
( 0, $#$a, 0, $#$b, [] );
|
||||
|
||||
# First we prune off any common elements at the beginning
|
||||
while ( $aStart <= $aFinish
|
||||
and $bStart <= $bFinish
|
||||
and &$compare( $a->[$aStart], $b->[$bStart], @_ ) )
|
||||
{
|
||||
$matchVector->[ $aStart++ ] = $bStart++;
|
||||
}
|
||||
|
||||
# now the end
|
||||
while ( $aStart <= $aFinish
|
||||
and $bStart <= $bFinish
|
||||
and &$compare( $a->[$aFinish], $b->[$bFinish], @_ ) )
|
||||
{
|
||||
$matchVector->[ $aFinish-- ] = $bFinish--;
|
||||
}
|
||||
|
||||
# Now compute the equivalence classes of positions of elements
|
||||
my $bMatches =
|
||||
_withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ );
|
||||
my $thresh = [];
|
||||
my $links = [];
|
||||
|
||||
my ( $i, $ai, $j, $k );
|
||||
for ( $i = $aStart ; $i <= $aFinish ; $i++ )
|
||||
{
|
||||
$ai = &$keyGen( $a->[$i], @_ );
|
||||
if ( exists( $bMatches->{$ai} ) )
|
||||
{
|
||||
$k = 0;
|
||||
for $j ( @{ $bMatches->{$ai} } )
|
||||
{
|
||||
|
||||
# optimization: most of the time this will be true
|
||||
if ( $k and $thresh->[$k] > $j and $thresh->[ $k - 1 ] < $j )
|
||||
{
|
||||
$thresh->[$k] = $j;
|
||||
}
|
||||
else
|
||||
{
|
||||
$k = _replaceNextLargerWith( $thresh, $j, $k );
|
||||
}
|
||||
|
||||
# oddly, it's faster to always test this (CPU cache?).
|
||||
if ( defined($k) )
|
||||
{
|
||||
$links->[$k] =
|
||||
[ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (@$thresh)
|
||||
{
|
||||
for ( my $link = $links->[$#$thresh] ; $link ; $link = $link->[0] )
|
||||
{
|
||||
$matchVector->[ $link->[1] ] = $link->[2];
|
||||
}
|
||||
}
|
||||
|
||||
return wantarray ? @$matchVector : $matchVector;
|
||||
}
|
||||
|
||||
sub traverse_sequences
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $callbacks = shift || {};
|
||||
my $keyGen = shift;
|
||||
my $matchCallback = $callbacks->{'MATCH'} || sub { };
|
||||
my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
|
||||
my $finishedACallback = $callbacks->{'A_FINISHED'};
|
||||
my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
|
||||
my $finishedBCallback = $callbacks->{'B_FINISHED'};
|
||||
my $matchVector = _longestCommonSubsequence( $a, $b, $keyGen, @_ );
|
||||
|
||||
# Process all the lines in @$matchVector
|
||||
my $lastA = $#$a;
|
||||
my $lastB = $#$b;
|
||||
my $bi = 0;
|
||||
my $ai;
|
||||
|
||||
for ( $ai = 0 ; $ai <= $#$matchVector ; $ai++ )
|
||||
{
|
||||
my $bLine = $matchVector->[$ai];
|
||||
if ( defined($bLine) ) # matched
|
||||
{
|
||||
&$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine;
|
||||
&$matchCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai, $bi, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
# The last entry (if any) processed was a match.
|
||||
# $ai and $bi point just past the last matching lines in their sequences.
|
||||
|
||||
while ( $ai <= $lastA or $bi <= $lastB )
|
||||
{
|
||||
|
||||
# last A?
|
||||
if ( $ai == $lastA + 1 and $bi <= $lastB )
|
||||
{
|
||||
if ( defined($finishedACallback) )
|
||||
{
|
||||
&$finishedACallback( $lastA, @_ );
|
||||
$finishedACallback = undef;
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardBCallback( $ai, $bi++, @_ ) while $bi <= $lastB;
|
||||
}
|
||||
}
|
||||
|
||||
# last B?
|
||||
if ( $bi == $lastB + 1 and $ai <= $lastA )
|
||||
{
|
||||
if ( defined($finishedBCallback) )
|
||||
{
|
||||
&$finishedBCallback( $lastB, @_ );
|
||||
$finishedBCallback = undef;
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ ) while $ai <= $lastA;
|
||||
}
|
||||
}
|
||||
|
||||
&$discardACallback( $ai++, $bi, @_ ) if $ai <= $lastA;
|
||||
&$discardBCallback( $ai, $bi++, @_ ) if $bi <= $lastB;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub traverse_balanced
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $callbacks = shift || {};
|
||||
my $keyGen = shift;
|
||||
my $matchCallback = $callbacks->{'MATCH'} || sub { };
|
||||
my $discardACallback = $callbacks->{'DISCARD_A'} || sub { };
|
||||
my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { };
|
||||
my $changeCallback = $callbacks->{'CHANGE'};
|
||||
my $matchVector = _longestCommonSubsequence( $a, $b, $keyGen, @_ );
|
||||
|
||||
# Process all the lines in match vector
|
||||
my $lastA = $#$a;
|
||||
my $lastB = $#$b;
|
||||
my $bi = 0;
|
||||
my $ai = 0;
|
||||
my $ma = -1;
|
||||
my $mb;
|
||||
|
||||
while (1)
|
||||
{
|
||||
|
||||
# Find next match indices $ma and $mb
|
||||
do { $ma++ } while ( $ma <= $#$matchVector && !defined $matchVector->[$ma] );
|
||||
|
||||
last if $ma > $#$matchVector; # end of matchVector?
|
||||
$mb = $matchVector->[$ma];
|
||||
|
||||
# Proceed with discard a/b or change events until
|
||||
# next match
|
||||
while ( $ai < $ma || $bi < $mb )
|
||||
{
|
||||
|
||||
if ( $ai < $ma && $bi < $mb )
|
||||
{
|
||||
|
||||
# Change
|
||||
if ( defined $changeCallback )
|
||||
{
|
||||
&$changeCallback( $ai++, $bi++, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
elsif ( $ai < $ma )
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
|
||||
# $bi < $mb
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
# Match
|
||||
&$matchCallback( $ai++, $bi++, @_ );
|
||||
}
|
||||
|
||||
while ( $ai <= $lastA || $bi <= $lastB )
|
||||
{
|
||||
if ( $ai <= $lastA && $bi <= $lastB )
|
||||
{
|
||||
|
||||
# Change
|
||||
if ( defined $changeCallback )
|
||||
{
|
||||
&$changeCallback( $ai++, $bi++, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
elsif ( $ai <= $lastA )
|
||||
{
|
||||
&$discardACallback( $ai++, $bi, @_ );
|
||||
}
|
||||
else
|
||||
{
|
||||
|
||||
# $bi <= $lastB
|
||||
&$discardBCallback( $ai, $bi++, @_ );
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub LCS
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $matchVector = _longestCommonSubsequence( $a, @_ );
|
||||
my @retval;
|
||||
my $i;
|
||||
for ( $i = 0 ; $i <= $#$matchVector ; $i++ )
|
||||
{
|
||||
if ( defined( $matchVector->[$i] ) )
|
||||
{
|
||||
push ( @retval, $a->[$i] );
|
||||
}
|
||||
}
|
||||
return wantarray ? @retval : \@retval;
|
||||
}
|
||||
|
||||
sub diff
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $retval = [];
|
||||
my $hunk = [];
|
||||
my $discard = sub { push ( @$hunk, [ '-', $_[0], $a->[ $_[0] ] ] ) };
|
||||
my $add = sub { push ( @$hunk, [ '+', $_[1], $b->[ $_[1] ] ] ) };
|
||||
my $match = sub { push ( @$retval, $hunk ) if scalar(@$hunk); $hunk = [] };
|
||||
traverse_sequences( $a, $b,
|
||||
{ MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ );
|
||||
&$match();
|
||||
return wantarray ? @$retval : $retval;
|
||||
}
|
||||
|
||||
sub sdiff
|
||||
{
|
||||
my $a = shift; # array ref
|
||||
my $b = shift; # array ref
|
||||
my $retval = [];
|
||||
my $discard = sub { push ( @$retval, [ '-', $a->[ $_[0] ], "" ] ) };
|
||||
my $add = sub { push ( @$retval, [ '+', "", $b->[ $_[1] ] ] ) };
|
||||
my $change = sub {
|
||||
push ( @$retval, [ 'c', $a->[ $_[0] ], $b->[ $_[1] ] ] );
|
||||
};
|
||||
my $match = sub {
|
||||
push ( @$retval, [ 'u', $a->[ $_[0] ], $b->[ $_[1] ] ] );
|
||||
};
|
||||
traverse_balanced(
|
||||
$a,
|
||||
$b,
|
||||
{
|
||||
MATCH => $match,
|
||||
DISCARD_A => $discard,
|
||||
DISCARD_B => $add,
|
||||
CHANGE => $change,
|
||||
},
|
||||
@_
|
||||
);
|
||||
return wantarray ? @$retval : $retval;
|
||||
}
|
||||
|
||||
1;
|
||||
1507
site/slowtwitch.com/cgi-bin/articles/GT/File/Tools.pm
Normal file
1507
site/slowtwitch.com/cgi-bin/articles/GT/File/Tools.pm
Normal file
File diff suppressed because it is too large
Load Diff
564
site/slowtwitch.com/cgi-bin/articles/GT/FileMan.pm
Normal file
564
site/slowtwitch.com/cgi-bin/articles/GT/FileMan.pm
Normal file
@ -0,0 +1,564 @@
|
||||
# ==================================================================
|
||||
# File manager - enhanced web based file management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# Revision : $Id: FileMan.pm,v 1.160 2008/11/21 21:01:09 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
package GT::FileMan;
|
||||
|
||||
use strict;
|
||||
use vars qw/$MSWIN $DEBUG $HAVE_GZIP $HAVE_AZIP $LANGUAGE $LANG_TPL/;
|
||||
use GT::Base qw/:persist/;
|
||||
use GT::Template;
|
||||
use GT::File::Tools qw/:all/;
|
||||
use GT::FileMan::Session;
|
||||
use GT::FileMan::Commands;
|
||||
use GT::MD5;
|
||||
use GT::Config;
|
||||
|
||||
$DEBUG = 0;
|
||||
|
||||
our @ISA = qw/GT::FileMan::Commands GT::FileMan::Session GT::Base/;
|
||||
|
||||
# Check if Compress::Zlib and Archive::Zip are available
|
||||
$HAVE_GZIP = eval { local $SIG{__DIE__}; require Compress::Zlib; 1; } ? 1 : 0;
|
||||
$HAVE_AZIP = eval { local $SIG{__DIE__}; require Archive::Zip; 1; } ? 1 : 0;
|
||||
|
||||
$MSWIN = $^O =~ /mswin/i ? 1 : 0;
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
|
||||
my $self = bless {%args}, ref $class || $class;
|
||||
|
||||
# Upload progress
|
||||
$self->{in} = GT::CGI->new();
|
||||
|
||||
unless ($self->{cfg}) {
|
||||
$self->{cfg} = $self->load_config();
|
||||
}
|
||||
# This applies for GT products version
|
||||
else {
|
||||
$self->{cfg}{template} ||= 'luna';
|
||||
$self->{cfg}{template_path} ||= $self->{cfg}{template_root};
|
||||
$self->{cfg}{root_path} ||= $self->{cfg}{root_dir};
|
||||
$self->{cfg}{tmp_path} ||= '/tmp';
|
||||
$self->{cfg}{static_url} ||= $self->{cfg}{html_root_url} . '/static';
|
||||
$self->{cfg}{cgi_url} ||= $self->{in}->url(absolute => 0, query_string => 0);
|
||||
$self->{cfg}{command_timeout} ||= $self->{cfg}{command_time_out};
|
||||
$self->{cfg}{path_to_perl} ||= '/usr/bin/perl';
|
||||
$self->{cfg}{default} ||= { allowed_space => 0, upload_mode => '644' };
|
||||
$self->{cfg}{date} = { display => '%dd%-%mmm%-%yy% %hh%:%MM%:%ss%', input => '%yyyy%-%mm%-%dd%' };
|
||||
}
|
||||
|
||||
# Set tmp_path and verify to see if it's writeable
|
||||
$self->{cfg}{tmp_path} ||= '/tmp';
|
||||
die "$self->{cfg}{tmp_path} is not writeable" unless -w $self->{cfg}{tmp_path};
|
||||
|
||||
my $query_string = $ENV{QUERY_STRING};
|
||||
if ($query_string =~ /^serial=/) {
|
||||
my ($read_file, $read_size) = ('', 0);
|
||||
my $uploaded_size = 0;
|
||||
my $started_time = time;
|
||||
my $total_size = $ENV{CONTENT_LENGTH};
|
||||
my ($serial) = $query_string =~ /\=([^=]+)$/;
|
||||
$serial =~ m|^(\w+\d*)$|i or die "Invalid serial: $serial";
|
||||
$self->{serial} = $serial;
|
||||
$self->{in}->upload_hook(
|
||||
sub {
|
||||
my ($filename, $buffer, $bytes) = @_;
|
||||
|
||||
my $new_progress;
|
||||
if ($read_file ne $filename) {
|
||||
$read_file = $filename;
|
||||
$read_size = $uploaded_size;
|
||||
}
|
||||
if ($read_size) {
|
||||
$new_progress = $read_size + $bytes;
|
||||
}
|
||||
else {
|
||||
my $old_progress = $uploaded_size;
|
||||
$new_progress = $bytes >= $old_progress ? $bytes : $old_progress;
|
||||
}
|
||||
$uploaded_size = $new_progress;
|
||||
|
||||
my $time = time;
|
||||
my $max_length = 50;
|
||||
$filename = substr($filename, 0, $max_length) if length($filename) > $max_length;
|
||||
|
||||
open FILE, "> $self->{cfg}{tmp_path}/$serial";
|
||||
flock FILE, 1;
|
||||
print FILE "$new_progress:|:$total_size:|:$started_time:|:$time:|:$filename:|:$self->{diskspace}{allowed}:|:$self->{diskspace}{free}\n"; # print the
|
||||
close FILE;
|
||||
|
||||
# select undef, undef, undef, 0.50;
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
$self->{cgi} = $self->{in}->get_hash();
|
||||
$DEBUG = $self->{cfg}{debug};
|
||||
|
||||
# Load access paths
|
||||
$self->{cfg}{template_path} or die('You must pass in your template root !');
|
||||
$self->{cfg}{root_path} or die('You must set your root dir !');
|
||||
|
||||
$self->{default} = $self->default();
|
||||
|
||||
# Cleanup the tmp directory
|
||||
$self->cleanup();
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub process {
|
||||
my $self = shift;
|
||||
|
||||
my $action = $self->{cgi}{cmd} || 'home';
|
||||
|
||||
# Avoid same name as GT::File::Tools::move/copy
|
||||
my $command = $action =~ /^(?:copy|move|print)$/ ? "cmd$action" : $action;
|
||||
|
||||
# Load authentication info
|
||||
if ($self->{cfg}{login}) {
|
||||
$self->auth();
|
||||
unless ($self->{session}) {
|
||||
return $self->{cgi}{ajax} ? $self->print_json({ html => $self->print('login.html', { json => 1, error => $self->language('ERR_NOAUTH') }) }, 1, undef, 'ERR_NOAUTH') : $self->login();
|
||||
}
|
||||
}
|
||||
|
||||
$self->{diskspace} = $self->check_space($self->{cfg}{root_path}, $self->{cfg}{allowed_space});
|
||||
|
||||
# Verify action to see if it's permitted
|
||||
return $self->home(error => $self->language('ERR_POST_REQUEST', $action)) unless $self->verify_request($action);
|
||||
return $self->home(error => $self->language('ERR_INVALID_ACTION', $action)) unless exists $GT::FileMan::Commands::COMPILE{$command};
|
||||
return $self->home(error => $self->language('ERR_NO_PERM', $action)) unless $self->check_action($action);
|
||||
|
||||
# Checking free space
|
||||
$self->{diskspace} = $self->check_space(($self->{cfg}{root_path}), $self->{cfg}{allowed_space});
|
||||
$self->$command();
|
||||
}
|
||||
|
||||
sub verify_request {
|
||||
my ($self, $action) = @_;
|
||||
|
||||
return 1 if lc $ENV{REQUEST_METHOD} eq 'post' or $action =~ /^(?:home|print|fdownload|preview)$/;
|
||||
return 1 if $action =~ /^(?:command|upload)$/ and $self->{cgi}{serial} and -e "$self->{cfg}{tmp_path}/$self->{cgi}{serial}";
|
||||
return;
|
||||
}
|
||||
|
||||
sub auth {
|
||||
my $self = shift;
|
||||
|
||||
$self->{session} = $self->session_valid();
|
||||
return unless $self->{session};
|
||||
|
||||
$self->{session}{user} = { username => $self->{cfg}{login}{username}, permission => $self->{cfg}{permission} };
|
||||
}
|
||||
|
||||
sub print {
|
||||
my ($self, $page, $args) = @_;
|
||||
|
||||
$page = 'home.html' if !$page or $page !~ /^[\w\-]+\.\w+$/;
|
||||
|
||||
my $template = $self->{cgi}{t} ? $self->{cgi}{t} : $self->{cfg}{template};
|
||||
$template = 'luna' if $template !~ /^[\w-]+$/;
|
||||
|
||||
my $fullpath = "$self->{cfg}{template_path}/$template/$page";
|
||||
|
||||
# Untaint the path
|
||||
($fullpath) = $fullpath =~ /^(.*)$/;
|
||||
|
||||
my $globals = $self->globals();
|
||||
my %browser = $self->{in}->browser_info;
|
||||
|
||||
$args->{have_gzip} = $HAVE_GZIP;
|
||||
$args->{have_azip} = $HAVE_AZIP;
|
||||
$args->{browser} = \%browser;
|
||||
$args->{apache_server} = 1 if $ENV{SERVER_SOFTWARE} =~ /apache/i;
|
||||
$args->{mswin} = $MSWIN;
|
||||
$args->{noauth} = 1 unless $self->{cfg}{login} or $self->{cfg}{fversion} eq 'multiple';
|
||||
|
||||
my $form = GT::Template->parse($fullpath, { %$globals, %$args }, { escape => 1 });
|
||||
return $form if $args->{json};
|
||||
|
||||
print $self->{in}->header;
|
||||
print $form;
|
||||
}
|
||||
|
||||
sub print_json_error {
|
||||
# --------------------------------------------------
|
||||
# shorthand to send an error message in json
|
||||
#
|
||||
# * If the first parameter is a hash, we assume it's a data
|
||||
# and the second parameter is the error message
|
||||
#
|
||||
# * If it's a scalar, we assume that it's the error message.
|
||||
#
|
||||
my $self = shift;
|
||||
my $data = ref $_[0] eq 'HASH' ? shift : {};
|
||||
my $message = shift;
|
||||
my $status = shift;
|
||||
return $self->print_json($data, 0, $message, $status);
|
||||
}
|
||||
|
||||
sub print_json {
|
||||
# --------------------------------------------------
|
||||
# Dumps the passed data object to STDOUT
|
||||
# by default, we assume that the request was a
|
||||
# success. If not, status should be set to "fail"
|
||||
#
|
||||
my ($self, $data, $success, $message, $status) = @_;
|
||||
|
||||
require GT::JSON;
|
||||
# If success is defined, pass it through
|
||||
if (defined $success) {
|
||||
$success = $success ? $GT::JSON::true : $GT::JSON::false;
|
||||
}
|
||||
|
||||
# Otherwise, lets just default the success status to true
|
||||
else {
|
||||
$success = $GT::JSON::true;
|
||||
}
|
||||
|
||||
# If there are any special messages
|
||||
$message ||= '';
|
||||
|
||||
my $json_str = GT::JSON::to_json({
|
||||
message => $message,
|
||||
success => $success,
|
||||
status => $status,
|
||||
data => ( $data || {} ),
|
||||
}, { utf8 => 0 });
|
||||
|
||||
print $self->{in}->header({ 'no-cache' => 1 });
|
||||
print $json_str;
|
||||
}
|
||||
|
||||
sub load_config {
|
||||
# Load the config file into a hash.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $self->{cfg_path} || 'fileman.conf';
|
||||
|
||||
my $header = <<END_OF_CONFIG;
|
||||
# ==================================================================
|
||||
# Gossamer FileMan - enhanced web based file management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/support/
|
||||
# Updated : [localtime]
|
||||
#
|
||||
# Copyright (c) 2007 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
END_OF_CONFIG
|
||||
|
||||
# Load configuration, create $IN and $DB object
|
||||
my $cfg = GT::Config->load($file, { inheritance => 0, cache => 1, header => $header });
|
||||
$cfg->{template_path} = "$cfg->{private_path}/templates";
|
||||
|
||||
$cfg->{date} ||= { display => '%dd%-%mmm%-%yy% %hh%:%MM%:%ss%', input => '%yyyy%-%mm%-%dd%' };
|
||||
$cfg->{default} ||= { allowed_space => 0, upload_mode => '644' };
|
||||
$cfg->{tmp_path} ||= '/tmp';
|
||||
$cfg->{filename_check} = 0 if $MSWIN;
|
||||
|
||||
|
||||
# Create tmp directory if it doesn't exist
|
||||
rmkdir($cfg->{tmp_path}, 0755) unless -e $cfg->{tmp_path};
|
||||
|
||||
return $cfg;
|
||||
}
|
||||
|
||||
sub default {
|
||||
# Load the default values from cookie
|
||||
#
|
||||
my ($self, %default) = @_;
|
||||
|
||||
# Loading defaults from fileman_defaults cookie
|
||||
unless (%default) {
|
||||
my $defaults = $self->{in}->cookie('fileman_defaults');
|
||||
my @defaults = split(/;/, $defaults);
|
||||
foreach my $d (@defaults) {
|
||||
if ($d =~ /^(\w+)=(.*\/?\w+)/) {
|
||||
$default{$1} = $2;
|
||||
}
|
||||
}
|
||||
}
|
||||
return \%default unless $self->{cfg}{root_path};
|
||||
|
||||
if ($default{pwd_path} and $default{pwd_path} !~ /^$self->{cfg}{root_path}/) {
|
||||
$default{pwd_path} = '' ;
|
||||
}
|
||||
elsif ($default{pwd_path}) {
|
||||
$default{pwd_path} =~ s/^$self->{cfg}{root_path}//;
|
||||
}
|
||||
|
||||
if ($default{path} and $default{path} !~ /^$self->{cfg}{root_path}/) {
|
||||
$default{path} = '';
|
||||
}
|
||||
elsif ($default{path}) {
|
||||
$default{path} =~ s/^$self->{cfg}{root_path}//;
|
||||
}
|
||||
|
||||
$default{readme} ||= 2;
|
||||
$self->{cfg}{work_path} = $self->{cgi}{work_path} eq '/' ? '' : $self->{cgi}{work_path};
|
||||
|
||||
if ($default{path} and $self->{cgi}{load_default} and !$self->{cfg}{work_path}) {
|
||||
$self->{cfg}{work_path} = $default{path};
|
||||
}
|
||||
|
||||
return \%default;
|
||||
}
|
||||
|
||||
sub cleanup {
|
||||
# Clean up xx hour old files in the tmp directory
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
return unless -e $self->{cfg}{tmp_path};
|
||||
|
||||
opendir (DIR, $self->{cfg}{tmp_path}) or return;
|
||||
my @files = readdir(DIR);
|
||||
close DIR;
|
||||
my $expiry = $self->{session}{expiry} || 5;
|
||||
foreach my $f (@files) {
|
||||
next if $f eq '.' or $f eq '..' or !-f "$self->{cfg}{tmp_file}/$f";
|
||||
my @stat = stat("$self->{cfg}{tmp_file}/$f");
|
||||
next if time - $stat[9] < 3600 * $expiry;
|
||||
del("$self->{cfg}{tmp_file}/$f", { untaint => 1 });
|
||||
}
|
||||
}
|
||||
|
||||
sub language {
|
||||
# ------------------------------------------------------------------
|
||||
# Process a language request, it's only loaded once, and saved in
|
||||
# $LANGUAGE.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = shift;
|
||||
|
||||
require GT::Config;
|
||||
my $lang = "$self->{cfg}{template_path}/$self->{cfg}{template}/language.txt";
|
||||
$LANGUAGE = undef unless $LANG_TPL;
|
||||
$LANGUAGE ||= GT::Config->load($lang, { create_ok => 1, inheritance => 1, local => 1, header => <<HEADER });
|
||||
# This file is auto generated and contains a perl hash of
|
||||
# your language variables for the '$self->{cfg}{template}' template set.
|
||||
# Generated on: [localtime]
|
||||
|
||||
HEADER
|
||||
$LANG_TPL = $self->{cfg}{template};
|
||||
|
||||
if (exists $LANGUAGE->{$code}) {
|
||||
return @_ ? sprintf($LANGUAGE->{$code}, @_) : $LANGUAGE->{$code};
|
||||
}
|
||||
else {
|
||||
return $code;
|
||||
}
|
||||
}
|
||||
|
||||
sub fatal {
|
||||
# Return a fatal error message to the browser.
|
||||
#
|
||||
die @_ if (GT::Base->in_eval()); # Don't do anything if we are in eval.
|
||||
|
||||
my $in = new GT::CGI;
|
||||
my $msg = $in->html_escape(shift);
|
||||
my $font = "Tahoma,Arial,Helvetica";
|
||||
|
||||
print $in->header;
|
||||
print qq!
|
||||
<font face="$font" size="2">A fatal error has occurred:<blockquote><pre style="font-family: $font; font-size: 12px; color: red>">$msg</pre></blockquote>Please enable debugging in setup for more details.</font>\n
|
||||
!;
|
||||
print base_env($in) if $DEBUG;
|
||||
}
|
||||
|
||||
sub base_env {
|
||||
my ($in, $version, $commands) = @_;
|
||||
|
||||
my $info = '<pre>';
|
||||
my ($oserr, $evalerr) = ($@, $!);
|
||||
|
||||
# Stack trace.
|
||||
$info .= "<b>Stack Trace</b>\n======================================\n";
|
||||
$info .= GT::Base::stack_trace('FileMan', 1);
|
||||
$info .= "\n";
|
||||
|
||||
# Print GT::SQL error if it exists.
|
||||
$info .= "<b>System Information</b>\n======================================\n";
|
||||
if (my @user = eval { getpwuid($>) }) {
|
||||
$info .= "Current user: $user[0] ($>)\n";
|
||||
}
|
||||
$info .= "Perl version: " . ($^V ? sprintf("%vd", $^V) : $]) . "\n";
|
||||
$info .= "Gossamer FileMan Version: $version\n" if $version;
|
||||
$info .= "GT::Template version: $GT::Template::VERSION\n" if $GT::Template::VERSION;
|
||||
$info .= "Running under mod_perl: " . (MOD_PERL ? "Yes (version " . MOD_PERL . ")" . (MOD_PERL >= 1.99 ? ', mod_perl 2 detected' : '') : "No") . "\n";
|
||||
$info .= "Running under SpeedyCGI: " . (SPEEDY ? "Yes (version " . SPEEDY . ")" : "No") . "\n";
|
||||
$info .= "\@INC = \n\t" . join("\n\t", @INC) . "\n";
|
||||
$info .= "\$\@: " . $in->html_escape($oserr) . "\n" if $oserr;
|
||||
$info .= "\$!: " . $in->html_escape($evalerr) . "\n" if $evalerr;
|
||||
$info .= "\n";
|
||||
|
||||
if ($commands) {
|
||||
$info .= 'Commands: <table>';
|
||||
foreach (keys %$commands) {
|
||||
$info .= qq|<tr><td class="text">$_:</td><td class="text">| . ($commands->{$_} ? 'Enabled' : 'Disabled') . qq|</td></tr>|;
|
||||
}
|
||||
$info .= '</table><br />';
|
||||
$info .= "\n";
|
||||
}
|
||||
|
||||
# CGI Parameters and Cookies.
|
||||
if (ref $in eq 'GT::CGI') {
|
||||
if ($in->param) {
|
||||
$info .= "<b>CGI Input</b>\n======================================\n";
|
||||
foreach (sort $in->param) {
|
||||
$info .= $in->html_escape($_) . " => " . $in->html_escape($in->param($_)) . "\n";
|
||||
}
|
||||
$info .= "\n";
|
||||
}
|
||||
if ($in->cookie) {
|
||||
$info .= "<b>CGI Cookies</b>\n======================================\n";
|
||||
foreach (sort $in->cookie) {
|
||||
$info .= $in->html_escape($_) . " => " . $in->html_escape($in->cookie($_)) . "\n";
|
||||
}
|
||||
$info .= "\n";
|
||||
}
|
||||
}
|
||||
|
||||
# Environement info.
|
||||
$info .= "<b>Environment</b>\n======================================\n";
|
||||
foreach (sort keys %ENV) {
|
||||
$info .= $in->html_escape($_) . " => " . $in->html_escape($ENV{$_}) . "\n";
|
||||
}
|
||||
|
||||
$info .= "</pre>";
|
||||
return $info;
|
||||
}
|
||||
|
||||
sub globals {
|
||||
my $self = shift;
|
||||
|
||||
# Create css and js url
|
||||
$self->{cfg}{template} = $self->{cgi}{t} if $self->{cgi}{t};
|
||||
my $date_input = $self->{cfg}{date}{input};
|
||||
$date_input =~ s/%//g;
|
||||
$self->{cfg}{date_input} = $date_input;
|
||||
|
||||
my %g = (cfg => $self->{cfg}, in => $self->{cgi}, default => $self->{default}, session => $self->{session});
|
||||
|
||||
my $hiddens = $self->hiddens();
|
||||
foreach (keys %$hiddens) {
|
||||
$g{$_} = \$hiddens->{$_};
|
||||
}
|
||||
|
||||
# Reload user's diskspace. This applies for multiple users version only
|
||||
if ($self->{cfg}{fversion} eq 'multiple' and !$self->{session}{user}{type}) {
|
||||
my @paths = map $_->{name}, @{$self->{session}{user}{accesses_loop}};
|
||||
$self->{diskspace} = $self->check_space(\@paths, $self->{session}{user}{allowed_space}); # Load free space
|
||||
$g{space} = $self->{diskspace};
|
||||
}
|
||||
|
||||
\%g;
|
||||
}
|
||||
|
||||
sub hiddens {
|
||||
my ($self, $no_workpath) = @_;
|
||||
|
||||
my @items = qw/sid t/;
|
||||
|
||||
my ($query, $html) = ('', '');
|
||||
foreach (@items) {
|
||||
next unless $self->{cgi}{$_};
|
||||
$query .= ";" . $self->{in}->escape($_) . "=" . $self->{in}->escape($self->{cgi}{$_}) if exists $self->{cgi}{$_};
|
||||
$html .= qq|<input type="hidden" name="| . $self->{in}->html_escape($_) . qq|" value="| . $self->{in}->html_escape($self->{cgi}{$_}) . qq|" />|;
|
||||
}
|
||||
|
||||
if ($self->{url_opts}) {
|
||||
my @opts = split(/;|&/, $self->{url_opts});
|
||||
foreach (@opts) {
|
||||
if ($_ =~ /^(\w+)=(.*\/?\w+)/) {
|
||||
$query .= ";$1=$2";
|
||||
$html .= qq|<input type="hidden" name="$1" value="| . $self->{in}->html_escape($2) . qq|" />|;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $subquery = $query;
|
||||
unless ($no_workpath) {
|
||||
$query .= ";work_path=" . $self->{in}->escape($self->{cfg}{work_path}) if $self->{cfg}{work_path};
|
||||
$html .= qq|<input type="hidden" name="work_path" value="| . $self->{in}->html_escape($self->{cfg}{work_path}) . qq|" />|;
|
||||
}
|
||||
|
||||
return { hidden_query => $query, hidden_subquery => $subquery, hidden_objects => $html };
|
||||
}
|
||||
|
||||
sub check_space {
|
||||
my ($self, $path, $allowed_space) = @_;
|
||||
|
||||
return undef unless $allowed_space and $path;
|
||||
|
||||
my @paths = ref $path eq 'ARRAY' ? @$path : [$path];
|
||||
|
||||
my ($used_space, $free_space, $usage) = (0, 0, 0);
|
||||
foreach my $p (@paths) {
|
||||
find($p, sub { $used_space += -s shift }, { untaint => 1 } );
|
||||
}
|
||||
|
||||
# Size in kb
|
||||
$used_space /= 1024;
|
||||
$free_space = $allowed_space < $used_space ? 0 : $allowed_space - $used_space;
|
||||
$usage = $used_space / $allowed_space * 100 if $allowed_space > 0;
|
||||
return {
|
||||
free => int($free_space * 1024),
|
||||
allowed => int($allowed_space * 1024),
|
||||
used => int($used_space * 1024),
|
||||
usage => int($usage)
|
||||
};
|
||||
}
|
||||
|
||||
sub image_url {
|
||||
# Takes an filename and using the current template set and theme, returns
|
||||
# the url of the image. It first checks if the file exists in the theme's
|
||||
# image directory, checks the template's image directory, and then tries
|
||||
# to check the template inheritance tree for more image directories.
|
||||
#
|
||||
my $image = shift;
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
if (-e "$tags->{cfg}{static_path}/$tags->{cfg}{template}/images/$image") {
|
||||
return "$tags->{cfg}{static_url}/$tags->{cfg}{template}/images/$image";
|
||||
}
|
||||
|
||||
# The image doesn't exist here, but return it anyway
|
||||
return "$tags->{cfg}{static_url}/$tags->{cfg}{template}/images/$image";
|
||||
}
|
||||
|
||||
sub encrypt {
|
||||
#--------------------------------------------------------------------
|
||||
# Encrypt password
|
||||
#
|
||||
my ($clear_pass, $salt) = @_;
|
||||
$salt ||= join '', map +('a' .. 'z', 'A' .. 'Z', 0 .. 9, '.', '/')[rand 64], 1 .. 8;
|
||||
|
||||
require GT::MD5::Crypt;
|
||||
return GT::MD5::Crypt::gt_md5_crypt($clear_pass, $salt);
|
||||
}
|
||||
|
||||
sub check_action {
|
||||
my ($self, $action) = @_;
|
||||
|
||||
my $perm = $self->{cfg}{fversion} eq 'multiple' ? $self->{session}{user}{permission} : $self->{cfg}{permission};
|
||||
return exists $perm->{$action} ? $perm->{$action} : 1;
|
||||
}
|
||||
1;
|
||||
2383
site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Commands.pm
Normal file
2383
site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Commands.pm
Normal file
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,145 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::FileMan::Commands::Language
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,068,085,094,083
|
||||
# $Id: Language.pm,v 1.4 2006/02/11 04:54:51 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Language variables for GT::FileMan::Commands
|
||||
#
|
||||
|
||||
package GT::FileMan::Commands::Language;
|
||||
use strict;
|
||||
use Exporter();
|
||||
use vars qw/@EXPORT @ISA %LANGUAGE/;
|
||||
@EXPORT = qw/%LANGUAGE/;
|
||||
@ISA = qw/Exporter/;
|
||||
|
||||
my $download_suffix = '<b>%s</b> (%s bytes) - </font><a href=\"javascript:top.js_download(\\\'%s\\\')\">Download</a>';
|
||||
|
||||
%LANGUAGE = (
|
||||
UPLOAD_MODE => "<font color=green>File <b>%s</b> was successfully uploaded in <b>%s</b> mode.</font>",
|
||||
MSG_LOG_OFF => "<font color=green>Please enter username and password to login.</font>",
|
||||
MSG_MULTI_UPLOAD => "<font color=green><b>%s</b> files have been successfully uploaded.</font>",
|
||||
MSG_CHMOD_CHANGED => "<font color=green>Permissions on <b>%s</b> file(s) have been updated successfully.</font>",
|
||||
MSG_SEACH_FOUND => "<font color=green>Your search found <b>%s</b> results.</font>",
|
||||
MSG_REPLA_FOUND => "<font color=green>Your search and replace updated <b>%s</b> files in %s</font>",
|
||||
MSG_SEACH_NOTFOUND => "<font color=red>Your search did not produce any results.</font>",
|
||||
MSG_FILE_EDITING => "<font color=green>Editing $download_suffix",
|
||||
MSG_FILE_VIEWING => "<font color=green>Viewing $download_suffix",
|
||||
MSG_FILE_CONTENTS => "<font color=green>Viewing contents of $download_suffix",
|
||||
MSG_FILE_CREATED => "<font color=green><b>%s</b> has been created.</font>",
|
||||
MSG_FILE_EDITED => "<font color=green>Changes to <b>%s</b> have been saved.</font>",
|
||||
MSG_DIR_CREATED => "<font color=green><b>%s</b> directory has been created.</font>",
|
||||
MSG_PREFERENCES => "<font color=green>Your options have been saved.</font>",
|
||||
MSG_UNCOMPRESS => "<font color=green><b>%s</b> file has been unarchived.</font>",
|
||||
MSG_TAR_CANCEL => "<font color=red>Creation of tar file has been cancelled.</font>",
|
||||
MSG_TAR_CREATED => "<font color=green>Tar file <b>%s</b> has been created.</font>",
|
||||
MSG_COPIED => "<font color=green> %s selected file/directory(s) have been copied (%s can not be copied).</font>",
|
||||
MSG_MOVED => "<font color=green> %s selected file/directory(s) have been moved (%s can not be moved).</font>",
|
||||
MSG_DEL_SUCC => "<font color=green><b>%s</b> files and <b>%s</b> directories have been removed.</font>",
|
||||
MSG_DEL_CURR => "<font color=green>You've removed the directory: %s</font>",
|
||||
MSG_DEL_ALL => "<font color=green>You've removed the directory, and all contents recursively.</font>",
|
||||
MSG_DEL_SKIP => "<font color=green>You've skipped the directory: %s</font>",
|
||||
MSG_DEL_CANC => "<font color=green>You've cancelled deleting the directory</font>",
|
||||
MSG_DEL_ALL_SUCC => "<font color=green>All child dirs and files on the selected directorys has been removed. </font>",
|
||||
MSG_CONTINUE => "<body bgcolor='#E9E9E9' text='#000066' leftmargin=5 topmargin=5><font color=red face=arial size=2> <b><a href='%s?fdo=cmd_show_passwd&work_path=%s&%s'>click here</a> to continue.</font></body>",
|
||||
MSG_PWD_CHANGED => "<font color=green>Your password was changed. </font>",
|
||||
MSG_DEMO => "<font color=red>Disabled in Demo.</font>",
|
||||
MSG_USER_ADDED => "%s was added successfully.",
|
||||
MSG_USER_DELETED => "%s was deleted successfully.",
|
||||
MSG_USER_RMALL => "Users were deleted sucessfully.",
|
||||
ERR_DEL => "<font color=red>Can not remove file(s)</font>",
|
||||
ERR_CHMOD => "<font color=red>Can not change mode </font>",
|
||||
ERR_FILE_OPEN => "<font color=red>Can not open file: %s</font>",
|
||||
ERR_FILE_EMPTY => "<font color=red>File <b>%s</b> is empty.</font>",
|
||||
ERR_FILE_EXISTS => "<font color=red>File <b>%s</b> exists.</font>",
|
||||
ERR_FILE_NOT_EXISTS => "<font color=red>File <b>%s</b> does not exist.</font>",
|
||||
ERR_FILE_PERM => "<body bgcolor='#E9E9E9' text='#000066' leftmargin=5 topmargin=5><font color=red face=arial size=2> <b>Sorry, but we don't have write access to the htaccess files: '%s' and '%s'</font></BODY>",
|
||||
ERR_FILE_PEM => "<font color=red>The <b>%s</b> directory is not writeable.</font>",
|
||||
ERR_NOT_TEXT_FILE => "<font color=red>File <b>%s</b> is not a text file.</font>",
|
||||
ERR_DIR_NOT_EXISTS => "<font color=red>Directory <b>%s</b> does not exist.</font>",
|
||||
ERR_DIR_PEM => "<font color=red>The <b>%s</b> is not writeable.</font>",
|
||||
ERR_DIR_PERM => "<font color=red>Please check permission.</font>",
|
||||
ERR_NOT_ISFILE => "<font color=red><b>%s</b> is a directory.</font>",
|
||||
ERR_TMP_FILE => "<font color=red>Can not open temp file.</font>",
|
||||
ERR_FREE_SPC => "<font color=red>Upload: Not enough free space to upload that file.</font>",
|
||||
ERR_RM_FILE => "<font color=red>Unable to remove file: %s. Reason: %s</font>",
|
||||
ERR_UPLOAD => "<font color=red>Unable to upload file: %s. Reason: %s.</font>",
|
||||
ERR_FILE_SAVE => "<font color=red>Cannot save file %s. Check permissions.</font>",
|
||||
ERR_DIR_EXISTS => "<font color=red>Directory %s already exists.</font>",
|
||||
ERR_NAME => "<font color=red>Illegal Characters in Directory. Please use letters, numbers, - and _ only.</font>",
|
||||
ERR_FILE_NAME1 => "No double .. allowed in file names.",
|
||||
ERR_FILE_NAME2 => "No leading . in file names.",
|
||||
ERR_READ_DIR => "<font color=red>Can not open dir: %s. Reason: %s</font>",
|
||||
ERR_DIR_DEEP => "Directory level too deep.",
|
||||
ERR_DISK_SPACE => "<font color=red>Not enough space to save it (free space is %s kb)</font>",
|
||||
ERR_UNCOMPRESS => "<font color=red>Select files or directories before to uncompress.</font>",
|
||||
ERR_TAR => "<font color=red>Error: %s.</font>",
|
||||
ERR_TAR_NOT_EXISTS => "<font color=red>Can not create a tar file: %s</font>",
|
||||
ERR_TAR_PEM => "<font color=red>Can not create a tar file <b>%s</b>. Check permission.</font>",
|
||||
ERR_DOWNLOAD => "<font color=red>You selected a directory !</font>",
|
||||
ERR_LOGIN => "<font color=red>Invalid Username and Password.</font>",
|
||||
ERR_INVALID => "<font color=red>Input value has invalid characters : <b>%s</b></font> ",
|
||||
ERR_NOT_FILE => "<font color=red>The %s is not a file</font>",
|
||||
ERR_OLD_PASSWORD => "<font color=red>Invalid Old password</font>",
|
||||
ERR_NEW_PASSWORD => "<font color=red>New password must be more than 3 character</font>",
|
||||
ERR_OPEN_FILE => "<font color=red>Can not open %s file, reason: %s</font>",
|
||||
ERR_WRITEABLE => "<font color=red>Can not save %s file, reason: %s</font>",
|
||||
ERR_NO_AZIP => "<font color=red>Please install the Archive::Zip library which is required.</font>",
|
||||
ERR_NO_GZIP => "<font color=red>Please install the Compress::Zlib library which is required.</font>",
|
||||
COBALT_NOREMOTE => "FileMan is not currently running under server authentication!",
|
||||
ERR_VERSION => "<font color=red>This action does not support for your current version!</font>",
|
||||
ERR_PRINT => "Please select the files which are required text or image files",
|
||||
PRINT_NEXT => "<a href='%s'><font face='Verdana, Arial, Helvetica, sans-serif' size=2>Print Next</font></a>",
|
||||
COBALT_NOUSER => "Unable to lookup user '%s'",
|
||||
COBALT_BADUID => "Invalid user '%s' (%s)",
|
||||
COBALT_CANTSU => "Can't switch to user '%s' (%s,%s). Reason: '%s'",
|
||||
COBALT_BADDIR => "Invalid home directory '%s'. It does not look like a standard Raq director.",
|
||||
COBALT_BADGROUP => "This program is restricted to site administrators only. You must be in the site administer group in order to use this.",
|
||||
FILETYPE_IMAGE => 'Image file',
|
||||
FILETYPE_TEXT => 'Text file',
|
||||
FILETYPE_SCRIPT => 'Script file',
|
||||
FILETYPE_COMPRESSED => 'Compressed file',
|
||||
FILETYPE_HTML => 'HTML file',
|
||||
FILETYPE_SOUND => 'Audio file',
|
||||
FILETYPE_BINARY => 'Binary file',
|
||||
FILETYPE_DOC => 'MS Word',
|
||||
FILETYPE_XLS => 'MS Excel',
|
||||
FILETYPE_PDF => 'PDF file',
|
||||
FILETYPE_FOLDER => 'File Folder',
|
||||
FILETYPE_UNKNOWN => 'Unknown file',
|
||||
FILETYPE_EXT => '%s file',
|
||||
FILECOL_NAME => 'Name',
|
||||
FILECOL_SIZE => 'Size',
|
||||
FILECOL_DATE => 'Modified',
|
||||
FILECOL_PERM => 'Permissions',
|
||||
FILECOL_USER => 'Owner',
|
||||
FILECOL_TYPE => 'File Type',
|
||||
FILECOL_VIEW => 'View',
|
||||
DATE_SHORT_JAN => 'Jan',
|
||||
DATE_SHORT_FEB => 'Feb',
|
||||
DATE_SHORT_MAR => 'Mar',
|
||||
DATE_SHORT_APR => 'Apr',
|
||||
DATE_SHORT_MAY => 'May',
|
||||
DATE_SHORT_JUN => 'Jun',
|
||||
DATE_SHORT_JUL => 'Jul',
|
||||
DATE_SHORT_AUG => 'Aug',
|
||||
DATE_SHORT_SEP => 'Sep',
|
||||
DATE_SHORT_OCT => 'Oct',
|
||||
DATE_SHORT_NOV => 'Nov',
|
||||
DATE_SHORT_DEC => 'Dec',
|
||||
DIR_PARENT => 'Parent Directory',
|
||||
README => 'Readme File',
|
||||
COMMAND_TIMEOUT => 'Command timed out',
|
||||
COMMAND_KILLFAIL => 'Unable to kill process (%s): %s',
|
||||
EXTRACT_FILE_OK => '%s... okay',
|
||||
EXTRACT_FILE_SKIP => '%s... skipped',
|
||||
);
|
||||
|
||||
1;
|
||||
442
site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Diff.pm
Normal file
442
site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Diff.pm
Normal file
@ -0,0 +1,442 @@
|
||||
# ==================================================================
|
||||
# File manager - enhanced web based file management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# Revision : $Id: Diff.pm,v 1.9 2004/02/17 01:33:07 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
package GT::FileMan::Diff;
|
||||
# ==================================================================
|
||||
# This module is based off the example scripts distributed with Algorthim::Diff
|
||||
#
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION %HTML_ESCAPE);
|
||||
use GT::File::Diff;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
|
||||
%HTML_ESCAPE = (
|
||||
'&' => '&',
|
||||
'<' => '<',
|
||||
'>' => '>',
|
||||
'"' => '"'
|
||||
);
|
||||
|
||||
my $File_Length_Difference = 0;
|
||||
|
||||
sub diff {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes two filenames, or two array refs, and returns a text diff. See also
|
||||
# html_diff. Optionally takes an additional number - if provided, you'll get
|
||||
# a unified context diff with however many lines of context as you passed in for
|
||||
# this value, otherwise you'll get a boring old <, >-type diff.
|
||||
# Returns 1 if the first file couldn't be opened, 2 if the second couldn't be
|
||||
# opened, and a scalar reference containing the diff otherwise.
|
||||
#
|
||||
my ($file1, $file2, $context_lines) = @_;
|
||||
my ($f1_mod, $f2_mod, $filename1, $filename2);
|
||||
|
||||
if (!ref $file1) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
open $fh, "<$file1" or return 1;
|
||||
chomp(my @f1 = <$fh>);
|
||||
$f1_mod = (stat $fh)[9];
|
||||
($filename1, $file1) = ($file1, \@f1);
|
||||
}
|
||||
if (!ref $file2) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
open $fh, "<$file2" or return 2;
|
||||
chomp(my @f2 = <$fh>);
|
||||
$f2_mod = (stat $fh)[9];
|
||||
($filename2, $file2) = ($file2, \@f2);
|
||||
}
|
||||
|
||||
my $ret = "";
|
||||
my $diff = GT::File::Diff::diff($file1, $file2, \&_hash);
|
||||
return \($ret = "Files are identical") if not @$diff;
|
||||
|
||||
if ($context_lines and $f1_mod and $f2_mod) {
|
||||
$ret .= "--- $filename1\t" . gmtime($f1_mod) . " -0000\n";
|
||||
$ret .= "+++ $filename2\t" . gmtime($f2_mod) . " -0000\n";
|
||||
}
|
||||
|
||||
$File_Length_Difference = 0;
|
||||
|
||||
my ($hunk, $oldhunk);
|
||||
for my $piece (@$diff) {
|
||||
$hunk = GT::FileMan::Diff::Hunk->new($file1, $file2, $piece, $context_lines);
|
||||
next unless $oldhunk;
|
||||
|
||||
if ($context_lines and $hunk->does_overlap($oldhunk)) {
|
||||
$hunk->prepend_hunk($oldhunk);
|
||||
}
|
||||
else {
|
||||
$ret .= $oldhunk->output_diff($file1, $file2, $context_lines);
|
||||
}
|
||||
} continue { $oldhunk = $hunk }
|
||||
|
||||
$ret .= $oldhunk->output_diff($file1, $file2, $context_lines);
|
||||
\$ret;
|
||||
}
|
||||
|
||||
# This generates a unique key for the line; we simply take the line and convert
|
||||
# all multiple spaces into a single space to effectively perform a "diff -b".
|
||||
sub _hash {
|
||||
my $str = shift;
|
||||
$str =~ s/^\s+//;
|
||||
$str =~ s/\s+$//;
|
||||
$str =~ s/\s{2,}/ /g;
|
||||
$str;
|
||||
}
|
||||
|
||||
sub html_diff {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Works exactly as the above, but also HTML escapes and colorizes the diff.
|
||||
# The first two or three arguments are the same as above, and the last argument
|
||||
# is a hash ref of (ID => html_color) pairs. The ID's available, and defaults,
|
||||
# are as follows (scalar refs make the text also bold):
|
||||
# { file => \"#2e8b57", linenum => \"#a52a2a", sep => "#6a5acd", removed => "#6a5acd", added => "#008b8b" }
|
||||
# - file is used only in unified context diffs to show the filename & last modified time
|
||||
# - linenum is used to indicate the line numbers the change applies to
|
||||
# - sep is used only in non-unified diffs to separate the removed/added lines
|
||||
# - removed is the colour for removed lines
|
||||
# - added is the colour for added lines
|
||||
# The return is the same scalar reference or error number as that of diff(),
|
||||
# but formatted for HTML with escaped HTML where necessary and the whole thing
|
||||
# wrapped in <pre>...</pre>. Note that no checking or HTML escaping is
|
||||
# performed on the colors passed in; it is your responsibility to make sure the
|
||||
# values of the colors hash are safe.
|
||||
#
|
||||
my (@args) = @_;
|
||||
my %colors;
|
||||
%colors = %{pop @args} if ref $args[-1];
|
||||
|
||||
$colors{file} ||= \"#2e8b57";
|
||||
$colors{linenum} ||= \"#a52a2a";
|
||||
$colors{added} ||= "#008b8b";
|
||||
$colors{removed} ||= "#6a5acd";
|
||||
$colors{sep} ||= "#6a5acd";
|
||||
|
||||
for (keys %colors) {
|
||||
if (ref $colors{$_}) {
|
||||
$colors{$_} = qq|<font color="${$colors{$_}}"><b>|;
|
||||
$colors{"${_}_close"} = qq|</b></font>|;
|
||||
}
|
||||
else {
|
||||
$colors{$_} = qq|<font color="$colors{$_}">|;
|
||||
$colors{"${_}_close"} = qq|</font>|;
|
||||
}
|
||||
}
|
||||
|
||||
my $ret = diff(@args);
|
||||
return $ret unless ref $ret;
|
||||
|
||||
$$ret =~ s/(["&<>])/$HTML_ESCAPE{$1}/g;
|
||||
$$ret =~ s{^([^ ].*)}{
|
||||
my $line = $1;
|
||||
if ($line eq '---') {
|
||||
qq{$colors{sep}$line$colors{sep_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 3) eq '---' or substr($line, 0, 3) eq '+++') {
|
||||
qq{$colors{file}$line$colors{file_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 2) eq '@@' or $line =~ /^[0-9]/) {
|
||||
qq{$colors{linenum}$line$colors{linenum_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 1) eq '+' or substr($line, 0, 4) eq '>') {
|
||||
qq{$colors{added}$line$colors{added_close}}
|
||||
}
|
||||
elsif (substr($line, 0, 1) eq '-' or substr($line, 0, 4) eq '<') {
|
||||
qq{$colors{removed}$line$colors{removed_close}}
|
||||
}
|
||||
else {
|
||||
# A mistake? We should never get here, but silently ignore if we do
|
||||
$line
|
||||
}
|
||||
}egm;
|
||||
|
||||
substr($$ret, 0, 0) = '<pre>';
|
||||
$$ret .= '</pre>';
|
||||
|
||||
$ret;
|
||||
}
|
||||
|
||||
|
||||
# Package Hunk. A Hunk is a group of Blocks which overlap because of the
|
||||
# context surrounding each block. (So if we're not using context, every
|
||||
# hunk will contain one block.)
|
||||
package GT::FileMan::Diff::Hunk;
|
||||
|
||||
sub new {
|
||||
# Arg1 is output from &LCS::diff (which corresponds to one Block)
|
||||
# Arg2 is the number of items (lines, e.g.,) of context around each block
|
||||
#
|
||||
# This subroutine changes $File_Length_Difference
|
||||
#
|
||||
# Fields in a Hunk:
|
||||
# blocks - a list of Block objects
|
||||
# start - index in file 1 where first block of the hunk starts
|
||||
# end - index in file 1 where last block of the hunk ends
|
||||
#
|
||||
# Variables:
|
||||
# before_diff - how much longer file 2 is than file 1 due to all hunks
|
||||
# until but NOT including this one
|
||||
# after_diff - difference due to all hunks including this one
|
||||
my ($class, $f1, $f2, $piece, $context_items) = @_;
|
||||
|
||||
my $block = new GT::FileMan::Diff::Block ($piece); # this modifies $FLD!
|
||||
|
||||
my $before_diff = $File_Length_Difference; # BEFORE this hunk
|
||||
my $after_diff = $before_diff + $block->{"length_diff"};
|
||||
$File_Length_Difference += $block->{"length_diff"};
|
||||
|
||||
# @remove_array and @insert_array hold the items to insert and remove
|
||||
# Save the start & beginning of each array. If the array doesn't exist
|
||||
# though (e.g., we're only adding items in this block), then figure
|
||||
# out the line number based on the line number of the other file and
|
||||
# the current difference in file lenghts
|
||||
my @remove_array = $block->remove;
|
||||
my @insert_array = $block->insert;
|
||||
my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2);
|
||||
$a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1;
|
||||
$a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1;
|
||||
$b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1;
|
||||
$b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1;
|
||||
|
||||
$start1 = $a1 == -1 ? $b1 - $before_diff : $a1;
|
||||
$end1 = $a2 == -1 ? $b2 - $after_diff : $a2;
|
||||
$start2 = $b1 == -1 ? $a1 + $before_diff : $b1;
|
||||
$end2 = $b2 == -1 ? $a2 + $after_diff : $b2;
|
||||
|
||||
# At first, a hunk will have just one Block in it
|
||||
my $hunk = {
|
||||
"start1" => $start1,
|
||||
"start2" => $start2,
|
||||
"end1" => $end1,
|
||||
"end2" => $end2,
|
||||
"blocks" => [$block],
|
||||
"f1" => $f1,
|
||||
"f2" => $f2
|
||||
};
|
||||
bless $hunk, $class;
|
||||
|
||||
$hunk->flag_context($context_items);
|
||||
|
||||
return $hunk;
|
||||
}
|
||||
|
||||
# Change the "start" and "end" fields to note that context should be added
|
||||
# to this hunk
|
||||
sub flag_context {
|
||||
my ($hunk, $context_items) = @_;
|
||||
return unless $context_items; # no context
|
||||
|
||||
# add context before
|
||||
my $start1 = $hunk->{"start1"};
|
||||
my $num_added = $context_items > $start1 ? $start1 : $context_items;
|
||||
$hunk->{"start1"} -= $num_added;
|
||||
$hunk->{"start2"} -= $num_added;
|
||||
|
||||
# context after
|
||||
my $end1 = $hunk->{"end1"};
|
||||
$num_added = ($end1+$context_items > $#{$hunk->{f1}}) ?
|
||||
$#{$hunk->{f1}} - $end1 :
|
||||
$context_items;
|
||||
$hunk->{"end1"} += $num_added;
|
||||
$hunk->{"end2"} += $num_added;
|
||||
}
|
||||
|
||||
# Is there an overlap between hunk arg0 and old hunk arg1?
|
||||
# Note: if end of old hunk is one less than beginning of second, they overlap
|
||||
sub does_overlap {
|
||||
my ($hunk, $oldhunk) = @_;
|
||||
return "" unless $oldhunk; # first time through, $oldhunk is empty
|
||||
|
||||
# Do I actually need to test both?
|
||||
return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 ||
|
||||
$hunk->{"start2"} - $oldhunk->{"end2"} <= 1);
|
||||
}
|
||||
|
||||
# Prepend hunk arg1 to hunk arg0
|
||||
# Note that arg1 isn't updated! Only arg0 is.
|
||||
sub prepend_hunk {
|
||||
my ($hunk, $oldhunk) = @_;
|
||||
|
||||
$hunk->{"start1"} = $oldhunk->{"start1"};
|
||||
$hunk->{"start2"} = $oldhunk->{"start2"};
|
||||
|
||||
unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}});
|
||||
}
|
||||
|
||||
|
||||
# DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO...
|
||||
sub output_diff {
|
||||
my $context_diff = $_[3];
|
||||
if ($context_diff) { return &output_unified_diff }
|
||||
else { return &output_boring_diff }
|
||||
}
|
||||
|
||||
sub output_unified_diff {
|
||||
my ($hunk, $fileref1, $fileref2) = @_;
|
||||
my @blocklist;
|
||||
my $ret = "";
|
||||
|
||||
# Calculate item number range.
|
||||
my $range1 = $hunk->unified_range(1);
|
||||
my $range2 = $hunk->unified_range(2);
|
||||
$ret .= "@@ -$range1 +$range2 @@\n";
|
||||
|
||||
# Outlist starts containing the hunk of file 1.
|
||||
# Removing an item just means putting a '-' in front of it.
|
||||
# Inserting an item requires getting it from file2 and splicing it in.
|
||||
# We splice in $num_added items. Remove blocks use $num_added because
|
||||
# splicing changed the length of outlist.
|
||||
# We remove $num_removed items. Insert blocks use $num_removed because
|
||||
# their item numbers---corresponding to positions in file *2*--- don't take
|
||||
# removed items into account.
|
||||
my $low = $hunk->{"start1"};
|
||||
my $hi = $hunk->{"end1"};
|
||||
my ($num_added, $num_removed) = (0,0);
|
||||
my @outlist = @$fileref1[$low..$hi];
|
||||
for (@outlist) { s/^/ / } # assume it's just context
|
||||
|
||||
foreach my $block (@{$hunk->{"blocks"}}) {
|
||||
foreach my $item ($block->remove) {
|
||||
my $op = $item->{"sign"}; # -
|
||||
my $offset = $item->{"item_no"} - $low + $num_added;
|
||||
$outlist[$offset] =~ s/^ /$op/;
|
||||
$num_removed++;
|
||||
}
|
||||
foreach my $item ($block->insert) {
|
||||
my $op = $item->{"sign"}; # +
|
||||
my $i = $item->{"item_no"};
|
||||
my $offset = $i - $hunk->{"start2"} + $num_removed;
|
||||
splice(@outlist,$offset,0,"$op$$fileref2[$i]");
|
||||
$num_added++;
|
||||
}
|
||||
}
|
||||
|
||||
for (@outlist) { $ret .= "$_\n" } # add \n's
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub output_boring_diff {
|
||||
# Note that an old diff can't have any context. Therefore, we know that
|
||||
# there's only one block in the hunk.
|
||||
my ($hunk, $fileref1, $fileref2) = @_;
|
||||
my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c');
|
||||
|
||||
my $ret = '';
|
||||
my @blocklist = @{$hunk->{"blocks"}};
|
||||
warn ("Expecting one block in an old diff hunk!") if scalar @blocklist != 1;
|
||||
my $block = $blocklist[0];
|
||||
my $op = $block->op; # +, -, or !
|
||||
|
||||
# Calculate item number range.
|
||||
# old diff range is just like a context diff range, except the ranges
|
||||
# are on one line with the action between them.
|
||||
my $range1 = $hunk->context_range(1);
|
||||
my $range2 = $hunk->context_range(2);
|
||||
my $action = $op_hash{$op} || warn "unknown op $op";
|
||||
$ret .= "$range1$action$range2\n";
|
||||
|
||||
# If removing anything, just print out all the remove lines in the hunk
|
||||
# which is just all the remove lines in the block
|
||||
if (my @foo = $block->remove) {
|
||||
my @outlist = @$fileref1[$hunk->{"start1"}..$hunk->{"end1"}];
|
||||
map {$_ = "< $_\n"} @outlist; # all lines will be '< text\n'
|
||||
$ret .= join '', @outlist;
|
||||
}
|
||||
|
||||
$ret .= "---\n" if $op eq '!'; # only if inserting and removing
|
||||
if ($block->insert) {
|
||||
my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}];
|
||||
map {$_ = "> $_\n"} @outlist; # all lines will be '> text\n'
|
||||
$ret .= join "", @outlist;
|
||||
}
|
||||
}
|
||||
|
||||
sub context_range {
|
||||
# Generate a range of item numbers to print. Only print 1 number if the range
|
||||
# has only one item in it. Otherwise, it's 'start,end'
|
||||
my ($hunk, $flag) = @_;
|
||||
my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
|
||||
$start++; $end++; # index from 1, not zero
|
||||
my $range = ($start < $end) ? "$start,$end" : $end;
|
||||
return $range;
|
||||
}
|
||||
|
||||
sub unified_range {
|
||||
# Generate a range of item numbers to print for unified diff
|
||||
# Print number where block starts, followed by number of lines in the block
|
||||
# (don't print number of lines if it's 1)
|
||||
my ($hunk, $flag) = @_;
|
||||
my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"});
|
||||
$start++; $end++; # index from 1, not zero
|
||||
my $length = $end - $start + 1;
|
||||
my $first = $length < 2 ? $end : $start; # strange, but correct...
|
||||
my $range = $length== 1 ? $first : "$first,$length";
|
||||
return $range;
|
||||
}
|
||||
|
||||
package GT::FileMan::Diff::Block;
|
||||
# Package Block. A block is an operation removing, adding, or changing
|
||||
# a group of items. Basically, this is just a list of changes, where each
|
||||
# change adds or deletes a single item.
|
||||
# (Change could be a separate class, but it didn't seem worth it)
|
||||
|
||||
sub new {
|
||||
# Input is a chunk from &Algorithm::LCS::diff
|
||||
# Fields in a block:
|
||||
# length_diff - how much longer file 2 is than file 1 due to this block
|
||||
# Each change has:
|
||||
# sign - '+' for insert, '-' for remove
|
||||
# item_no - number of the item in the file (e.g., line number)
|
||||
# We don't bother storing the text of the item
|
||||
#
|
||||
my ($class,$chunk) = @_;
|
||||
my @changes = ();
|
||||
|
||||
# This just turns each change into a hash.
|
||||
foreach my $item (@$chunk) {
|
||||
my ($sign, $item_no, $text) = @$item;
|
||||
my $hashref = {"sign" => $sign, "item_no" => $item_no};
|
||||
push @changes, $hashref;
|
||||
}
|
||||
|
||||
my $block = { "changes" => \@changes };
|
||||
bless $block, $class;
|
||||
|
||||
$block->{"length_diff"} = $block->insert - $block->remove;
|
||||
return $block;
|
||||
}
|
||||
|
||||
|
||||
# LOW LEVEL FUNCTIONS
|
||||
sub op {
|
||||
# what kind of block is this?
|
||||
my $block = shift;
|
||||
my $insert = $block->insert;
|
||||
my $remove = $block->remove;
|
||||
|
||||
$remove && $insert and return '!';
|
||||
$remove and return '-';
|
||||
$insert and return '+';
|
||||
warn "unknown block type";
|
||||
return '^'; # context block
|
||||
}
|
||||
|
||||
# Returns a list of the changes in this block that remove items
|
||||
# (or the number of removals if called in scalar context)
|
||||
sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; }
|
||||
|
||||
# Returns a list of the changes in this block that insert items
|
||||
sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; }
|
||||
|
||||
1;
|
||||
103
site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Session.pm
Normal file
103
site/slowtwitch.com/cgi-bin/articles/GT/FileMan/Session.pm
Normal file
@ -0,0 +1,103 @@
|
||||
# ==================================================================
|
||||
# File manager - enhanced web based file management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# Revision : $Id: Session.pm,v 1.1 2007/12/19 23:32:47 bao Exp $
|
||||
#
|
||||
# Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
package GT::FileMan::Session;
|
||||
|
||||
use strict;
|
||||
use GT::Session::File;
|
||||
|
||||
sub session_valid {
|
||||
# This function checks to see if the session is valid, and returns a
|
||||
# hash of session information
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $session_path = "$self->{cfg}->{private_path}/sessions";
|
||||
|
||||
# Clear out old sessions.
|
||||
GT::Session::File->cleanup($self->{cfg}->{session}->{expiry} * 3600, $session_path);
|
||||
|
||||
# Validate the session
|
||||
my $session_id = $self->{in}->param('sid') || $self->{in}->cookie($self->{cfg}->{session}->{cookie}) || return;
|
||||
my $session = new GT::Session::File (
|
||||
directory => $session_path,
|
||||
id => $session_id
|
||||
) || return;
|
||||
|
||||
# Update the session
|
||||
$session->save;
|
||||
|
||||
return { id => $session_id, data => $session->{data} };
|
||||
}
|
||||
|
||||
sub session_create {
|
||||
my ($self, $user, $use_cookie) = @_;
|
||||
|
||||
my $session_path = "$self->{cfg}->{private_path}/sessions";
|
||||
|
||||
# Clear out old sessions.
|
||||
GT::Session::File->cleanup($self->{cfg}->{session}->{expiry} * 3600, $session_path);
|
||||
|
||||
# Create a new session and save the information.
|
||||
my $session = new GT::Session::File (directory => $session_path);
|
||||
$session->{data}->{user} = $user->{username};
|
||||
$session->save;
|
||||
|
||||
# Now redirect to another URL and set cookies, or set URL string.
|
||||
if ($use_cookie) {
|
||||
print $self->{in}->cookie(
|
||||
-name => $self->{cfg}->{session}->{cookie},
|
||||
-value => $session->{id},
|
||||
-path => '/'
|
||||
)->cookie_header() . "\n";
|
||||
}
|
||||
else {
|
||||
$self->{cgi}->{sid} = $session->{id};
|
||||
}
|
||||
return { id => $session->{id}, data => $session->{data} };
|
||||
}
|
||||
|
||||
sub session_delete {
|
||||
my $self = shift;
|
||||
|
||||
print $self->{in}->cookie(
|
||||
-name => $self->{cfg}->{session}->{cookie},
|
||||
-value => '',
|
||||
-path => '/'
|
||||
)->cookie_header() . "\n";
|
||||
|
||||
my $session_id = $self->{in}->cookie($self->{cfg}->{session}->{cookie}) || $self->{in}->param('sid') || return;
|
||||
my $session = new GT::Session::File (
|
||||
directory => "$self->{cfg}->{private_path}/sessions",
|
||||
id => $session_id
|
||||
) || return;
|
||||
return $session->delete();
|
||||
}
|
||||
|
||||
sub session_save {
|
||||
my ($self, $id, $args) = @_;
|
||||
|
||||
return unless $id and $args;
|
||||
|
||||
my $session_path = "$self->{cfg}->{private_path}/sessions";
|
||||
my $session = new GT::Session::File (
|
||||
directory => $session_path,
|
||||
id => $id
|
||||
);
|
||||
|
||||
foreach (keys %$args) {
|
||||
next unless $args->{$_};
|
||||
$session->{data}->{$_} = $args->{$_};
|
||||
}
|
||||
$session->save();
|
||||
}
|
||||
1;
|
||||
107
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter.pm
Normal file
107
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter.pm
Normal file
@ -0,0 +1,107 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Filter
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Filter.pm,v 1.3 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Does nothing for now, here as a referance.
|
||||
#
|
||||
|
||||
package GT::IPC::Filter;
|
||||
# ==================================================================
|
||||
|
||||
die "Do not use me";
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::IPC::Filter::Foo;
|
||||
|
||||
my $filter = new GT::IPC::Filter::Foo(sub { my $out = shift ... });
|
||||
# -or-
|
||||
my $filter = new GT::IPC::Filter::Foo(
|
||||
output => sub { my $out = shift; .. },
|
||||
%options
|
||||
);
|
||||
|
||||
$filter->put(\$data);
|
||||
|
||||
$filter->flush;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This documents how to create a filter. The filter system documented here is
|
||||
used for GT::IPC::Run, L<GT::IPC::Run>, currently but could be useful for other
|
||||
things relating to IO and IPC.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
You will need to impliment three methods to create a filter. These methods are
|
||||
pretty simple and strait forward.
|
||||
|
||||
=head2 new
|
||||
|
||||
This is your constructor. You will need to return an object. You should be able
|
||||
to take a sigle argument as well as a hash of options. It isn't manditory but
|
||||
it will keep the filter interface consistent.
|
||||
|
||||
The one argument form of C<new()> is a code reference. This code reference will
|
||||
be called with the data (in whatever form) after you filter it. You should
|
||||
default the rest of your arguments to something reasonable. If there are no
|
||||
reasonable defaults for your options you can stray from this and require the
|
||||
hash form, but you should have a nice error for people that call you with the
|
||||
one argument form:
|
||||
|
||||
$class->fatal(
|
||||
BADARGS => "This class does not accept the one argument form for filters"
|
||||
) if @_ == 1;
|
||||
|
||||
The hash form should take a key C<output> which will be the code reference
|
||||
output will go to once you filter it. The rest of the keys are up to you. Try
|
||||
to have reasonable defaults for the other keys, but fatal if there are any that
|
||||
are required and not present.
|
||||
|
||||
=head2 put
|
||||
|
||||
This method is called with a scaler reference of the data you will be
|
||||
filtering. You are expect to make changes to the data and call the C<output>
|
||||
code reference with the formatted data. For example GT::IPC::Filter::Line
|
||||
calles the C<output> code reference with each line of data, see
|
||||
L<GT::IPC::Filter::Line>. It is ok if you change the scalar reference passed
|
||||
into you.
|
||||
|
||||
=head2 flush
|
||||
|
||||
C<flush()> if called when the stream of data is at an end. Not arguments are
|
||||
passed to it. You are expected send any data you are buffering to the C<output>
|
||||
code reference at this point, after filtering it if nessisary.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<GT::IPC::Run>, L<GT::IPC::Filter::Line>, L<GT::IPC::Filter::Stream>,
|
||||
and L<GT::IPC::Filter::Block>.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Scott Beck
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Filter.pm,v 1.3 2004/01/13 01:35:17 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
154
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Block.pm
Normal file
154
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Block.pm
Normal file
@ -0,0 +1,154 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Filter::Block
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Block.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Filter streams of input out in block sizes.
|
||||
#
|
||||
|
||||
package GT::IPC::Filter::Block;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use base 'GT::Base';
|
||||
|
||||
sub new {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $class = shift;
|
||||
|
||||
if (@_ == 1) {
|
||||
@_ = (output => $_[0]);
|
||||
}
|
||||
$class->fatal(BADARGS => "Arguments to new() must be a hash")
|
||||
if @_ & 1;
|
||||
my %opts = @_;
|
||||
|
||||
my $output = delete $opts{output};
|
||||
$class->fatal(BADARGS => "No output for new()")
|
||||
unless defined $output;
|
||||
$class->fatal(BADARGS => "No output passed to new() is not a code ref")
|
||||
unless ref($output) eq 'CODE';
|
||||
|
||||
my $block_size = delete $opts{block_size};
|
||||
$block_size = 512 unless defined $block_size;
|
||||
|
||||
return bless {
|
||||
block_size => $block_size,
|
||||
output => $output,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub put {
|
||||
# ----------------------------------------------------------------------------
|
||||
my ($self, $in) = @_;
|
||||
|
||||
if (defined $self->{buffer}) {
|
||||
$$in = $self->{buffer} . $$in;
|
||||
undef $self->{buffer};
|
||||
}
|
||||
if (length($$in) >= $self->{block_size}) {
|
||||
my $gets = int(length($$in) / $self->{block_size});
|
||||
for (1 .. $gets) {
|
||||
$self->{output}->(substr($$in, 0, $self->{block_size}));
|
||||
substr($$in, 0, $self->{block_size}) = '';
|
||||
}
|
||||
}
|
||||
$self->{buffer} = $$in;
|
||||
}
|
||||
|
||||
sub flush {
|
||||
# ----------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
$self->{output}->($self->{buffer}) if defined $self->{buffer};
|
||||
undef $self->{buffer};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::IPC::Filter::Block - Implements block based filtering for output streams.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::IPC::Filter::Block;
|
||||
|
||||
my $filter = new GT::IPC::Filter::Block(
|
||||
sub { my $block = shift ... }
|
||||
);
|
||||
# -or-
|
||||
my $filter = new GT::IPC::Filter::Block(
|
||||
output => sub { my $out = shift; .. },
|
||||
block_size => 512 # Default
|
||||
);
|
||||
|
||||
$filter->put(\$data);
|
||||
|
||||
$filter->flush;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Implements block based filtering to an output code reference. Used mainly in
|
||||
GT::IPC::Run, L<GT::IPC::Run> for details.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
There are three methods (as with all filters in this class).
|
||||
|
||||
=head2 new
|
||||
|
||||
Takes either a single argument, which is a code reference to call output with,
|
||||
or a hash of options.
|
||||
|
||||
=over 4
|
||||
|
||||
=item output
|
||||
|
||||
This is the code reference you would like called with each block of output.
|
||||
The blocks are stripped of there ending before this is called.
|
||||
|
||||
=item block_size
|
||||
|
||||
This is the size of chunks of data you want your code reference called with. It
|
||||
defaults to 512.
|
||||
|
||||
=back
|
||||
|
||||
=head2 put
|
||||
|
||||
This method takes a stream of data, it converted it into block based data using
|
||||
the C<block_size> you specified and passes each block to the code reference
|
||||
specified by C<new()>, see L<"new">. There is buffering that happens here.
|
||||
|
||||
=head2 flush
|
||||
|
||||
This method should be called last, when the data stream is over. It flushes the
|
||||
remaining buffer out to the code reference.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<GT::IPC::Run>.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Scott Beck
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Block.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
176
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Line.pm
Normal file
176
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Line.pm
Normal file
@ -0,0 +1,176 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Filter::Line
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Line.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Filter streams of input out to a line.
|
||||
#
|
||||
|
||||
package GT::IPC::Filter::Line;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use base 'GT::Base';
|
||||
|
||||
sub new {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $class = shift;
|
||||
|
||||
if (@_ == 1) {
|
||||
@_ = (output => $_[0]);
|
||||
}
|
||||
$class->fatal(BADARGS => "Arguments to new() must be a hash")
|
||||
if @_ & 1;
|
||||
my %opts = @_;
|
||||
|
||||
my $output = delete $opts{output};
|
||||
$class->fatal(BADARGS => "No output for new()")
|
||||
unless defined $output;
|
||||
$class->fatal(BADARGS => "No output passed to new() is not a code ref")
|
||||
unless ref($output) eq 'CODE';
|
||||
|
||||
my $regex = delete $opts{regex};
|
||||
my $literal = delete $opts{literal};
|
||||
|
||||
$class->fatal(BADARGS => "You can only specify one of literal and regex")
|
||||
if defined $regex and defined $literal;
|
||||
|
||||
if (defined $literal) {
|
||||
$regex = quotemeta $literal;
|
||||
}
|
||||
|
||||
if (!defined $regex) {
|
||||
$regex = '\x0D\x0A?|\x0A\x0D?';
|
||||
}
|
||||
|
||||
return bless {
|
||||
regex => $regex,
|
||||
output => $output,
|
||||
}, $class;
|
||||
}
|
||||
|
||||
sub put {
|
||||
# ----------------------------------------------------------------------------
|
||||
my ($self, $in) = @_;
|
||||
|
||||
if (defined $self->{buffer}) {
|
||||
$$in = $self->{buffer} . $$in;
|
||||
undef $self->{buffer};
|
||||
}
|
||||
my $regex = $self->{regex};
|
||||
my @in = split /($regex)/ => $$in;
|
||||
|
||||
# Not a complete line
|
||||
if ($in[$#in] !~ /$regex/) {
|
||||
$self->{buffer} = pop @in;
|
||||
}
|
||||
|
||||
for (my $i = 0; $i < $#in; $i += 2) {
|
||||
$self->{output}->($in[$i]);
|
||||
}
|
||||
}
|
||||
|
||||
sub flush {
|
||||
# ----------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
$self->{output}->($self->{buffer}) if defined $self->{buffer};
|
||||
undef $self->{buffer};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::IPC::Filter::Line - Implements line based filtering for output streams.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::IPC::Filter::Line;
|
||||
|
||||
my $filter = new GT::IPC::Filter::Line(
|
||||
sub { my $line = shift ... }
|
||||
);
|
||||
# -or-
|
||||
my $filter = new GT::IPC::Filter::Line(
|
||||
output => sub { my $out = shift; .. },
|
||||
regex => '\r?\n'
|
||||
);
|
||||
|
||||
$filter->put(\$data);
|
||||
|
||||
$filter->flush;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Implements line based filtering to an output code reference. Used mainly in
|
||||
GT::IPC::Run, L<GT::IPC::Run> for details.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
There are three methods (as with all filters in this class).
|
||||
|
||||
=head2 new
|
||||
|
||||
Takes either a single argument, which is a code reference to call output with,
|
||||
or a hash of options.
|
||||
|
||||
=over 4
|
||||
|
||||
=item output
|
||||
|
||||
This is the code reference you would like called with each line of output. The
|
||||
lines are stripped of there ending before this is called.
|
||||
|
||||
=item regex
|
||||
|
||||
Specify the regex to use in order to determine the end of line sequence. This
|
||||
regex is used in a split on the input stream. If you capture in this regex it
|
||||
will break the output.
|
||||
|
||||
=item literal
|
||||
|
||||
Specifies a literal new line sequence. The only difference between this option
|
||||
and the C<regex> option is it is C<quotemeta>, See L<perlfunc/quotemeta>.
|
||||
|
||||
=back
|
||||
|
||||
=head2 put
|
||||
|
||||
This method takes a stream of data, it converted it into line based data and
|
||||
passes each line to the code reference specified by C<new()>, see L<"new">.
|
||||
There is buffering that happens here because we have no way of knowing if the
|
||||
output stream does not end with a new line, also streams almost always get
|
||||
partial lines.
|
||||
|
||||
=head2 flush
|
||||
|
||||
This method should be called last, when the data stream is over. It flushes the
|
||||
remaining buffer out to the code reference.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<GT::IPC::Run>.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Scott Beck
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Line.pm,v 1.7 2004/01/13 01:35:17 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
127
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Stream.pm
Normal file
127
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Filter/Stream.pm
Normal file
@ -0,0 +1,127 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Filter::Stream
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Stream.pm,v 1.5 2006/05/26 21:56:30 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Filter streams of input out to a streams ;).
|
||||
#
|
||||
|
||||
package GT::IPC::Filter::Stream;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use base 'GT::Base';
|
||||
|
||||
sub new {
|
||||
# ----------------------------------------------------------------------------
|
||||
my $class = shift;
|
||||
|
||||
if (@_ == 1) {
|
||||
@_ = (output => $_[0]);
|
||||
}
|
||||
$class->fatal(BADARGS => "Arguments to new() must be a hash")
|
||||
if @_ & 1;
|
||||
my %opts = @_;
|
||||
|
||||
my $output = delete $opts{output};
|
||||
$class->fatal(BADARGS => "No output for new()")
|
||||
unless defined $output;
|
||||
$class->fatal(BADARGS => "No output passed to new() is not a code ref")
|
||||
unless ref($output) eq 'CODE';
|
||||
|
||||
return bless { output => $output }, $class;
|
||||
}
|
||||
|
||||
sub put {
|
||||
# ----------------------------------------------------------------------------
|
||||
my ($self, $in) = @_;
|
||||
|
||||
$self->{output}->($$in);
|
||||
}
|
||||
|
||||
sub flush {
|
||||
# ----------------------------------------------------------------------------
|
||||
# Does nothing
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::IPC::Filter::Block - Implements stream based filtering for output streams.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::IPC::Filter::Stream;
|
||||
|
||||
my $filter = new GT::IPC::Filter::Block(
|
||||
sub { my $chunk = shift ... }
|
||||
);
|
||||
# -or-
|
||||
my $filter = new GT::IPC::Filter::Block(
|
||||
output => sub { my $chunk = shift; .. },
|
||||
);
|
||||
|
||||
$filter->put(\$data);
|
||||
|
||||
$filter->flush;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Implements stream based filtering to an output code reference. Used mainly in
|
||||
GT::IPC::Run, L<GT::IPC::Run> for details. Basically just a pass through to
|
||||
your code reference.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
There are three methods (as with all filters in this class).
|
||||
|
||||
=head2 new
|
||||
|
||||
Takes either a single argument, which is a code reference to call output with,
|
||||
or a hash of options.
|
||||
|
||||
=over 4
|
||||
|
||||
=item output
|
||||
|
||||
This is the code reference you would like called with each output.
|
||||
|
||||
=back
|
||||
|
||||
=head2 put
|
||||
|
||||
This method takes a stream of data and passed it strait to your code reference.
|
||||
There is no buffering that happens here.
|
||||
|
||||
=head2 flush
|
||||
|
||||
This method does nothing.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<GT::IPC::Run>.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Scott Beck
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Stream.pm,v 1.5 2006/05/26 21:56:30 brewt Exp $
|
||||
|
||||
=cut
|
||||
|
||||
873
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run.pm
Normal file
873
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run.pm
Normal file
@ -0,0 +1,873 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Run
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Run.pm,v 1.22 2006/05/26 21:56:30 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Runs programs or code references in parallel
|
||||
#
|
||||
package GT::IPC::Run;
|
||||
|
||||
use strict;
|
||||
use base 'GT::Base';
|
||||
use vars qw/@EXPORT_OK $SYSTEM $DEBUG $ERRORS/;
|
||||
|
||||
use Exporter();
|
||||
use Socket;
|
||||
use Symbol qw/gensym/;
|
||||
use POSIX qw(fcntl_h errno_h :sys_wait_h);
|
||||
|
||||
use GT::IPC::Filter::Line;
|
||||
use GT::IPC::Run::Select;
|
||||
use GT::IPC::Run::Child;
|
||||
|
||||
my $can_run_socket = undef;
|
||||
|
||||
*import = \&Exporter::import;
|
||||
@EXPORT_OK = qw/run/;
|
||||
$DEBUG = 0;
|
||||
|
||||
sub READ_BLOCK () { 512 }
|
||||
sub IS_WIN32 () { $^O eq 'MSWin32' }
|
||||
|
||||
$ERRORS = {
|
||||
SEMAPHORE => "Could not create semephore socket; Reason: %s",
|
||||
FORK => "Could not fork; Reason: %s"
|
||||
};
|
||||
|
||||
BEGIN {
|
||||
# http://support.microsoft.com/support/kb/articles/Q150/5/37.asp
|
||||
# defines EINPROGRESS as 10035. We provide it here because some
|
||||
# Win32 users report POSIX::EINPROGRESS is not vendor-supported.
|
||||
if (IS_WIN32) {
|
||||
eval '*EINPROGRESS = sub { 10036 };';
|
||||
eval '*EWOULDBLOCK = sub { 10035 };';
|
||||
eval '*F_GETFL = sub { 0 };';
|
||||
eval '*F_SETFL = sub { 0 };';
|
||||
require GT::IPC::Run::Win32;
|
||||
import GT::IPC::Run::Win32;
|
||||
$SYSTEM = 'GT::IPC::Run::Win32';
|
||||
}
|
||||
else {
|
||||
require GT::IPC::Run::Unix;
|
||||
import GT::IPC::Run::Unix;
|
||||
$SYSTEM = 'GT::IPC::Run::Unix';
|
||||
}
|
||||
}
|
||||
|
||||
sub new {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = bless {}, $SYSTEM;
|
||||
$self->{select} = new GT::IPC::Run::Select;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub run {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($program, $out, $err, $in) = @_;
|
||||
my $self = new GT::IPC::Run;
|
||||
my $ref;
|
||||
|
||||
$self->fatal("No program specified to start")
|
||||
unless defined $program;
|
||||
$ref = ref $program;
|
||||
$self->fatal("Invalid program passed to start $program")
|
||||
if
|
||||
$ref ne 'CODE' and
|
||||
$ref ne 'ARRAY' and
|
||||
$ref;
|
||||
|
||||
$ref = defined($out) ? ref($out) : undef;
|
||||
my $out_is_handle = _is_handle($out);
|
||||
$self->fatal(
|
||||
BADARGS => "stdout handler is not a code ref or scalar ref"
|
||||
) if
|
||||
defined $ref and
|
||||
$ref ne 'CODE' and
|
||||
$ref ne 'SCALAR' and
|
||||
!$out_is_handle and
|
||||
$ref !~ /\AGT::IPC::Filter::/;
|
||||
|
||||
$ref = defined($err) ? ref($err) : undef;
|
||||
my $err_is_handle = _is_handle($err);
|
||||
$self->fatal(
|
||||
BADARGS => "stderr handler is not a code ref or scalar ref"
|
||||
) if
|
||||
defined $ref and
|
||||
$ref ne 'CODE' and
|
||||
$ref ne 'SCALAR' and
|
||||
!$err_is_handle and
|
||||
$ref !~ /\AGT::IPC::Filter::/;
|
||||
|
||||
$ref = ref $in;
|
||||
my $in_is_handle = _is_handle($in);
|
||||
$self->fatal(
|
||||
BADARGS => "stdin handler is not a scalar ref or filehandle"
|
||||
) if
|
||||
$ref ne 'SCALAR' and
|
||||
!$in_is_handle and
|
||||
$ref !~ /\AGT::IPC::Filter::/ and
|
||||
defined $in;
|
||||
|
||||
my $pid = $self->start(
|
||||
program => $program,
|
||||
stdout => $out,
|
||||
stderr => $err,
|
||||
stdin => $in,
|
||||
debug => $DEBUG
|
||||
);
|
||||
1 while $self->do_one_loop;
|
||||
my $exit_code = $self->exit_code($pid);
|
||||
return $exit_code;
|
||||
}
|
||||
|
||||
sub start {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->fatal(BADARGS => "Arguments to start() must be a hash")
|
||||
if @_ & 1;
|
||||
my %opts = @_;
|
||||
my $ref;
|
||||
|
||||
$self->{_debug} = delete $opts{debug};
|
||||
$self->{_debug} = $DEBUG unless defined $self->{_debug};
|
||||
|
||||
my $program = delete $opts{program};
|
||||
$self->fatal("No program specified to start")
|
||||
unless defined $program;
|
||||
$ref = ref $program;
|
||||
$self->fatal("Invalid program passed to start $program")
|
||||
if
|
||||
$ref ne 'CODE' and
|
||||
$ref ne 'ARRAY' and
|
||||
$ref;
|
||||
|
||||
my $out = delete $opts{stdout};
|
||||
my $actual_out;
|
||||
$ref = defined($out) ? ref($out) : undef;
|
||||
my $out_is_handle = _is_handle($out);
|
||||
|
||||
# Default to line filter for stderr
|
||||
if ($ref and $ref eq 'CODE') {
|
||||
$actual_out = new GT::IPC::Filter::Line($out);
|
||||
}
|
||||
elsif ($ref and $ref eq 'SCALAR') {
|
||||
$actual_out = new GT::IPC::Filter::Line(sub { $$out .= "$_[0]\n" });
|
||||
}
|
||||
elsif ($ref and $ref =~ /\AGT::IPC::Filter::/) {
|
||||
$actual_out = $out;
|
||||
}
|
||||
elsif (defined($out) and !$out_is_handle) {
|
||||
$self->fatal(
|
||||
BADARGS => "stdout handler is not a code ref or scalar ref"
|
||||
);
|
||||
}
|
||||
|
||||
my $err = delete $opts{stderr};
|
||||
my $actual_err;
|
||||
my $err_is_handle = _is_handle($err);
|
||||
$ref = defined($err) ? ref($err) : undef;
|
||||
|
||||
# Default to line filter for stderr
|
||||
if ($ref and $ref eq 'CODE') {
|
||||
$actual_err = new GT::IPC::Filter::Line($err);
|
||||
}
|
||||
elsif ($ref and $ref eq 'SCALAR') {
|
||||
$actual_err = new GT::IPC::Filter::Line(sub { $$err .= "$_[0]\n" });
|
||||
}
|
||||
elsif ($ref and $ref =~ /\AGT::IPC::Filter::/) {
|
||||
$actual_err = $err;
|
||||
}
|
||||
elsif (defined($err) and !$err_is_handle) {
|
||||
$self->fatal(
|
||||
BADARGS => "stderr handler is not a code ref or scalar ref"
|
||||
);
|
||||
}
|
||||
|
||||
my $in = delete $opts{stdin};
|
||||
my $in_is_handle = _is_handle($in);
|
||||
$ref = ref $in;
|
||||
$self->fatal(
|
||||
BADARGS => "stdin handler is not a scalar ref or filehandle"
|
||||
) if
|
||||
$ref ne 'SCALAR' and
|
||||
!$in_is_handle and
|
||||
defined $in;
|
||||
|
||||
|
||||
my $exit_callback = delete $opts{reaper};
|
||||
$self->fatal(
|
||||
BADARGS => "The exit callback specified is not a code reference"
|
||||
) if
|
||||
defined $exit_callback and
|
||||
ref($exit_callback) ne 'CODE';
|
||||
|
||||
my $done_callback = delete $opts{done_callback};
|
||||
$self->fatal(
|
||||
BADARGS => "The done callback specified is not a code reference"
|
||||
) if
|
||||
defined $done_callback and
|
||||
ref($done_callback) ne 'CODE';
|
||||
|
||||
$self->fatal(
|
||||
BADARGS => "Unknown arguments ", join(", ", keys %opts)
|
||||
) if keys %opts;
|
||||
|
||||
# get the sockets we need for stdin/stdout/stderr communication
|
||||
my ($stderr_read, $stderr_write) = $self->oneway;
|
||||
$self->fatal("could not make stderr pipe: $!")
|
||||
unless defined $stderr_read and defined $stderr_write;
|
||||
my ($stdout_read, $stdout_write) = $self->twoway;
|
||||
$self->fatal("could not make stdout pipe: $!")
|
||||
unless defined $stdout_read and defined $stdout_write;
|
||||
my ($stdin_read, $stdin_write) = $self->oneway;
|
||||
$self->fatal("could not make stdin pipes: $!")
|
||||
unless defined $stdin_read and defined $stdin_write;
|
||||
|
||||
# Defaults to blocking
|
||||
$self->stop_blocking($stdout_read);
|
||||
$self->stop_blocking($stdout_write);
|
||||
$self->stop_blocking($stderr_read);
|
||||
$self->stop_blocking($stderr_write);
|
||||
|
||||
# Change the ones they have overridden
|
||||
if ($in_is_handle) {
|
||||
$stdin_read = $in;
|
||||
undef $stdin_write;
|
||||
undef $in;
|
||||
}
|
||||
elsif (!$in) {
|
||||
undef $stdin_write;
|
||||
undef $stdin_read;
|
||||
}
|
||||
if ($out_is_handle) {
|
||||
$stdout_write = $out;
|
||||
undef $stdout_read;
|
||||
undef $out;
|
||||
}
|
||||
elsif (!$out) {
|
||||
undef $stdout_write;
|
||||
undef $stdout_read;
|
||||
}
|
||||
if ($err_is_handle) {
|
||||
$stderr_write = $err;
|
||||
undef $stderr_read;
|
||||
}
|
||||
elsif (!$err) {
|
||||
undef $stderr_write;
|
||||
undef $stderr_read;
|
||||
}
|
||||
|
||||
# Temporary location for these
|
||||
$self->{current_child} = new GT::IPC::Run::Child(
|
||||
program => $program,
|
||||
stderr_read => $stderr_read,
|
||||
stderr_write => $stderr_write,
|
||||
stdout_read => $stdout_read,
|
||||
stdout_write => $stdout_write,
|
||||
stdin_write => $stdin_write,
|
||||
stdin_read => $stdin_read,
|
||||
stdin => $in,
|
||||
handler_stdout => $actual_out,
|
||||
handler_stderr => $actual_err,
|
||||
exit_callback => $exit_callback,
|
||||
done_callback => $done_callback,
|
||||
exit_status => 0,
|
||||
pid => 0
|
||||
);
|
||||
|
||||
# Run the program/code ref
|
||||
my $pid = $self->execute;
|
||||
return $pid;
|
||||
}
|
||||
|
||||
sub do_loop {
|
||||
# ----------------------------------------------------------------------------
|
||||
my ($self, $wait) = @_;
|
||||
1 while $self->do_one_loop($wait);
|
||||
}
|
||||
|
||||
sub exit_code {
|
||||
# ----------------------------------------------------------------------------
|
||||
my ($self, $pid) = @_;
|
||||
$self->fatal( BADARGS => "No pid passed to exit_code" )
|
||||
unless defined $pid;
|
||||
return $self->{goners}{$pid};
|
||||
}
|
||||
|
||||
sub twoway {
|
||||
# ------------------------------------------------------------------------
|
||||
my ( $self, $conduit_type ) = @_;
|
||||
|
||||
# Try UNIX-domain socketpair if no preferred conduit type is
|
||||
# specified, or if the specified conduit type is 'socketpair'.
|
||||
if (
|
||||
(
|
||||
not defined $conduit_type or
|
||||
$conduit_type eq 'socketpair'
|
||||
) and
|
||||
not defined $can_run_socket
|
||||
)
|
||||
{
|
||||
my ($rw1, $rw2) = (gensym, gensym);
|
||||
|
||||
eval {
|
||||
socketpair( $rw1, $rw2, AF_UNIX, SOCK_STREAM, PF_UNSPEC )
|
||||
or die "socketpair 1 failed: $!";
|
||||
};
|
||||
|
||||
# Socketpair succeeded.
|
||||
if ( !length $@ ) {
|
||||
|
||||
$self->debug("Using socketpair for twoway") if $self->{_debug};
|
||||
# It's two-way, so each reader is also a writer.
|
||||
|
||||
select( ( select($rw1), $| = 1 )[0] );
|
||||
select( ( select($rw2), $| = 1 )[0] );
|
||||
return ( $rw1, $rw2, $rw1, $rw2 );
|
||||
}
|
||||
elsif ($DEBUG) {
|
||||
$self->debug("Error with socketpair: $@\n");
|
||||
}
|
||||
}
|
||||
|
||||
# Try the pipe if no preferred conduit type is specified, or if the
|
||||
# specified conduit type is 'pipe'.
|
||||
if (
|
||||
(
|
||||
not defined $conduit_type or
|
||||
$conduit_type eq 'pipe'
|
||||
) and
|
||||
not defined $can_run_socket
|
||||
)
|
||||
{
|
||||
my ($read1, $write1, $read2, $write2) =
|
||||
(gensym, gensym, gensym, gensym);
|
||||
|
||||
eval {
|
||||
pipe($read1, $write1) or die "pipe 1 failed: $!";
|
||||
pipe($read2, $write2) or die "pipe 2 failed: $!";
|
||||
};
|
||||
|
||||
# Pipe succeeded.
|
||||
if (!length $@) {
|
||||
|
||||
$self->debug("Using pipe for twoway") if $self->{_debug};
|
||||
# Turn off buffering. POE::Kernel does this for us, but someone
|
||||
# might want to use the pipe class elsewhere.
|
||||
select((select($write1), $| = 1)[0]);
|
||||
select((select($write2), $| = 1)[0]);
|
||||
return($read1, $write1, $read2, $write2);
|
||||
}
|
||||
elsif ($self->{_debug}) {
|
||||
$self->debug("Error with pipe(): $@");
|
||||
}
|
||||
}
|
||||
|
||||
# Try a pair of plain INET sockets if no preffered conduit type is
|
||||
# specified, or if the specified conduit type is 'inet'.
|
||||
if (
|
||||
(
|
||||
not defined $conduit_type or
|
||||
$conduit_type eq 'inet'
|
||||
) and (
|
||||
$can_run_socket or
|
||||
not defined $can_run_socket
|
||||
)
|
||||
)
|
||||
{
|
||||
my ($rw1, $rw2) = (gensym, gensym);
|
||||
|
||||
# Try using a pair of plain INET domain sockets.
|
||||
eval { ($rw1, $rw2) = $self->make_socket }; # make_socket
|
||||
# returns em
|
||||
# non-blocking
|
||||
|
||||
# Sockets worked.
|
||||
if (!length $@) {
|
||||
|
||||
$self->debug("Using inet socket for twoway") if $self->{_debug};
|
||||
# Try sockets more often.
|
||||
$can_run_socket = 1;
|
||||
|
||||
# Turn off buffering. POE::Kernel does this for us, but someone
|
||||
# might want to use the pipe class elsewhere.
|
||||
select((select($rw1), $| = 1)[0]);
|
||||
select((select($rw2), $| = 1)[0]);
|
||||
|
||||
return($rw1, $rw2, $rw1, $rw2);
|
||||
}
|
||||
elsif ($self->{_debug}) {
|
||||
$self->debug("Error with socket: $@");
|
||||
}
|
||||
|
||||
# Sockets failed. Don't dry them again.
|
||||
}
|
||||
$self->debug("Nothing worked") if $self->{_debug};
|
||||
|
||||
# There's nothing left to try.
|
||||
return(undef, undef, undef, undef);
|
||||
}
|
||||
|
||||
sub oneway {
|
||||
# ------------------------------------------------------------------------
|
||||
my ( $self, $conduit_type ) = @_;
|
||||
|
||||
# Generate symbols to be used as filehandles for the pipe's ends.
|
||||
my $read = gensym;
|
||||
my $write = gensym;
|
||||
|
||||
# Try UNIX-domain socketpair if no preferred conduit type is
|
||||
# specified, or if the specified conduit type is 'socketpair'.
|
||||
if (
|
||||
(
|
||||
not defined $conduit_type or
|
||||
$conduit_type eq 'socketpair'
|
||||
) and
|
||||
not defined $can_run_socket
|
||||
)
|
||||
{
|
||||
|
||||
eval {
|
||||
socketpair($read, $write, AF_UNIX, SOCK_STREAM, PF_UNSPEC)
|
||||
or die "socketpair failed: $!";
|
||||
};
|
||||
|
||||
# Socketpair succeeded.
|
||||
if (!length $@) {
|
||||
|
||||
$self->debug("Using socketpair for oneway") if $self->{_debug};
|
||||
# It's one-way, so shut down the unused directions.
|
||||
shutdown($read, 1);
|
||||
shutdown($write, 0);
|
||||
|
||||
# Turn off buffering. POE::Kernel does this for us, but someone
|
||||
# might want to use the pipe class elsewhere.
|
||||
select((select($write), $| = 1)[0]);
|
||||
return($read, $write);
|
||||
}
|
||||
elsif ($self->{_debug}) {
|
||||
$self->debug("Could not make socketpair: $@");
|
||||
}
|
||||
}
|
||||
|
||||
# Try the pipe if no preferred conduit type is specified, or if the
|
||||
# specified conduit type is 'pipe'.
|
||||
if (
|
||||
(
|
||||
not defined $conduit_type or
|
||||
$conduit_type eq 'pipe'
|
||||
) and
|
||||
not defined $can_run_socket
|
||||
)
|
||||
{
|
||||
|
||||
eval { pipe($read, $write) or die "pipe failed: $!" };
|
||||
|
||||
# Pipe succeeded.
|
||||
if (!length $@) {
|
||||
|
||||
$self->debug("Using pipe for oneway") if $self->{_debug};
|
||||
# Turn off buffering. POE::Kernel does this for us, but
|
||||
# someone might want to use the pipe class elsewhere.
|
||||
select((select($write),$| = 1 )[0]);
|
||||
return($read, $write);
|
||||
}
|
||||
elsif ($self->{_debug}) {
|
||||
$self->debug("Could not make pipe: $@");
|
||||
}
|
||||
}
|
||||
|
||||
# Try a pair of plain INET sockets if no preffered conduit type is
|
||||
# specified, or if the specified conduit type is 'inet'.
|
||||
if (
|
||||
(
|
||||
not defined $conduit_type or
|
||||
$conduit_type eq 'inet'
|
||||
) and (
|
||||
$can_run_socket or
|
||||
not defined $can_run_socket
|
||||
)
|
||||
)
|
||||
{
|
||||
|
||||
# Try using a pair of plain INET domain sockets.
|
||||
eval { ($read, $write) = $self->make_socket };
|
||||
|
||||
if (!length $@) {
|
||||
|
||||
$self->debug("Using inet socket for oneway") if $self->{_debug};
|
||||
# Try sockets more often.
|
||||
$can_run_socket = 1;
|
||||
|
||||
# It's one-way, so shut down the unused directions.
|
||||
shutdown($read, 1);
|
||||
shutdown($write, 0);
|
||||
|
||||
# Turn off buffering. POE::Kernel does this for us, but someone
|
||||
# might want to use the pipe class elsewhere.
|
||||
select((select($write), $| = 1)[0]);
|
||||
return($read, $write);
|
||||
}
|
||||
else {
|
||||
$self->debug("Could not make socket: $@") if $self->{_debug};
|
||||
$can_run_socket = 0;
|
||||
}
|
||||
}
|
||||
$self->debug("Nothing worked") if $self->{_debug};
|
||||
return(undef, undef);
|
||||
}
|
||||
|
||||
|
||||
# Make a socket. This is a homebrew socketpair() for systems that
|
||||
# don't support it. The things I must do to make Windows happy.
|
||||
|
||||
sub make_socket {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
|
||||
### Server side.
|
||||
|
||||
my $acceptor = gensym();
|
||||
my $accepted = gensym();
|
||||
|
||||
my $tcp = getprotobyname('tcp') or die "getprotobyname: $!";
|
||||
socket( $acceptor, PF_INET, SOCK_STREAM, $tcp ) or die "socket: $!";
|
||||
|
||||
setsockopt($acceptor, SOL_SOCKET, SO_REUSEADDR, pack("l", 1)) or die "reuse: $!";
|
||||
|
||||
my $server_addr = inet_aton('127.0.0.1') or die "inet_aton: $!";
|
||||
$server_addr = pack_sockaddr_in( 0, $server_addr ) or die "sockaddr_in: $!";
|
||||
|
||||
bind($acceptor, $server_addr) or die "bind: $!";
|
||||
|
||||
$self->stop_blocking($acceptor);
|
||||
|
||||
$server_addr = getsockname($acceptor);
|
||||
|
||||
listen($acceptor, SOMAXCONN) or die "listen: $!";
|
||||
|
||||
### Client side.
|
||||
|
||||
my $connector = gensym();
|
||||
|
||||
socket($connector, PF_INET, SOCK_STREAM, $tcp) or die "socket: $!";
|
||||
|
||||
$self->stop_blocking($connector);
|
||||
|
||||
unless (connect( $connector, $server_addr)) {
|
||||
die "connect: $!"
|
||||
if $! and ($! != EINPROGRESS) and ($! != EWOULDBLOCK);
|
||||
}
|
||||
|
||||
my $connector_address = getsockname($connector);
|
||||
my ( $connector_port, $connector_addr ) =
|
||||
unpack_sockaddr_in($connector_address);
|
||||
|
||||
### Loop around 'til it's all done. I thought I was done writing
|
||||
### select loops. Damnit.
|
||||
|
||||
my $in_read = '';
|
||||
my $in_write = '';
|
||||
|
||||
vec($in_read, fileno($acceptor), 1) = 1;
|
||||
vec($in_write, fileno($connector), 1) = 1;
|
||||
|
||||
my $done = 0;
|
||||
while ( $done != 0x11 ) {
|
||||
my $hits =
|
||||
select( my $out_read = $in_read, my $out_write = $in_write, undef,
|
||||
5 );
|
||||
|
||||
# For some reason this always dies when called
|
||||
# successivly (quickly) on the 5th or 6th call
|
||||
die "select: $^E" if $hits < 0;
|
||||
#next unless $hits;
|
||||
# try again?
|
||||
# return $self->make_socket unless $hits;
|
||||
|
||||
# Accept happened.
|
||||
if ( vec( $out_read, fileno($acceptor), 1 ) ) {
|
||||
my $peer = accept( $accepted, $acceptor ) or die "accept: $!";
|
||||
my ( $peer_port, $peer_addr ) = unpack_sockaddr_in($peer);
|
||||
|
||||
if ( $peer_port == $connector_port
|
||||
and $peer_addr eq $connector_addr )
|
||||
{
|
||||
vec( $in_read, fileno($acceptor), 1 ) = 0;
|
||||
$done |= 0x10;
|
||||
}
|
||||
}
|
||||
|
||||
# Connect happened.
|
||||
if ( vec( $out_write, fileno($connector), 1 ) ) {
|
||||
$! = unpack( 'i', getsockopt( $connector, SOL_SOCKET, SO_ERROR ) );
|
||||
die "connect: $!" if $!;
|
||||
|
||||
vec( $in_read, fileno($acceptor), 1 ) = 0;
|
||||
$done |= 0x01;
|
||||
}
|
||||
}
|
||||
|
||||
# Turn blocking back on, damnit.
|
||||
$self->start_blocking($accepted);
|
||||
$self->start_blocking($connector);
|
||||
|
||||
return ( $accepted, $connector );
|
||||
}
|
||||
|
||||
sub _is_handle {
|
||||
my $ref = ref($_[0]);
|
||||
return (
|
||||
($ref and $ref eq 'GLOB') or
|
||||
($ref and $_[0] =~ /=GLOB\(/)
|
||||
);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::IPC::Run - Run programs or code in parallel
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::IPC::Run;
|
||||
|
||||
# stderr and stdout filters default to a
|
||||
# GT::IPC::Line::Filter
|
||||
my $exit_code = run
|
||||
'/bin/ls', # Program to run
|
||||
\*stdout_handle, # stdout event
|
||||
\&stderr_handler, # stderr event
|
||||
\$stdin; # stdin
|
||||
|
||||
|
||||
my $io = new GT::IPC::Run;
|
||||
|
||||
use GT::IPC::Filter::Line;
|
||||
|
||||
my $pid = $io->start(
|
||||
stdout => GT::IPC::Filter::Line->new(
|
||||
regex => "\r?\n",
|
||||
output => sub { print "Output: $_[0]\n" }
|
||||
),
|
||||
program => sub { print "I got forked\n" },
|
||||
);
|
||||
|
||||
while ($io->do_one_loop) {
|
||||
if (defined(my $exit = $io->exit_code($pid))) {
|
||||
print "$pid exited ", ($exit>>8), "\n";
|
||||
}
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Module to simplify running a program or code reference in parallel. Allows
|
||||
catching and filtering the output of the program and filtering it.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
GT::IPC::Run will import one function C<run()> if you request it to.
|
||||
|
||||
=head2 run
|
||||
|
||||
Run is a simple interface to running a program or a subroutine in a separate
|
||||
process and catching the output, both stderr and stdout. This function takes
|
||||
four arguments, only the first argument is required.
|
||||
|
||||
=over 4
|
||||
|
||||
=item First Argument
|
||||
|
||||
The first argument to C<run()> is the program to run or the code reference to
|
||||
run. This argument can be one of three things.
|
||||
|
||||
If a code reference if passed as the first argument to C<run()>, GT::IPC::Run
|
||||
will fork off and run the code reference. You SHOULD NOT exit in the code
|
||||
reference if you want your code to work on Windows. Calling C<die()> is ok,
|
||||
as your code is evaled. There are some things you CAN NOT do if you want your
|
||||
code to work on Windows.
|
||||
|
||||
You SHOULD NOT make any calles to C<system()> or C<exec()>. For some reason, on
|
||||
Windows, this breaks filehandle inheritance so all your output from that moment
|
||||
on (including the C<system()> or C<exec()>) call will go to the real output
|
||||
channel, STDERR or STDOUT.
|
||||
|
||||
You SHOULD NOT change STDERR or STDOUT. The child process on Windows can
|
||||
affect the filehandles in the parent. This is probably because of the way
|
||||
C<fork()> on Windows is emulated as threads.
|
||||
|
||||
You probably should not C<fork()> either, though this is not confirmed I
|
||||
really doubt it will work the way you plan.
|
||||
|
||||
If an array reference is passed in it will be dereferenced and passed to
|
||||
C<exec()>. If a scalar is passed in it will be passed to C<exec()>.
|
||||
|
||||
On Windows the arguments are passed to Win32::Process::Create as the program
|
||||
you wish to run. See L<Win32::Process::Create>.
|
||||
|
||||
=item Second Argument
|
||||
|
||||
The second argument to C<run()> is what you want to happen to STDOUT as it
|
||||
comes in. This argument can be one of three things.
|
||||
|
||||
If it is a reference to a GT::IPC::Filter:: class, that will be used to call
|
||||
your code. See L<GT::IPC::Filter> for details.
|
||||
|
||||
If it is a code reference, a new GT::IPC::Filter::Line object will be created
|
||||
and your code reference will be passed in. Exactly:
|
||||
|
||||
$out = GT::IPC::Filter::Line->new($out);
|
||||
|
||||
GT::IPC::Filter::Line will call your code reference for each line of output
|
||||
from the program, the end of the line will be stripped. See
|
||||
L<GT::IPC::Filter::Line> for details.
|
||||
|
||||
If the argument is a scalar reference, again, a new GT::IPC::Filter::Line
|
||||
object will be created. Exactly:
|
||||
|
||||
|
||||
$out = GT::IPC::Filter::Line->new(sub { $$out .= $_[0] });
|
||||
|
||||
|
||||
=item Third Argument
|
||||
|
||||
The third argument to L<run()> is used to handle STDERR if and when what you
|
||||
are running produces it.
|
||||
|
||||
This can be the exact same thing as the second argument, but will work on
|
||||
STDERR.
|
||||
|
||||
=item Forth Argument
|
||||
|
||||
This argument is how to handle STDIN. It may be one of two things.
|
||||
|
||||
If it is a SCALAR, it will be printed to the input of what you are running.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 new
|
||||
|
||||
The is a simple method that takes no arguments and returns a GT::IPC::Run
|
||||
object. It may take options in the future.
|
||||
|
||||
=head2 start
|
||||
|
||||
This is the more complex method to start a program running. When you call this
|
||||
method, the program you specify is started right away and it's PID (process ID)
|
||||
is returned to you. After you call this you will either need to call
|
||||
C<do_loop()> or C<do_one_loop()> to start getting the programs or code
|
||||
references output. See L<"do_loop"> and L<"do_one_loop"> else where in this
|
||||
document.
|
||||
|
||||
This method takes a hash of arguments. The arguments are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item program
|
||||
|
||||
The name of the program, or code reference you wish to run. This is treated
|
||||
the same way as the first argument to L<run()>. See L<"run"> else where in
|
||||
this document for a description of how this argument is treated.
|
||||
|
||||
=item stdout
|
||||
|
||||
This is how you want STDOUT treated. It can be the same things as the second
|
||||
argument to L<run()>. See L<"run"> else where in this document for a
|
||||
description of how this argument is treated.
|
||||
|
||||
=item stderr
|
||||
|
||||
This is how you want STDERR treated. It can be the same things as the third
|
||||
argument to L<run()>. See L<"run"> else where in this document for a
|
||||
description of how this argument is treated.
|
||||
|
||||
=item stdin
|
||||
|
||||
This argument is how to handle STDIN. It may be one of two things. It is
|
||||
treated like the forth argument to L<run()>. See L<"run"> else where in this
|
||||
document for a description of how this argument is treated.
|
||||
|
||||
=item reaper
|
||||
|
||||
This is a code reference that will be ran once a process has exited. Note: the
|
||||
process may not be done sending us STDOUT or STDERR when it exits.
|
||||
|
||||
The code reference is called with the pid as it's first argument and the exit
|
||||
status of the program for its second argument. The exit status is the same as
|
||||
it is returned by waitpid(). The exit status is somewhat fiddled on Windows to
|
||||
act the way you want it to, e.g. C<$exit_status E<gt>E<gt> 8> will be the
|
||||
number the program exited with.
|
||||
|
||||
=item done_callback
|
||||
|
||||
This is a code reference that works similarly to reaper except that it is only
|
||||
called after the child has died AND all STDOUT/STDERR output has been sent,
|
||||
unlike reaper which is called on exit, regardless of any output that may still
|
||||
be pending.
|
||||
|
||||
The code reference is called wih the pid and exit status of the program as its
|
||||
two arguments.
|
||||
|
||||
=back
|
||||
|
||||
=head2 do_one_loop
|
||||
|
||||
This method takes one argument, the time to wait for C<select()> to return
|
||||
something in milliseconds. This does one select loop on all the processes. You
|
||||
will need to called this after you call C<start()>. Typically:
|
||||
|
||||
my $ipc = new GT::IPC::Run;
|
||||
my $pid = $ipc->start(program => 'ls');
|
||||
1 while $ipc->do_one_loop;
|
||||
my $exit_status = $ipc->exit_code($pid);
|
||||
|
||||
|
||||
=head2 do_loop
|
||||
|
||||
This is similar to C<do_one_loop>, except it does not return unless all
|
||||
processes are finished. Almost the same as:
|
||||
|
||||
1 while $ipc->do_one_loop;
|
||||
|
||||
You can pass the wait time to C<do_loop()> and it will be passed on to
|
||||
C<do_one_loop>. The wait time is in milliseconds.
|
||||
|
||||
=head2 exit_code
|
||||
|
||||
This method takes a pid as an argument and returns the exit status of that
|
||||
processes pid. If the process has not exited yet or GT::IPC::Run did not launch
|
||||
the process, returns undefined. The exit code returned by this is the same as
|
||||
returned by waitpid. See L<perlfunc/waitpid> and L<perlfunc/system>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<perlipc>, L<perlfunc/system>, L<perlfunc/exec>, L<perlfork>, and
|
||||
L<Win32::Process>.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Scott Beck
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Run.pm,v 1.22 2006/05/26 21:56:30 brewt Exp $
|
||||
|
||||
=cut
|
||||
|
||||
47
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Child.pm
Normal file
47
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Child.pm
Normal file
@ -0,0 +1,47 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Run::Child
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Child.pm,v 1.2 2002/04/24 04:07:18 alex Exp $
|
||||
#
|
||||
# Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Child storrage class
|
||||
#
|
||||
|
||||
package GT::IPC::Run::Child;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %self = @_;
|
||||
bless \%self, $class;
|
||||
return \%self;
|
||||
}
|
||||
|
||||
sub program { if (@_ > 1) { $_[0]->{program} = $_[1]; } return $_[0]->{program}; }
|
||||
sub stderr_read { if (@_ > 1) { $_[0]->{stderr_read} = $_[1]; } return $_[0]->{stderr_read}; }
|
||||
sub stderr_write { if (@_ > 1) { $_[0]->{stderr_write} = $_[1]; } return $_[0]->{stderr_write}; }
|
||||
sub stdout_read { if (@_ > 1) { $_[0]->{stdout_read} = $_[1]; } return $_[0]->{stdout_read}; }
|
||||
sub stdout_write { if (@_ > 1) { $_[0]->{stdout_write} = $_[1]; } return $_[0]->{stdout_write}; }
|
||||
sub stdin_read { if (@_ > 1) { $_[0]->{stdin_read} = $_[1]; } return $_[0]->{stdin_read}; }
|
||||
sub stdin_write { if (@_ > 1) { $_[0]->{stdin_write} = $_[1]; } return $_[0]->{stdin_write}; }
|
||||
sub stdin { if (@_ > 1) { $_[0]->{stdin} = $_[1]; } return $_[0]->{stdin}; }
|
||||
sub handler_stdout { if (@_ > 1) { $_[0]->{handler_stdout} = $_[1]; } return $_[0]->{handler_stdout}; }
|
||||
sub handler_stderr { if (@_ > 1) { $_[0]->{handler_stderr} = $_[1]; } return $_[0]->{handler_stderr}; }
|
||||
sub exit_callback { if (@_ > 1) { $_[0]->{exit_callback} = $_[1]; } return $_[0]->{exit_callback}; }
|
||||
sub done_callback { if (@_ > 1) { $_[0]->{done_callback} = $_[1]; } return $_[0]->{done_callback}; }
|
||||
sub exit_status { if (@_ > 1) { $_[0]->{exit_status} = $_[1]; } return $_[0]->{exit_status}; }
|
||||
sub pid { if (@_ > 1) { $_[0]->{pid} = $_[1]; } return $_[0]->{pid}; }
|
||||
sub called_reaper { if (@_ > 1) { $_[0]->{called_reaper} = $_[1]; } return $_[0]->{called_reaper}; }
|
||||
sub process { if (@_ > 1) { $_[0]->{process} = $_[1]; } return $_[0]->{process}; }
|
||||
sub forked { if (@_ > 1) { $_[0]->{forked} = $_[1]; } return $_[0]->{forked}; }
|
||||
sub called_done { if (@_ > 1) { $_[0]->{called_done} = $_[1]; } return $_[0]->{called_done}; }
|
||||
|
||||
1;
|
||||
|
||||
131
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Select.pm
Normal file
131
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Select.pm
Normal file
@ -0,0 +1,131 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Run::Select
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Select.pm,v 1.6 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Select IO for children handles
|
||||
#
|
||||
|
||||
package GT::IPC::Run::Select;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
|
||||
use POSIX qw(errno_h);
|
||||
use constants
|
||||
STDOUT_FN => 0,
|
||||
STDERR_FN => 1;
|
||||
|
||||
sub new {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($class) = @_;
|
||||
return bless {}, $class;
|
||||
}
|
||||
|
||||
sub add_stdout {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $pid, $stdout) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
$bits = '' unless defined $bits;
|
||||
|
||||
if (defined $stdout) {
|
||||
my $stdout_fn = fileno($stdout);
|
||||
vec($bits, $stdout_fn, 1) = 1;
|
||||
$self->{$pid}[STDOUT_FN] = $stdout_fn;
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
}
|
||||
|
||||
sub add_stderr {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $pid, $stderr) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
$bits = '' unless defined $bits;
|
||||
|
||||
if (defined $stderr) {
|
||||
my $stderr_fn = fileno($stderr);
|
||||
vec($bits, $stderr_fn, 1) = 1;
|
||||
$self->{$pid}[STDERR_FN] = $stderr_fn;
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
}
|
||||
|
||||
sub remove_stdout {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $pid) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
$bits = '' unless defined $bits;
|
||||
|
||||
my $fn = $self->{$pid}[STDOUT_FN];
|
||||
if (defined $fn) {
|
||||
vec($bits, $fn, 1) = 0;
|
||||
undef $self->{$pid}[STDOUT_FN];
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
}
|
||||
|
||||
sub remove_stderr {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $pid) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
$bits = '' unless defined $bits;
|
||||
|
||||
my $fn = $self->{$pid}[STDERR_FN];
|
||||
if (defined $fn) {
|
||||
vec($bits, $fn, 1) = 0;
|
||||
undef $self->{$pid}[STDERR_FN];
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
}
|
||||
|
||||
sub can_read {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $timeout) = @_;
|
||||
my $bits = delete $self->{vec_bits};
|
||||
my $sbits = $bits;
|
||||
|
||||
local $!;
|
||||
my $nfound;
|
||||
do {
|
||||
$! = 0;
|
||||
$nfound = select($sbits, undef, undef, $timeout);
|
||||
} while $! == EINTR;
|
||||
if (defined $sbits and $nfound > 0) {
|
||||
my (@stdout_waiting, @stderr_waiting);
|
||||
for my $pid (keys %$self ) {
|
||||
my $child = $self->{$pid};
|
||||
if (!defined $self->{$pid}[STDOUT_FN] and !defined $self->{$pid}[STDERR_FN]) {
|
||||
delete $self->{$pid};
|
||||
next;
|
||||
}
|
||||
if (defined $child->[STDOUT_FN] and (!defined $sbits or vec($sbits, $child->[STDOUT_FN], 1))) {
|
||||
push @stdout_waiting, $pid;
|
||||
}
|
||||
if (defined $child->[STDERR_FN] and (!defined $sbits or vec($sbits, $child->[STDERR_FN], 1))) {
|
||||
push @stderr_waiting, $pid;
|
||||
}
|
||||
}
|
||||
if (!@stdout_waiting and !@stderr_waiting) {
|
||||
$self->debug(
|
||||
"Select said we have nfound, but did not find anything pending!"
|
||||
) if $self->{_debug};
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
return(\@stdout_waiting, \@stderr_waiting);
|
||||
}
|
||||
elsif ($nfound < 0) {
|
||||
$self->debug("Socket error: $!") if $self->{_debug};
|
||||
}
|
||||
$self->{vec_bits} = $bits;
|
||||
return [], [];
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
306
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Unix.pm
Normal file
306
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Unix.pm
Normal file
@ -0,0 +1,306 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Run::Unix
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Unix.pm,v 1.24 2004/02/17 01:33:07 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::IPC::Run::Unix;
|
||||
|
||||
use strict;
|
||||
use vars qw/$EVENTS $ERROR_MESSAGE/;
|
||||
use base 'GT::Base';
|
||||
|
||||
use IO::Select;
|
||||
use POSIX qw(fcntl_h errno_h :sys_wait_h);
|
||||
|
||||
sub READ_BLOCK () { 512 }
|
||||
|
||||
@GT::IPC::Run::Unix::ISA = qw(GT::IPC::Run);
|
||||
$ERROR_MESSAGE = 'GT::IPC::Run';
|
||||
|
||||
sub execute {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
|
||||
# unless ($self->{sigchld_installed}) {
|
||||
# $self->{chld_signal} = sub {
|
||||
# my $child;
|
||||
# while (($child = waitpid -1, WNOHANG) > 0) {
|
||||
# $self->{goners}{$child} = $?;
|
||||
# $self->debug(
|
||||
# "forked child $child exited with exit status (".
|
||||
# ($self->{goners}{$child} >> 8).
|
||||
# ")\n"
|
||||
# ) if $self->{_debug};
|
||||
# }
|
||||
# $SIG{CHLD} = $self->{chld_signal};
|
||||
# };
|
||||
# $SIG{CHLD} = $self->{chld_signal};
|
||||
# $self->{sigchld_installed} = 1;
|
||||
# }
|
||||
|
||||
# Create a semaphore pipe. This is used so that the parent doesn't
|
||||
# begin listening until the child's stdio has been set up.
|
||||
my ($child_pipe_read, $child_pipe_write) = $self->oneway;
|
||||
die "Could not create semaphore socket: $!" unless defined $child_pipe_read;
|
||||
|
||||
my $pid;
|
||||
if ($pid = fork) { # Parent
|
||||
my $child = delete $self->{current_child};
|
||||
$self->{select}->add_stdout($pid => $child->stdout_read);
|
||||
$self->{select}->add_stderr($pid => $child->stderr_read);
|
||||
$self->{children}{$pid} = $child;
|
||||
$child->pid($pid);
|
||||
if ($child->stdin and ref($child->stdin) eq 'SCALAR') {
|
||||
print {$child->stdin_write} ${$child->stdin};
|
||||
close $child->stdin_write;
|
||||
}
|
||||
|
||||
# Cludge to stop speed forking
|
||||
select undef, undef, undef, 0.001;
|
||||
|
||||
# Close what the parent will not need
|
||||
# close $child->stdout_write if $child->stdout_write;
|
||||
# close $child->stderr_write if $child->stderr_write;
|
||||
# close $child->stdin_read if $child->stdin_read;
|
||||
<$child_pipe_read>;
|
||||
close $child_pipe_read;
|
||||
close $child_pipe_write;
|
||||
return $pid;
|
||||
}
|
||||
else {
|
||||
$self->fatal(FORK => "$!") unless defined $pid;
|
||||
$self->debug("Forked: $$\n") if $self->{_debug} > 1;
|
||||
|
||||
# Get out self and out filenos
|
||||
my $self = delete $self->{current_child};
|
||||
my ($stdout_fn, $stderr_fn, $stdin_fn);
|
||||
$stdout_fn = fileno($self->stdout_write) if $self->stdout_write;
|
||||
$stderr_fn = fileno($self->stderr_write) if $self->stderr_write;
|
||||
$stdin_fn = fileno($self->stdin_read) if $self->stdin_read;
|
||||
# Close what the child won't need.
|
||||
# close $self->stdin_write if $self->stdin_write;
|
||||
# close $self->stderr_read if $self->stderr_read;
|
||||
# close $self->stdout_read if $self->stdout_read;
|
||||
|
||||
# Tied handles break this
|
||||
untie *STDOUT if tied *STDOUT;
|
||||
untie *STDERR if tied *STDERR;
|
||||
untie *STDIN if tied *STDIN;
|
||||
|
||||
# Redirect STDOUT to the write end of the stdout pipe.
|
||||
if (defined $stdout_fn) {
|
||||
$self->debug("Opening stdout to fileno $stdout_fn") if $self->{_debug};
|
||||
open( STDOUT, ">&$stdout_fn" )
|
||||
or die "can't redirect stdout in child pid $$: $!";
|
||||
$self->debug("stdout opened") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Redirect STDIN from the read end of the stdin pipe.
|
||||
if (defined $stdin_fn) {
|
||||
$self->debug("Opening stdin to fileno $stdin_fn") if $self->{_debug};
|
||||
open( STDIN, "<&$stdin_fn" )
|
||||
or die "can't redirect STDIN in child pid $$: $!";
|
||||
$self->debug("stdin opened") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Redirect STDERR to the write end of the stderr pipe.
|
||||
if (defined $stderr_fn) {
|
||||
$self->debug("Opening stderr to fileno $stderr_fn") if $self->{_debug};
|
||||
open( STDERR, ">&$stderr_fn" )
|
||||
or die "can't redirect stderr in child: $!";
|
||||
}
|
||||
|
||||
select STDERR; $| = 1;
|
||||
select STDOUT; $| = 1;
|
||||
|
||||
# Tell the parent that the stdio has been set up.
|
||||
close $child_pipe_read;
|
||||
print $child_pipe_write "go\n";
|
||||
close $child_pipe_write;
|
||||
|
||||
# Program code here
|
||||
my $program = $self->program;
|
||||
if (ref($program) eq 'ARRAY') {
|
||||
exec(@$program) or do {
|
||||
print STDERR "can't exec (@$program) in child pid $$:$!\n";
|
||||
eval { POSIX::_exit($?); };
|
||||
eval { kill KILL => $$; };
|
||||
};
|
||||
}
|
||||
elsif (ref($program) eq 'CODE') {
|
||||
$? = 0;
|
||||
$program->();
|
||||
|
||||
# In case flushing them wasn't good enough.
|
||||
close STDOUT if defined fileno(STDOUT);
|
||||
close STDERR if defined fileno(STDERR);
|
||||
|
||||
eval { POSIX::_exit($?); };
|
||||
eval { kill KILL => $$; };
|
||||
}
|
||||
else {
|
||||
exec($program) or do {
|
||||
print STDERR "can't exec ($program) in child pid $$:$!\n";
|
||||
eval { POSIX::_exit($?); };
|
||||
eval { kill KILL => $$; };
|
||||
};
|
||||
}
|
||||
die "How did I get here!";
|
||||
}
|
||||
}
|
||||
|
||||
sub put {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $pid = shift;
|
||||
print {$self->{children}{$pid}->stdin_write} @_;
|
||||
}
|
||||
|
||||
sub do_one_loop {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $wait) = @_;
|
||||
$wait = 0.05 unless defined $wait;
|
||||
|
||||
# See if any children have exited
|
||||
my $child;
|
||||
while (($child = waitpid -1, WNOHANG) > 0) {
|
||||
next unless exists $self->{children}{$child};
|
||||
$self->{goners}{$child} = $?;
|
||||
$self->{children}{$child}->exit_status($?);
|
||||
$self->debug(
|
||||
"forked child $child exited with exit status (".
|
||||
($self->{goners}{$child} >> 8).
|
||||
")\n"
|
||||
) if $self->{_debug};
|
||||
}
|
||||
|
||||
for my $pid (keys %{$self->{goners}} ) {
|
||||
my $child = $self->{children}{$pid} or next;
|
||||
if (!$child->called_reaper) {
|
||||
$child->exit_callback->($pid, $self->{goners}{$pid})
|
||||
if $child->exit_callback;
|
||||
$child->called_reaper(1);
|
||||
}
|
||||
}
|
||||
my ($stdout_pending, $stderr_pending) = $self->{select}->can_read($wait);
|
||||
|
||||
my %not_pending = %{$self->{children}};
|
||||
for my $pid (@$stdout_pending, @$stderr_pending) {
|
||||
delete $not_pending{$pid};
|
||||
}
|
||||
for my $pid (keys %{$self->{goners}}) {
|
||||
my $child = $self->{children}{$pid} or next;
|
||||
if ($not_pending{$pid} and not $child->called_done) {
|
||||
$child->done_callback->($pid, $self->{goners}{$pid})
|
||||
if $child->done_callback;
|
||||
$child->called_done(1);
|
||||
}
|
||||
}
|
||||
|
||||
if (!@$stdout_pending and !@$stderr_pending) {
|
||||
$self->debug("Nothing else to do, flushing buffers")
|
||||
if $self->{_debug};
|
||||
$self->debug(
|
||||
"Children: ".
|
||||
keys(%{$self->{children}}).
|
||||
"; goners: ".
|
||||
keys(%{$self->{goners}})
|
||||
) if $self->{_debug};
|
||||
|
||||
# We still have children out there
|
||||
return 1 if keys(%{$self->{children}}) > keys(%{$self->{goners}});
|
||||
|
||||
# Flush output filters and delete children to free memory and FDs
|
||||
$self->flush_filters;
|
||||
|
||||
# Nothing left to do
|
||||
return 0;
|
||||
}
|
||||
# else we have stuff to do
|
||||
for my $pid (@$stdout_pending) {
|
||||
my $child = $self->{children}{$pid};
|
||||
$self->debug("STDOUT pending for $pid") if $self->{_debug};
|
||||
|
||||
my $ret = sysread($child->stdout_read, my $buff, READ_BLOCK);
|
||||
if (!$ret) {
|
||||
if ($! != EAGAIN and $! != 0) {
|
||||
# Socket error
|
||||
$self->debug(
|
||||
"$pid: Socket Read: $!: $^E; Errno: ", 0+$!
|
||||
) if $self->{_debug};
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Process callbacks
|
||||
$self->debug("[$pid STDOUT]: `$buff'\n")
|
||||
if $self->{_debug} > 1;
|
||||
if ($child->handler_stdout) {
|
||||
$child->handler_stdout->put(\$buff);
|
||||
}
|
||||
}
|
||||
}
|
||||
for my $pid (@$stderr_pending) {
|
||||
my $child = $self->{children}{$pid};
|
||||
$self->debug("STDERR pending for $pid") if $self->{_debug};
|
||||
|
||||
my $ret = sysread($child->stderr_read, my $buff, READ_BLOCK);
|
||||
if (!$ret) {
|
||||
if ($! != EAGAIN and $! != 0) {
|
||||
# Socket error
|
||||
$self->debug(
|
||||
"$pid: Socket Read: $!: $^E; Errno: ", 0+$!
|
||||
) if $self->{_debug};
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Process callbacks
|
||||
$self->debug("[$pid STDERR]: `$buff'\n")
|
||||
if $self->{_debug} > 1;
|
||||
if ($child->handler_stderr) {
|
||||
$child->handler_stderr->put(\$buff);
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub flush_filters {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
for my $pid (keys %{$self->{children}}) {
|
||||
my $child = delete $self->{children}{$pid};
|
||||
$self->select->remove_stdout($pid);
|
||||
$self->select->remove_stderr($pid);
|
||||
if ($child->handler_stdout) {
|
||||
$child->handler_stdout->flush;
|
||||
}
|
||||
if ($child->handler_stderr) {
|
||||
$child->handler_stderr->flush;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub stop_blocking {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $socket_handle) = @_;
|
||||
my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl: $!";
|
||||
$flags = fcntl($socket_handle, F_SETFL, $flags | O_NONBLOCK)
|
||||
or die "setfl: $!";
|
||||
}
|
||||
|
||||
sub start_blocking {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $socket_handle) = @_;
|
||||
my $flags = fcntl($socket_handle, F_GETFL, 0) or die "getfl: $!";
|
||||
$flags = fcntl($socket_handle, F_SETFL, $flags & ~O_NONBLOCK)
|
||||
or die "setfl: $!";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
505
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Win32.pm
Normal file
505
site/slowtwitch.com/cgi-bin/articles/GT/IPC/Run/Win32.pm
Normal file
@ -0,0 +1,505 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPC::Run::Win32
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Win32.pm,v 1.16 2006/03/30 18:40:22 sbeck Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::IPC::Run::Win32;
|
||||
|
||||
use strict;
|
||||
use vars qw/$EVENTS $ERROR_MESSAGE/;
|
||||
use base 'GT::Base';
|
||||
|
||||
use POSIX qw(fcntl_h errno_h :sys_wait_h);
|
||||
use GT::Lock qw/lock unlock/;
|
||||
use Win32;
|
||||
use Win32::Process;
|
||||
use Win32::Mutex;
|
||||
sub READ_BLOCK () { 512 }
|
||||
|
||||
# What Win32 module exports this?
|
||||
sub WSAEWOULDBLOCK () { 10035 }
|
||||
|
||||
@GT::IPC::Run::Win32::ISA = qw(GT::IPC::Run);
|
||||
|
||||
$ERROR_MESSAGE = 'GT::IPC::Run';
|
||||
|
||||
sub execute {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
|
||||
my $pid;
|
||||
my $child = $self->{current_child};
|
||||
if (ref($child->program) eq 'ARRAY' or !ref($child->program)) {
|
||||
my $process = $self->fork_exec;
|
||||
$child->pid($process->GetProcessID);
|
||||
$child->process($process);
|
||||
}
|
||||
else {
|
||||
$child->pid($self->fork_code);
|
||||
$child->forked(1);
|
||||
}
|
||||
$self->{children}{$child->pid} = delete $self->{current_child};
|
||||
return $child->pid;
|
||||
}
|
||||
|
||||
sub put {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $pid = shift;
|
||||
print {$self->{children}{$pid}->stdin_write} @_;
|
||||
}
|
||||
|
||||
sub fork_exec {
|
||||
# ------------------------------------------------------------------------
|
||||
# Called on Win32 systems when wanting to exec() a process. This replaces
|
||||
# forking and executing. You cannot get filehandle inheritance when exec()
|
||||
# after a fork, fun stuff.
|
||||
my $self = shift;
|
||||
|
||||
|
||||
my $child = $self->{current_child};
|
||||
my $process = '';
|
||||
my $program = ref($child->program) eq 'ARRAY'
|
||||
? $child->program
|
||||
: [split ' ', $child->program];
|
||||
open STDOUT_SAVE, ">&STDOUT";
|
||||
open STDERR_SAVE, ">&STDERR";
|
||||
open STDIN_SAVE, "<&STDIN";
|
||||
|
||||
# Redirect STDOUT to the write end of the stdout pipe.
|
||||
if ($child->stdout_write) {
|
||||
my $fn = fileno($child->stdout_write);
|
||||
if (defined $fn) {
|
||||
$self->debug("Opening stdout to fileno $fn") if $self->{_debug};
|
||||
open( STDOUT, ">&$fn" )
|
||||
or die "can't redirect stdout in child pid $$: $!";
|
||||
$self->debug("stdout opened") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
die "No fileno for stdout_write";
|
||||
}
|
||||
}
|
||||
|
||||
# Redirect STDIN from the read end of the stdin pipe.
|
||||
if ($child->stdin_read) {
|
||||
my $fn = fileno($child->stdin_read);
|
||||
if (defined $fn) {
|
||||
$self->debug("Opening stdin to fileno $fn") if $self->{_debug};
|
||||
open( STDIN, "<&$fn" )
|
||||
or die "can't redirect STDIN in child pid $$: $!";
|
||||
$self->debug("stdin opened") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
die "No fileno for stdin_read";
|
||||
}
|
||||
}
|
||||
|
||||
# Redirect STDERR to the write end of the stderr pipe.
|
||||
if ($child->stderr_write) {
|
||||
my $fn = fileno($child->stderr_write);
|
||||
if (defined $fn) {
|
||||
$self->debug("Opening stderr to fileno $fn") if $self->{_debug};
|
||||
open( STDERR, ">&$fn" )
|
||||
or die "can't redirect stderr in child: $!";
|
||||
}
|
||||
else {
|
||||
die "No fileno for stderr_write";
|
||||
}
|
||||
}
|
||||
|
||||
select STDOUT; $| = 1;
|
||||
select STDERR; $| = 1;
|
||||
select STDOUT;
|
||||
Win32::Process::Create(
|
||||
$process,
|
||||
$program->[0],
|
||||
"@$program",
|
||||
1,
|
||||
NORMAL_PRIORITY_CLASS,
|
||||
'.'
|
||||
) or do {
|
||||
open STDOUT, ">&STDOUT_SAVE";
|
||||
open STDERR, ">&STDERR_SAVE";
|
||||
open STDIN, "<&STDIN_SAVE";
|
||||
die "can't exec (@$program) using Win32::Process; Reason: ".
|
||||
Win32::FormatMessage(Win32::GetLastError);
|
||||
};
|
||||
syswrite($child->stdin_write, ${$child->stdin}, length(${$child->stdin}), 0)
|
||||
if ref($child->stdin) eq 'SCALAR';
|
||||
open STDOUT, ">&STDOUT_SAVE";
|
||||
open STDERR, ">&STDERR_SAVE";
|
||||
open STDIN, "<&STDIN_SAVE";
|
||||
return $process;
|
||||
}
|
||||
|
||||
sub fork_code {
|
||||
# ------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
# Hack to keep from forking too many process too fast, perl on windows
|
||||
# tends to segv when that happens
|
||||
select undef, undef, undef, 0.5;
|
||||
|
||||
# So we know when the child is finished setting up
|
||||
my $mutex = new Win32::Mutex(1, 'CHILD');
|
||||
my $pid;
|
||||
if ($pid = fork) { # Parent
|
||||
my $child = $self->{current_child};
|
||||
$mutex->wait(2000);
|
||||
print {$child->stdin_write} ${$child->stdin}
|
||||
if ref($child->stdin) eq 'SCALAR';
|
||||
return $pid;
|
||||
}
|
||||
else {
|
||||
$self->fatal( FORK => "$!" ) unless defined $pid;
|
||||
$self->debug("Forked: $$\n") if $self->{_debug} > 1;
|
||||
|
||||
# Hack to keep the child from destroying the mutex
|
||||
{
|
||||
package GT::IPC::Run::Mutex;
|
||||
@GT::IPC::Run::Mutex::ISA = 'Win32::Mutex';
|
||||
sub DESTROY {}
|
||||
}
|
||||
bless $mutex, 'GT::IPC::Run::Mutex';
|
||||
|
||||
my $child = $self->{current_child};
|
||||
my ($stdout, $stderr, $stdin) = (
|
||||
$child->stdout_write,
|
||||
$child->stderr_write,
|
||||
$child->stdin_read
|
||||
);
|
||||
|
||||
# Redirect STDOUT to the write end of the stdout pipe.
|
||||
if (defined $stdout) {
|
||||
*STDOUT = $stdout;
|
||||
$self->debug("stdout opened") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Redirect STDIN from the read end of the stdin pipe.
|
||||
if (defined $stdin) {
|
||||
*STDIN = $stdin;
|
||||
$self->debug("stdin opened") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Redirect STDERR to the write end of the stderr pipe.
|
||||
if (defined $stderr) {
|
||||
*STDERR = $stderr;
|
||||
}
|
||||
|
||||
select STDERR; $| = 1;
|
||||
select STDOUT; $| = 1;
|
||||
|
||||
# Tell the parent that the stdio has been set up.
|
||||
$mutex->release;
|
||||
|
||||
# Launch the code reference
|
||||
$child->program->();
|
||||
close STDOUT if defined fileno STDOUT;
|
||||
close STDERR if defined fileno STDERR;
|
||||
exit(0);
|
||||
}
|
||||
}
|
||||
|
||||
sub do_one_loop {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $wait) = @_;
|
||||
$wait = 0.05 unless defined $wait;
|
||||
|
||||
$self->check_for_exit;
|
||||
$self->debug(
|
||||
"Children: ". keys(%{$self->{children}}).
|
||||
"; goners: ". keys(%{$self->{goners}})
|
||||
) if $self->{_debug};
|
||||
|
||||
for my $pid (keys %{$self->{children}}) {
|
||||
my $child = $self->{children}{$pid};
|
||||
|
||||
if ($child->stdout_read) {
|
||||
my $ret = sysread($child->stdout_read, my $buff, READ_BLOCK);
|
||||
if (!$ret) {
|
||||
# Fun stuff with win32
|
||||
if ($! == EAGAIN) {
|
||||
# Socket error
|
||||
#$self->{select}->remove_stdout($pid);
|
||||
$self->debug(
|
||||
"1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug};
|
||||
}
|
||||
elsif ($! == WSAEWOULDBLOCK and exists $self->{goners}{$pid}) {
|
||||
$child->{socket_err}++;
|
||||
$self->debug(
|
||||
"2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug} > 1;
|
||||
}
|
||||
else {
|
||||
$child->{socket_err}++;
|
||||
$self->debug(
|
||||
"2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug} > 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Process callbacks
|
||||
$self->debug("[$pid STDOUT]: `$buff'\n") if $self->{_debug} > 1;
|
||||
if (defined $child->handler_stdout) {
|
||||
$child->handler_stdout->put(\$buff);
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($child->stderr_read) {
|
||||
my $ret = sysread($child->stderr_read, my $buff, READ_BLOCK);
|
||||
if (!$ret) {
|
||||
# Fun stuff with win32
|
||||
if ($! == EAGAIN) {
|
||||
# Socket error
|
||||
#$self->{select}->remove_stderr($pid);
|
||||
$self->debug(
|
||||
"1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug};
|
||||
}
|
||||
elsif ($! == WSAEWOULDBLOCK and exists $self->{goners}{$pid}) {
|
||||
$child->{socket_err}++;
|
||||
$self->debug(
|
||||
"2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug} > 1;
|
||||
}
|
||||
else {
|
||||
$child->{socket_err}++;
|
||||
$self->debug(
|
||||
"2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ".(0+$!)."; OSErrno: ".(0+$^E)
|
||||
) if $self->{_debug} > 1;
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Process callbacks
|
||||
$self->debug("[$pid STDERR]: `$buff'\n") if $self->{_debug} > 1;
|
||||
if (defined $child->handler_stderr) {
|
||||
$child->handler_stderr->put(\$buff);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
# Call the "done" callback for anything that has exited and has no pending output
|
||||
my %not_pending = %{$self->{children}};
|
||||
for my $child (values %{$self->{children}}) {
|
||||
if ($child->{socket_err} >= 2) {
|
||||
delete $not_pending{$child->{pid}};
|
||||
}
|
||||
}
|
||||
for my $pid (keys %{$self->{goners}}) {
|
||||
my $child = $self->{children}{$pid} or next;
|
||||
if ($not_pending{$pid} and not $child->called_done) {
|
||||
$child->done_callback->($pid, $self->{goners}{$pid})
|
||||
if $child->done_callback;
|
||||
$child->called_done(1);
|
||||
}
|
||||
}
|
||||
|
||||
my $done;
|
||||
for my $child (values %{$self->{children}}) {
|
||||
if ($child->{socket_err} >= 2) {
|
||||
$done++;
|
||||
}
|
||||
}
|
||||
if ($done == keys %{$self->{children}} and (keys(%{$self->{children}}) <= keys(%{$self->{goners}}))) {
|
||||
# We still have children out there
|
||||
if (keys(%{$self->{children}}) > keys(%{$self->{goners}})) {
|
||||
$self->debug("We still have children") if $self->{_debug};
|
||||
return 1;
|
||||
}
|
||||
|
||||
$self->debug("Nothing else to do, flushing buffers")
|
||||
if $self->{_debug};
|
||||
|
||||
# Flush output filters
|
||||
for my $pid (keys %{$self->{children}}) {
|
||||
my $child = delete $self->{children}{$pid};
|
||||
$self->select->remove_stdout($pid);
|
||||
$self->select->remove_stderr($pid);
|
||||
if ($child->handler_stdout) {
|
||||
$child->handler_stdout->flush;
|
||||
}
|
||||
if ($child->handler_stderr) {
|
||||
$child->handler_stderr->flush;
|
||||
}
|
||||
}
|
||||
|
||||
# Nothing left to do
|
||||
$self->debug("Returning 0") if $self->{_debug};
|
||||
return 0;
|
||||
}
|
||||
|
||||
# for my $pid (@$stdout_pending) {
|
||||
# my $child = $self->{children}{$pid};
|
||||
# $self->debug("STDOUT pending for $pid") if $self->{_debug};
|
||||
#
|
||||
# my $ret = sysread($child->stdout_read, my $buff, READ_BLOCK);
|
||||
# if (!$ret) {
|
||||
# # Fun stuff with win32
|
||||
# if ($! != EAGAIN and $! != WSAEWOULDBLOCK) {
|
||||
# # Socket error
|
||||
# $self->{select}->remove_stdout($pid);
|
||||
# $self->debug("1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E))
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
# else {
|
||||
# $self->debug("2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E))
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
# }
|
||||
# else {
|
||||
# # Process callbacks
|
||||
# $self->debug("[$pid STDOUT]: `$buff'\n") if $self->{_debug} > 1;
|
||||
# if (defined $child->handler_stdout) {
|
||||
# $child->handler_stdout->put(\$buff);
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
#
|
||||
# for my $pid (@$stderr_pending) {
|
||||
# my $child = $self->{children}{$pid};
|
||||
# $self->debug("STDERR pending for $pid") if $self->{_debug};
|
||||
#
|
||||
# my $ret = sysread($child->stderr_read, my $buff, READ_BLOCK);
|
||||
# if (!$ret) {
|
||||
# # Fun stuff with win32
|
||||
# if ($! != EAGAIN and $! != WSAEWOULDBLOCK) {
|
||||
# # Socket error
|
||||
# $self->{select}->remove_stderr($pid);
|
||||
# $self->debug("1: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E))
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
# else {
|
||||
# $self->debug("2: $pid: Socket Read: Error: $!; OSError: $^E; Errno: ", (0+$!), "; OSErrno: ", (0+$^E))
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
# }
|
||||
# else {
|
||||
# # Process callbacks
|
||||
# $self->debug("[$pid STDERR]: `$buff'\n") if $self->{_debug} > 1;
|
||||
# if (defined $child->handler_stderr) {
|
||||
# $child->handler_stderr->put(\$buff);
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
return 1;
|
||||
}
|
||||
|
||||
my $warned;
|
||||
sub check_for_exit {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
# This process was created with Win32::Process. The problem is
|
||||
# there is no way to reliably get the output from a Win32::Process
|
||||
# program in a loop like this. Output handles are not flushed when
|
||||
# process exits, which means that if it blocks a little we will
|
||||
# likly lose the last output it produces, this is so not nice.
|
||||
for my $pid (keys %{$self->{children}}) {
|
||||
my $child = $self->{children}{$pid};
|
||||
next if exists $self->{goners}{$pid};
|
||||
|
||||
if ($child->forked) {
|
||||
# Check if the program exited
|
||||
my $got_pid;
|
||||
my $waited = waitpid($pid, WNOHANG);
|
||||
my $killed = 1;
|
||||
$self->debug("waited: $waited; pid: $pid")
|
||||
if $self->{_debug};
|
||||
if ($waited < -1) {
|
||||
$self->{goners}{$pid} = $?;
|
||||
$child->exit_callback->($pid, $?)
|
||||
if $child->exit_callback;
|
||||
$self->debug(
|
||||
"forked child $pid exited with exit status (".
|
||||
($self->{goners}{$pid} >> 8).
|
||||
")\n"
|
||||
) if $self->{_debug};
|
||||
}
|
||||
elsif ($waited == -1) {
|
||||
$self->{goners}{$pid} = 0;
|
||||
$child->exit_callback->($pid, 0)
|
||||
if $child->exit_callback;
|
||||
}
|
||||
# elsif ($waited == -1) {
|
||||
# for my $pid (keys %{$self->{children}}) {
|
||||
# $self->{select}->remove_stdout($pid);
|
||||
# $self->{select}->remove_stderr($pid);
|
||||
# unless (exists $self->{goners}{$pid}) {
|
||||
# $self->{goners}{$pid} = -1;
|
||||
# $self->{children}{$pid}{exit_callback}->($pid, -1)
|
||||
# if $self->{children}{$pid}{exit_callback};
|
||||
# }
|
||||
# }
|
||||
# }
|
||||
# elsif (!$killed) {
|
||||
# $self->{goners}{$pid} = -1;
|
||||
# $self->{children}{$pid}{exit_callback}->($pid, -1)
|
||||
# if $self->{children}{$pid}{exit_callback};
|
||||
# $self->debug( "Could not get exit status of $pid")
|
||||
# if $self->{_debug};
|
||||
# }
|
||||
}
|
||||
else {
|
||||
|
||||
$self->debug("Checking if $pid is running") if $self->{_debug};
|
||||
if ($child->process and $child->process->Wait(0)) {
|
||||
$self->{goners}{$pid} = '';
|
||||
my $exit_code;
|
||||
$child->process->GetExitCode($exit_code);
|
||||
$self->{goners}{$pid} = $exit_code << 8;
|
||||
$child->exit_callback->($pid, ($exit_code << 8))
|
||||
if $child->exit_callback;
|
||||
$self->debug("$pid exited with status: $self->{goners}{$pid}")
|
||||
if $self->{_debug};
|
||||
}
|
||||
elsif ($self->{_debug}) {
|
||||
$self->debug("$pid is still running");
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub oneway {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
$self->SUPER::oneway('inet');
|
||||
}
|
||||
|
||||
sub twoway {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self) = @_;
|
||||
$self->SUPER::twoway('inet');
|
||||
}
|
||||
|
||||
sub stop_blocking {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $socket_handle) = @_;
|
||||
my $set_it = "1";
|
||||
|
||||
# 126 is FIONBIO (some docs say 0x7F << 16)
|
||||
ioctl( $socket_handle,
|
||||
0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
|
||||
$set_it
|
||||
) or die "ioctl: $^E";
|
||||
}
|
||||
|
||||
sub start_blocking {
|
||||
# ------------------------------------------------------------------------
|
||||
my ($self, $socket_handle) = @_;
|
||||
my $unset_it = "0";
|
||||
|
||||
# 126 is FIONBIO (some docs say 0x7F << 16)
|
||||
ioctl( $socket_handle,
|
||||
0x80000000 | (4 << 16) | (ord('f') << 8) | 126,
|
||||
$unset_it
|
||||
) or die "ioctl: $^E";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
172
site/slowtwitch.com/cgi-bin/articles/GT/IPCountry.pm
Normal file
172
site/slowtwitch.com/cgi-bin/articles/GT/IPCountry.pm
Normal file
@ -0,0 +1,172 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::IPCountry
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: IPCountry.pm,v 1.1 2006/01/31 00:45:04 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Attempts to look up an IP's country using a variety of common CPAN modules.
|
||||
#
|
||||
|
||||
package GT::IPCountry;
|
||||
use strict;
|
||||
require Exporter;
|
||||
|
||||
use vars qw/@EXPORT @ISA %MODULE/;
|
||||
|
||||
@ISA = 'Exporter';
|
||||
@EXPORT = 'ip_to_country';
|
||||
|
||||
sub lookup_possible () {
|
||||
_load_module() if not defined $MODULE{loaded};
|
||||
return $MODULE{loaded};
|
||||
}
|
||||
|
||||
sub ip_to_country ($) {
|
||||
my $ip = shift;
|
||||
|
||||
lookup_possible or return (undef, undef);
|
||||
|
||||
my $country;
|
||||
|
||||
if ($MODULE{geoip}) { # Geo::IP
|
||||
$country = $MODULE{geoip}->country_name_by_addr($ip);
|
||||
}
|
||||
elsif ($MODULE{ipc}) { # IP::Country & Geography::Countries
|
||||
$country = $MODULE{ipc}->inet_ntocc(Socket::inet_aton($ip));
|
||||
my %special = ( # Special codes returned that G::C can't handle:
|
||||
AP => 'non-specific Asia-Pacific location',
|
||||
CS => 'Czechoslovakia (former)',
|
||||
EU => 'non-specific European Union location',
|
||||
FX => 'France, Metropolitan',
|
||||
PS => 'Palestinian Territory, Occupied',
|
||||
'**' => 'Intranet address'
|
||||
);
|
||||
if ($special{$country}) { $country = $special{$country} }
|
||||
elsif ($MODULE{geoc}) {
|
||||
$country = Geography::Countries::country($country) || $country;
|
||||
}
|
||||
}
|
||||
elsif ($MODULE{geoipfree}) { # Geo::IPfree
|
||||
$country = ($MODULE{geoipfree}->LookUp($ip))[1];
|
||||
}
|
||||
|
||||
return wantarray ? ($country, 1) : $country;
|
||||
}
|
||||
|
||||
# Attempts to load various CPAN modules capable of going the IP -> country
|
||||
# lookup. Sets $MODULE{loaded} to 1 if at least one of the modules was found,
|
||||
# sets to 0 if none were loadable.
|
||||
sub _load_module {
|
||||
|
||||
if (!defined $MODULE{geoip}) {
|
||||
$MODULE{geoip} = eval { require Geo::IP; Geo::IP->new(Geo::IP::GEOIP_STANDARD()) } || 0;
|
||||
if (!$MODULE{geoip}) {
|
||||
$MODULE{geoipfree} = 0 && eval { require Geo::IPfree; Geo::IPfree->new } || 0;
|
||||
}
|
||||
if (!$MODULE{geoip}) {
|
||||
$MODULE{ipc} = eval { require IP::Country::Fast; IP::Country::Fast->new } || 0;
|
||||
}
|
||||
if ($MODULE{ipc}) {
|
||||
require Socket;
|
||||
$MODULE{geoc} = eval { require Geography::Countries } || 0;
|
||||
}
|
||||
if (!$MODULE{ipc} and !$MODULE{geoipfree}) {
|
||||
$MODULE{geoipfree} = 0 && eval { require Geo::IPfree; Geo::IPfree->new } || 0;
|
||||
}
|
||||
}
|
||||
|
||||
$MODULE{loaded} = $MODULE{geoip} || $MODULE{geoipfree} || $MODULE{ipc} ? 1 : 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::IPCountry - Attempts to look up an IP's country using a variety of common
|
||||
CPAN modules.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::IPCountry;
|
||||
|
||||
my $country = ip_to_country("209.139.239.160");
|
||||
|
||||
my ($country, $lookup_okay) = ip_to_country("209.139.239.160");
|
||||
|
||||
my $can_lookup = GT::IPCountry::lookup_possible();
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module takes an IP address and returns the country name the IP is reserved
|
||||
for. This module itself does no actual lookup, but is simply a wrapper around
|
||||
serveral CPAN modules. If none of the modules are available, it simply returns
|
||||
the value C<undef>.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
=head2 ip_to_country
|
||||
|
||||
This method takes a country name and returns two elements: the country name,
|
||||
and a true/false value indicating whether one of the lookup modules was
|
||||
available. In scalar context just the country name is returned. A country
|
||||
name of C<undef> indicates that either the IP wasn't found, or no lookup module
|
||||
was available.
|
||||
|
||||
C<ip_to_country> is exported by default.
|
||||
|
||||
=head2 lookup_possible
|
||||
|
||||
This method returns a true/false value indicating whether or not an IP ->
|
||||
Country lookup can be done. It corresponds directly to the second return value
|
||||
of C<ip_to_country>.
|
||||
|
||||
=head1 MODULES
|
||||
|
||||
GT::IPCountry attempts to use the following modules, in order, to perform a
|
||||
country lookup:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Geo::IP
|
||||
|
||||
Uses Geo::IP for the lookup.
|
||||
|
||||
=item IP::Country
|
||||
|
||||
Uses IP::Country for the lookup. Note that because IP::Country only returns a
|
||||
country code, this module will attempt to use Geography::Countries to determine
|
||||
the country name. If Geography::Countries isn't installed, you'll just get a
|
||||
country code.
|
||||
|
||||
=item Geo::IPfree
|
||||
|
||||
Uses Geo::IPfree for the lookup.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Geo::IP>
|
||||
|
||||
L<Geo::IPfree>
|
||||
|
||||
L<IP::Country>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: IPCountry.pm,v 1.1 2006/01/31 00:45:04 jagerman Exp $
|
||||
|
||||
=cut
|
||||
684
site/slowtwitch.com/cgi-bin/articles/GT/Image/Security.pm
Normal file
684
site/slowtwitch.com/cgi-bin/articles/GT/Image/Security.pm
Normal file
@ -0,0 +1,684 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Image::Security
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Security.pm,v 1.3 2006/11/03 18:55:35 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Creates an image with specified text with mild
|
||||
# alterations to rendered text and background to
|
||||
# reduce machine legibility.
|
||||
#
|
||||
|
||||
package GT::Image::Security;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $ERRORS $DEBUG/;
|
||||
use GT::Base;
|
||||
|
||||
$DEBUG = 0;
|
||||
@ISA = 'GT::Base';
|
||||
|
||||
$ATTRIBS = {
|
||||
text => '',
|
||||
|
||||
height => undef, # undef == automatic
|
||||
width => undef, # undef == automatic
|
||||
image_type => undef, # undef == automatic
|
||||
|
||||
fonts_path => undef,
|
||||
|
||||
# Since this module will probably be working with the Bitstream fonts,
|
||||
# the module by default has the settings to remove the fonts that are
|
||||
# difficult to read
|
||||
exclude_fonts => [qw( Vera.ttf VeraIt.ttf VeraMoIt.ttf VeraMono.ttf VeraSe.ttf )],
|
||||
|
||||
# The number of steps each colour has. As truecolour
|
||||
# is not being used automatically, 5 appears to be safest
|
||||
# value that regresses nicely across versions
|
||||
colour_steps => 5,
|
||||
|
||||
# invert the intensity colours on the image?
|
||||
invert => undef, # undef == automatic
|
||||
|
||||
max_x_wobble => 20,
|
||||
max_y_wobble => 20,
|
||||
max_ang_wobble => 30,
|
||||
base_pt => 30,
|
||||
max_pt_wobble => 15,
|
||||
max_obfuscates => undef, # undef == automatic
|
||||
padding => 10,
|
||||
|
||||
display_chars => undef, # undef == automatic
|
||||
|
||||
# The following attributes are listed reference just as
|
||||
# purposes. They shouldn't be used by the invoking application.
|
||||
_use_ttf => 1,
|
||||
_fonts => undef,
|
||||
_keyimage => undef,
|
||||
};
|
||||
|
||||
$ERRORS = {
|
||||
IMG_GD_FAIL => 'Could not load GD. (%s)',
|
||||
IMG_FONT_PATH => 'Could not open font path (%s)',
|
||||
IMG_INIT_FAIL => 'Could not initialize image.',
|
||||
IMG_TYPE_FAIL => 'Could not determine if GD could render an image',
|
||||
IMG_DRAW_FAIL => 'Could not draw image because (%s).',
|
||||
IMG_DATA_FAIL => 'Could not generate data for image because (%s)'
|
||||
};
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------------------
|
||||
# Test to make sure GD is available on the system. If not, returns
|
||||
# undef and records the error
|
||||
#
|
||||
my $class = shift;
|
||||
local $@;
|
||||
eval { require GD };
|
||||
return $class->warn( IMG_GD_FAIL => "$@" ) if $@;
|
||||
return $class->SUPER::new( @_ );
|
||||
}
|
||||
|
||||
sub init_fonts {
|
||||
# -------------------------------------------------------------------
|
||||
# This loads the fonts, tests to see if the system can handle truetype
|
||||
# and if it can't, switches the system over to internal fonts
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Find out if this system allows ttf to be used.
|
||||
my $use_ttf = UNIVERSAL::can( 'GD::Image', 'stringFT' );
|
||||
|
||||
my @fonts;
|
||||
|
||||
# If the GD module supports the stringFT function
|
||||
# which is used to render TrueType fonts onto the
|
||||
# image, let's see if we can load a couple of TTF files
|
||||
if ( $use_ttf and defined $self->{fonts_path} ) {
|
||||
my $exclude_font_lookup = {
|
||||
map {( lc $_ => 1 )} @{$self->{exclude_fonts}}
|
||||
};
|
||||
|
||||
$self->debug( "Trying to load fonts from path: $self->{fonts_path}" ) if $self->{_debug};
|
||||
|
||||
-d $self->{fonts_path} or return $self->warn( IMG_FONT_PATH => $self->{fonts_path} );
|
||||
opendir( FONTSDIR, $self->{fonts_path} ) or return $self->warn( IMG_FONT_PATH => "$!" );
|
||||
|
||||
while ( my $f = readdir FONTSDIR ) {
|
||||
next unless $f =~ /\.ttf/i;
|
||||
next if $exclude_font_lookup->{lc $f};
|
||||
push @fonts, "$self->{fonts_path}/$f";
|
||||
}
|
||||
closedir FONTSDIR;
|
||||
|
||||
# Check to see that using the TTF support causes no errors
|
||||
# We do this buy just faking a request to the function which
|
||||
# simply returns. If there was an error, it should be set in
|
||||
# $@
|
||||
if ( @fonts ) {
|
||||
GD::Image->stringFT( 0, $fonts[0], 12, 0, 0, 0, 'GT' );
|
||||
$@ and $use_ttf = 0;
|
||||
}
|
||||
|
||||
unless ( defined $self->{max_obfuscates} ) {
|
||||
$self->{max_obfuscates} = 10;
|
||||
}
|
||||
}
|
||||
|
||||
# Something didn't work in our attempt to use the TTF features
|
||||
# we'll setup to use just the standard built in font faces
|
||||
# though they may be easily cracked with an OCR based system.
|
||||
unless ( @fonts and $use_ttf ) {
|
||||
|
||||
# change the max obfuscations to 3 as 10 would obliterate
|
||||
# the legibility of the text
|
||||
unless ( defined $self->{max_obfuscates} ) {
|
||||
$self->{max_obfuscates} = 3;
|
||||
}
|
||||
@fonts = (
|
||||
GD::gdGiantFont(),
|
||||
# The next set of fonts are far too small
|
||||
# to be legible. The "Giant" font is rather
|
||||
# tiny on the screen as well.
|
||||
# GD::gdLargeFont()
|
||||
# GD::gdSmallFont()
|
||||
# GD::gdTinyFont()
|
||||
);
|
||||
|
||||
$use_ttf = 0;
|
||||
}
|
||||
|
||||
# Debug output
|
||||
if ( $self->{_debug} ) {
|
||||
if ( $use_ttf ) {
|
||||
$self->debug( "Using Truetype Fonts. The following fonts are loaded:" );
|
||||
foreach my $font ( @fonts ) {
|
||||
$self->debug( " $font" );
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->debug( "Using internal Fonts." );
|
||||
}
|
||||
}
|
||||
|
||||
$self->{_use_ttf} = $use_ttf;
|
||||
$self->{_fonts} = \@fonts;
|
||||
}
|
||||
|
||||
sub init_image {
|
||||
# --------------------------------------------------
|
||||
# Create the image and fill in the background. Has
|
||||
# a secondary effect of initializing the text
|
||||
# string and calculating bounds on each character.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
$self->{_keyimage} and return $self->{_keyimage};
|
||||
|
||||
my ( $mx, $my ) = $self->calculate_bounds( @_ ) or return;
|
||||
|
||||
my $keyimage_width = $self->{width} ||= $mx + $self->{padding} * 2,
|
||||
my $keyimage_height = $self->{height} ||= $my + $self->{padding} * 2;
|
||||
|
||||
my $keyimage = $self->{_keyimage} = GD::Image->new(
|
||||
$keyimage_width,
|
||||
$keyimage_height
|
||||
) or return $self->warn( 'IMG_INIT_FAIL' );
|
||||
|
||||
$keyimage->fill(
|
||||
0, # x position to flood from
|
||||
0, # y position to flood from
|
||||
$self->get_random_colour( -0.2 )
|
||||
);
|
||||
|
||||
return $keyimage;
|
||||
}
|
||||
|
||||
sub init_chars {
|
||||
# --------------------------------------------------
|
||||
# This will take the text to be rendered and randomly
|
||||
# choose values on how they will be rendered.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
$self->{text} = shift if @_;
|
||||
my $text = $self->{text} or return;
|
||||
|
||||
my @display_chars;
|
||||
|
||||
my $fonts = $self->init_fonts or return;
|
||||
|
||||
foreach my $ch ( split //, $text ) {
|
||||
|
||||
# setup variable entities wobble
|
||||
my $f = $fonts->[int( @$fonts * rand )];
|
||||
my $a = ( $self->{max_ang_wobble} * ( 0.5 - rand() ) ) * 0.01745;
|
||||
my $y = int( rand() * $self->{max_y_wobble} );
|
||||
my $x = int( rand() * $self->{max_x_wobble} );
|
||||
my $p = $self->{base_pt} + ( int( $self->{max_pt_wobble} * ( 0.5 - rand() ) ) );
|
||||
|
||||
# the new character record.
|
||||
my $char_rec = {
|
||||
char => $ch,
|
||||
font => $f,
|
||||
angle => $a,
|
||||
xoffset => $x,
|
||||
yoffset => $y,
|
||||
point => $p,
|
||||
};
|
||||
|
||||
push @display_chars, $char_rec;
|
||||
}
|
||||
|
||||
$self->{display_chars} = \@display_chars;
|
||||
}
|
||||
|
||||
sub init_colour_matrix {
|
||||
# --------------------------------------------------
|
||||
# This creates an NxNxN colour lookup matrix where
|
||||
# N is equal to $self->{colour_steps}. This allows
|
||||
# the fetching of colours quickly without need to
|
||||
# create the colour entry in the swatch.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# create the colour maps for the image
|
||||
my $colour_steps = $self->{colour_steps};
|
||||
my $fraction = 255 / $colour_steps;
|
||||
|
||||
my $colour_map = [];
|
||||
for my $r ( 0..$colour_steps ) {
|
||||
for my $g ( 0..$colour_steps ) {
|
||||
for my $b ( 0..$colour_steps ) {
|
||||
my @rgb = map { int( $_ * $fraction ) } ( $r, $g, $b );
|
||||
$colour_map->[$r][$g][$b] = $self->{_keyimage}->colorAllocate( @rgb );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# do we want to invert the colours with the randomizer?
|
||||
unless ( defined $self->{invert} ) {
|
||||
$self->{invert} = rand > 0.5 ? 1 : 0;
|
||||
}
|
||||
|
||||
$self->{colour_map} = $colour_map;
|
||||
}
|
||||
|
||||
sub draw_image {
|
||||
# --------------------------------------------------
|
||||
# This method does the actual work of putting the
|
||||
# characters onto a prepared image.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $display_chars = $self->{display_chars};
|
||||
my $keyimage = $self->init_image or return;
|
||||
|
||||
my $offset = $self->{padding};
|
||||
my $obfuscate_count = 0;
|
||||
|
||||
# If we have TTF support use that as the display
|
||||
# chars have been prepared with TTF support in mind
|
||||
if ( $self->{_use_ttf} ) {
|
||||
local $@;
|
||||
|
||||
foreach my $char_rec ( @$display_chars ) {
|
||||
$keyimage->stringFT(
|
||||
$self->get_random_colour( 0.6 ),
|
||||
$char_rec->{font},
|
||||
$char_rec->{point},
|
||||
$char_rec->{angle},
|
||||
$offset,
|
||||
$char_rec->{yoffset} + $self->{padding},
|
||||
$char_rec->{char}
|
||||
);
|
||||
|
||||
return $self->warn( IMG_DRAW_FAIL => "$@" ) if $@;
|
||||
|
||||
$offset += $char_rec->{xoffset};
|
||||
|
||||
if ( $obfuscate_count++ < $self->{max_obfuscates} ) {
|
||||
$self->obfuscate_image;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Unfortunately, TTF support is not available so attempt
|
||||
# to regress as nicely as possible
|
||||
else {
|
||||
foreach my $char_rec ( @$display_chars ) {
|
||||
$keyimage->string(
|
||||
$char_rec->{font},
|
||||
$offset,
|
||||
$char_rec->{yoffset} + $self->{padding},
|
||||
$char_rec->{char},
|
||||
$self->get_random_colour( 0.6 )
|
||||
);
|
||||
|
||||
$offset += $char_rec->{xoffset};
|
||||
}
|
||||
}
|
||||
|
||||
# Finish up the obfuscations
|
||||
while ( $obfuscate_count++ < $self->{max_obfuscates} ) {
|
||||
$self->obfuscate_image;
|
||||
}
|
||||
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub obfuscate_image {
|
||||
# --------------------------------------------------
|
||||
# This randomly applies certain transformations to the
|
||||
# key image to make it harder for machine readability.
|
||||
# To add new obfuscation methods, the easiest way could
|
||||
# be to subclass this module and override this function
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $mode = int( 2 * rand() );
|
||||
|
||||
my $keyimage = $self->init_image or return;
|
||||
my $keyimage_width = $self->{width};
|
||||
my $keyimage_height = $self->{height};
|
||||
|
||||
# Basic line
|
||||
if ( $mode == 1 ) {
|
||||
|
||||
# Find two edges to play with
|
||||
my @edges = sort { $a->[2] <=> $b->[2] } (
|
||||
[ 0, int(rand()*$keyimage_height), rand ], # left
|
||||
[ int(rand()*$keyimage_width), 0, rand], # top
|
||||
[ $keyimage_width, int(rand()*$keyimage_height), rand], # right
|
||||
[ int(rand()*$keyimage_width), $keyimage_height, rand ], # bottom
|
||||
);
|
||||
|
||||
$keyimage->line(
|
||||
@{$edges[0]}[0,1],
|
||||
@{$edges[1]}[0,1],
|
||||
$self->get_random_colour
|
||||
);
|
||||
}
|
||||
|
||||
# Draw a rectangle after acquiring two random points
|
||||
else {
|
||||
my @edges = (
|
||||
int(rand()*$keyimage_width), int(rand()*$keyimage_height),
|
||||
int(rand()*$keyimage_width), int(rand()*$keyimage_height)
|
||||
);
|
||||
|
||||
$keyimage->rectangle(
|
||||
@edges,
|
||||
$self->get_random_colour
|
||||
);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub calculate_char_bounds {
|
||||
# --------------------------------------------------
|
||||
# Finds out the bounds for a single character. Based
|
||||
# upon the setting provided.
|
||||
#
|
||||
my ( $self, $char_rec ) = @_;
|
||||
|
||||
my ( $vx, $vy );
|
||||
|
||||
# Must discern which of the methods are going to be
|
||||
# used to display images.
|
||||
if ( $self->{_use_ttf} ) {
|
||||
|
||||
# calculate bounds
|
||||
my @b = GD::Image->stringFT(
|
||||
0,
|
||||
$char_rec->{font},
|
||||
$char_rec->{point},
|
||||
$char_rec->{angle},
|
||||
$char_rec->{xoffset},
|
||||
$char_rec->{yoffset},
|
||||
$char_rec->{char}
|
||||
);
|
||||
|
||||
# The docs for bounds on stringFT suggested that
|
||||
# the elements should be a bit more ordered but
|
||||
# having had odd experiences with the values. Ensure
|
||||
# value sanity
|
||||
my ( $mxx, $mxy, $mix, $miy ) = (0,0,0,0);
|
||||
for ( my $i = 0; $i < 4 ; $i++ ) {
|
||||
my ( $x, $y ) = @b[$i*2,$i*2+1];
|
||||
$x > $mxx and $mxx = $x;
|
||||
$x < $mix and $mix = $x;
|
||||
$y > $mxy and $mxy = $y;
|
||||
$y < $miy and $miy = $y;
|
||||
}
|
||||
|
||||
$vx = abs( $mxx - $mix );
|
||||
$vy = abs( $mxy - $miy );
|
||||
$char_rec->{yoffset} = $vy;
|
||||
|
||||
}
|
||||
else {
|
||||
my $f = $char_rec->{font};
|
||||
$vx = $f->width() + $char_rec->{xoffset};
|
||||
$vy = $f->height() + $char_rec->{yoffset};
|
||||
}
|
||||
|
||||
$char_rec->{xoffset} = $vx;
|
||||
|
||||
return ( $vx, $vy );
|
||||
}
|
||||
|
||||
sub get_random_colour {
|
||||
# --------------------------------------------------
|
||||
# Returns a random GD image colour to be used in
|
||||
# rendering fonts/lines/etc. The fraction value
|
||||
# is optional and determines what portion of the
|
||||
# palatte will be returned. A -1 < fraction < 0 will use
|
||||
# the brightest n * 100% percent while a 0 < fraction < 1
|
||||
# will consider the darkest n * 100% as possible results
|
||||
#
|
||||
my ( $self, $fraction ) = @_;
|
||||
|
||||
unless ( $self->{colour_map} ) {
|
||||
$self->init_colour_matrix;
|
||||
};
|
||||
|
||||
$fraction ||= 1;
|
||||
$fraction *= ( $self->{invert} ? -1 : 1 );
|
||||
|
||||
my $colour_steps = $self->{colour_steps};
|
||||
|
||||
my @rgb;
|
||||
|
||||
$fraction = $fraction * $colour_steps;
|
||||
if ( $fraction > 0 ) {
|
||||
@rgb = map { int($fraction*rand) } (1,2,3);
|
||||
}
|
||||
else {
|
||||
@rgb = map { int($colour_steps+$fraction*rand) } (1,2,3);
|
||||
}
|
||||
|
||||
return $self->{colour_map}[$rgb[0]][$rgb[1]][$rgb[2]];
|
||||
|
||||
}
|
||||
|
||||
sub calculate_bounds {
|
||||
# --------------------------------------------------
|
||||
# Find out how much space all the text is going to
|
||||
# occupy. This function will determine how large the
|
||||
# image will be.
|
||||
#
|
||||
my $self = shift;
|
||||
my $display_chars = $self->init_chars( @_ ) or return;
|
||||
|
||||
my $my = 0;
|
||||
my $mx = 0;
|
||||
|
||||
for my $char_rec ( @$display_chars ) {
|
||||
my ( $vx, $vy ) = $self->calculate_char_bounds( $char_rec );
|
||||
$mx += $vx;
|
||||
$my < $vy and $my = $vy;
|
||||
}
|
||||
|
||||
return ( $mx, $my )
|
||||
}
|
||||
|
||||
sub image_type {
|
||||
# --------------------------------------------------
|
||||
# Returns the image type of the output format favoured
|
||||
# by GD
|
||||
#
|
||||
my $self = shift;
|
||||
my $keyimage = $self->init_image or return;
|
||||
|
||||
# If the image type has not been predeclared,
|
||||
# attempt to
|
||||
unless ( defined $self->{image_type} ) {
|
||||
$self->{image_type} ||=
|
||||
UNIVERSAL::can( $keyimage, 'png' ) ? 'png' :
|
||||
UNIVERSAL::can( $keyimage, 'gif' ) ? 'gif' :
|
||||
UNIVERSAL::can( $keyimage, 'jpeg' ) ? 'jpeg' :
|
||||
$self->warn( 'IMG_TYPE_FAIL' );
|
||||
}
|
||||
|
||||
return $self->{image_type};
|
||||
}
|
||||
|
||||
sub image_data {
|
||||
# --------------------------------------------------
|
||||
# Returns the data to the image in scalar format. Suitable
|
||||
# for print
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $keyimage = $self->init_image or return;
|
||||
my $image_type = $self->image_type or return;
|
||||
|
||||
$self->draw_image or return;
|
||||
|
||||
local $@;
|
||||
my $data;
|
||||
|
||||
eval { $data = $keyimage->$image_type() };
|
||||
|
||||
$@ and return $self->warn( IMG_DATA_FAIL => "$@" ); # copy value
|
||||
|
||||
return $data;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Image::Security - Using the GD module, creates an image with text.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Image::Security;
|
||||
|
||||
my $sec_image = GT::Image::Security->new(
|
||||
fonts_path => "/home/aki/public_html/fonts",
|
||||
text => "Hello World"
|
||||
) or die $GT::Image::Security::error;
|
||||
|
||||
# some versions have gif, others png
|
||||
my $img_type = $sec_image->image_type();
|
||||
|
||||
print "Content-type: image/$img_type\n\n";
|
||||
print $sec_image->image_data;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Creates an image with specified text with mild alterations to rendered text
|
||||
and background to reduce machine legibility. Whenever it can, it will attempt
|
||||
to use TrueType fonts as the internal fonts tend to be difficult to read
|
||||
and very limited in the number of transformations possible.
|
||||
|
||||
=head1 INTERFACE
|
||||
|
||||
=head2 new
|
||||
|
||||
Creates a new security image handler with all options populated but does
|
||||
not initialize the image. While most option are set by default or automatically,
|
||||
certain behaviours can be forced quite easily by passing in a new value.
|
||||
|
||||
new will return undef if the GD module cannot be loaded. The exact details of the
|
||||
error can be retreived from $GT::Image::Security::error or through the normal
|
||||
GT::Base error function mechanism.
|
||||
|
||||
The following is a list of attributes that can be used to customize the output.
|
||||
|
||||
=over 4
|
||||
|
||||
=item text
|
||||
|
||||
Required. The string to be rendered in the image.
|
||||
|
||||
=item fonts_path
|
||||
|
||||
Optional. Required only if TrueType support is desired, it should be the path to the directory that holds .TTF files.
|
||||
|
||||
=item height
|
||||
|
||||
Optional. Typically automatically calculated, setting this will force the image to the specified height. (Output will be clipped if not tall enough)
|
||||
|
||||
=item width
|
||||
|
||||
Optional. Typically automatically calculated, setting this will force the image to the specified width. (Output will be clipped if not wide enough)
|
||||
|
||||
=item image_type
|
||||
|
||||
Optional. Set to png/jpeg/gif if the output format is important. If GD does not support the rendering method for the type of image, image_data will return undef and an error will be set.
|
||||
|
||||
=item exclude_fonts
|
||||
|
||||
Optional. Arrayref of filenames to ignore when scanning fonts for reasons such as illegibility. By default, the settings have been configured to work with the Bitstream Vera selection of fonts.
|
||||
|
||||
=item colour_steps
|
||||
|
||||
Optional. The number of steps between 0..255 in relation to the brightness of a single colour channel. By default, it has been set to 5 as older GD modules only support 256 colours.
|
||||
|
||||
=item invert
|
||||
|
||||
Optional. Typically automatically chosen, it will invert the colour selections so instead of dark colours for the foreground, brighter colours will be chosen instead. Similarly for the background, from bright, dark colours will be chosen instead.
|
||||
|
||||
=item max_x_wobble
|
||||
|
||||
Optional. Maximum number of pixels to randomly offset characters from ideal position along the horizontal axis.
|
||||
|
||||
=item max_y_wobble
|
||||
|
||||
Optional. Maximum number of pixels to randomly offset characters from ideal position along the vertical axis.
|
||||
|
||||
=item max_ang_wobble
|
||||
|
||||
Optional. Only affects TrueType fonts, internal fonts will not use this feature. The maximum amount of random angular rotation for each character in the text.
|
||||
|
||||
=item base_pt
|
||||
|
||||
Optional. Only affects TrueType fonts, internal fonts will not use this feature. This sets the base point size of the font.
|
||||
|
||||
=item max_pt_wobble
|
||||
|
||||
Optional. Only affects TrueType fonts, internal fonts will not use this feature. The maximum amount of random deviation from the base_pt size for each chacter rendered.
|
||||
|
||||
=item max_obfuscates
|
||||
|
||||
Optional. Usually set automatically, this sets the number of times the obfuscate_image action will be called uon the image. The action randomly draws a line or a rectangle on the image to provide chaff for any attempt to use OCR type software to extract the text from the image.
|
||||
|
||||
=item padding
|
||||
|
||||
Optional. The amount of extra pixel space that should be around the text.
|
||||
|
||||
=item display_chars
|
||||
|
||||
Optional. Typically shouldn't be used. However, it may be useful in situations where you would like to reproduce the image. After image_data has been called, squirrel away the value of $obj->{display_chars} and it will contain all the settings to be able to regenerate the image's core parts. Note: it does not store colour information so while the positions and size of the image would be the same, the colours would be different.
|
||||
|
||||
=back
|
||||
|
||||
=head2 image_type
|
||||
|
||||
Returns the type of image the module will attempt to produce. The results
|
||||
can be "png", "gif", and "jpeg", fit for inserting into a mimetype header.
|
||||
|
||||
If an error occurs in the testing or no rendering methods could be found,
|
||||
the function will return undef. The details on the error can be retrieved
|
||||
through $obj->error
|
||||
|
||||
=head2 image_data
|
||||
|
||||
Returns a scalar with binary data which comprise the image. The image type
|
||||
can be preset via the "image_type" attribute or accertained by the
|
||||
image_type() method.
|
||||
|
||||
If an error occurs in the testing or no rendering methods could be found,
|
||||
the function will return undef. The details on the error can be retrieved
|
||||
through $obj->error
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
GD, http://stein.cshl.org/WWW/software/GD/
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Aki Mimoto
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Security.pm,v 1.3 2006/11/03 18:55:35 brewt Exp $
|
||||
|
||||
=cut
|
||||
1076
site/slowtwitch.com/cgi-bin/articles/GT/Image/Size.pm
Normal file
1076
site/slowtwitch.com/cgi-bin/articles/GT/Image/Size.pm
Normal file
File diff suppressed because it is too large
Load Diff
369
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.cn
Normal file
369
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.cn
Normal file
@ -0,0 +1,369 @@
|
||||
|
||||
%GT::Installer::LANG = (
|
||||
ERR_REQUIRED => "%s <20><><EFBFBD><EFBFBD><EFBFBD>ťաC",
|
||||
ERR_PATH => "<22><><EFBFBD><EFBFBD><EFBFBD>| (%s) <20><><EFBFBD>b<EFBFBD>t<EFBFBD>ΤW",
|
||||
ERR_PATHWRITE => "<22>L<EFBFBD>k<EFBFBD>g<EFBFBD>J<EFBFBD>ؿ<EFBFBD> (%s)<29>C<EFBFBD><43><EFBFBD>]<5D>G (%s)",
|
||||
ERR_PATHCREATE => "<22>L<EFBFBD>k<EFBFBD>إߥؿ<DFA5> (%s)<29>C<EFBFBD><43><EFBFBD>]<5D>G (%s)",
|
||||
ERR_URLFMT => "(%s) <20><><EFBFBD>G<EFBFBD><47><EFBFBD>O<EFBFBD><4F><EFBFBD>T<EFBFBD><54><EFBFBD><EFBFBD><EFBFBD>}",
|
||||
ERR_FTPFMT => "(%s) <20><><EFBFBD>G<EFBFBD><47><EFBFBD>O<EFBFBD><4F><EFBFBD>T<EFBFBD><54> FTP <20><><EFBFBD>m",
|
||||
ERR_EMAILFMT => "(%s) <20><><EFBFBD>G<EFBFBD><47><EFBFBD>O<EFBFBD><4F><EFBFBD>T<EFBFBD><54> email",
|
||||
ERR_SENDMAIL => "<22><><EFBFBD><EFBFBD><EFBFBD>| (%s) <20><><EFBFBD>s<EFBFBD>b<EFBFBD>t<EFBFBD>ΤW<CEA4>εL<CEB5>k<EFBFBD><6B><EFBFBD><EFBFBD>",
|
||||
ERR_SMTP => "(%s) <20><><EFBFBD>O<EFBFBD><4F><EFBFBD>Ī<EFBFBD> SMTP <20>D<EFBFBD><44><EFBFBD>W<EFBFBD><57>",
|
||||
ERR_PERL => "<22><><EFBFBD>V Perl <20><><EFBFBD><EFBFBD><EFBFBD>| (%s) %s",
|
||||
ERR_DIREXISTS => "%s <20>s<EFBFBD>b<EFBFBD>t<EFBFBD>ΤW<CEA4><57><EFBFBD>o<EFBFBD><6F><EFBFBD>O<EFBFBD>@<40>ӥؿ<D3A5><D8BF>A<EFBFBD>L<EFBFBD>k<EFBFBD>Φ<EFBFBD><CEA6>W<EFBFBD>٫إߥؿ<DFA5>",
|
||||
ERR_WRITEOPEN => "<22>L<EFBFBD>k<EFBFBD>}<7D><> %s <20>Ӽg<D3BC>J<EFBFBD><4A><EFBFBD>ơF<C6A1><46><EFBFBD>]<5D>G %s",
|
||||
ERR_READOPEN => "<22>L<EFBFBD>k<EFBFBD>}<7D><> %s <20><>Ū<EFBFBD>X<EFBFBD><58><EFBFBD>ơF<C6A1><46><EFBFBD>]<5D>G %s",
|
||||
ERR_RENAME => "<22>L<EFBFBD>k<EFBFBD>N %s <20><><EFBFBD>s<EFBFBD>R<EFBFBD>W<EFBFBD><57> %s<>F<EFBFBD><46><EFBFBD>]<5D>G %s",
|
||||
ERR_MKDIR => "<22>L<EFBFBD>k mkdir %s<>C<EFBFBD><43><EFBFBD>]<5D>G %s",
|
||||
ENTER_REG => '<27>п<EFBFBD><D0BF>J<EFBFBD>z<EFBFBD><7A><EFBFBD><EFBFBD><EFBFBD>U<EFBFBD><55><EFBFBD>X',
|
||||
REG_NUM => '<27><><EFBFBD>U<EFBFBD><55><EFBFBD>X',
|
||||
ENTER_SENDMAIL => '<27>п<EFBFBD><D0BF>J<EFBFBD>ΨӰe<D3B0>X<EFBFBD>q<EFBFBD>l<EFBFBD><6C> sendmail <20><><EFBFBD>|<7C><> SMTP <20>D<EFBFBD><44><EFBFBD>W<EFBFBD><57>',
|
||||
MAILER => 'Mailer',
|
||||
ENTER_PERL => '<27>п<EFBFBD><D0BF>J<EFBFBD><4A><EFBFBD>V Perl 5 <20><><EFBFBD><EFBFBD><EFBFBD>|',
|
||||
PATH_PERL => 'Perl <20><><EFBFBD>|',
|
||||
CREATE_DIRS => '<27>إߥؿ<DFA5>',
|
||||
INSTALL_CURRUPTED => '
|
||||
install.dat <20><><EFBFBD>G<EFBFBD>w<EFBFBD>l<EFBFBD>a<EFBFBD>C<EFBFBD>нT<D0BD>{<7B>z<EFBFBD>b FTP <20><><EFBFBD>ɮɡB<C9A1>ϥΪ<CFA5><CEAA>O BINARY <20>Ҧ<EFBFBD><D2A6>C<EFBFBD>Ϊ̡A
|
||||
<EFBFBD>z<EFBFBD>U<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ɥi<EFBFBD><EFBFBD><EFBFBD>w<EFBFBD>l<EFBFBD>a<EFBFBD>C<EFBFBD>ЦA<EFBFBD><EFBFBD><EFBFBD><EFBFBD> Gossamer Threads <20>U<EFBFBD><55><EFBFBD>s<EFBFBD><73><EFBFBD>ɮסC
|
||||
|
||||
<EFBFBD>p<EFBFBD>G<EFBFBD>z<EFBFBD>ݭn<EFBFBD><EFBFBD><EFBFBD>U<EFBFBD>A<EFBFBD>Ш<EFBFBD><EFBFBD>G
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
ADMIN_PATH_ERROR => "<22>z<EFBFBD><7A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>J<EFBFBD>ܲ{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> admin <20><><EFBFBD>|",
|
||||
INTRO => '
|
||||
%s Quick Install http://gossamer-threads.com
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved
|
||||
Redistribution in part or in whole strictly prohibited.
|
||||
|
||||
<EFBFBD>ԲӸ<EFBFBD><EFBFBD>ƽаѾ\ LICENSE <20><>
|
||||
',
|
||||
WELCOME => '
|
||||
<EFBFBD>w<EFBFBD><EFBFBD><EFBFBD>ϥ<EFBFBD> %s <20>۰ʦw<CAA6>˨t<CBA8>ΡC<CEA1><43><EFBFBD>w<EFBFBD>˵{<7B><><EFBFBD>N<EFBFBD>|<7C><><EFBFBD><EFBFBD> %s <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ʧ@<40>B
|
||||
<EFBFBD>]<5D>w<EFBFBD>Ҧ<EFBFBD><D2A6>ɮ<EFBFBD><C9AE>v<EFBFBD><76><EFBFBD>B<EFBFBD>Υ<EFBFBD><CEA5>T<EFBFBD><54><EFBFBD>]<5D>w<EFBFBD><77> Perl <20><><EFBFBD><EFBFBD><EFBFBD>|<7C>C
|
||||
|
||||
<EFBFBD>Ĥ@<40>B<EFBFBD>A<EFBFBD>Х<EFBFBD><D0A5><EFBFBD><EFBFBD>J<EFBFBD>H<EFBFBD>U<EFBFBD><55><EFBFBD><EFBFBD><EFBFBD>ơC
|
||||
<EFBFBD>z<EFBFBD>i<EFBFBD>H<EFBFBD>b<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ɭ<EFBFBD><EFBFBD><EFBFBD><EFBFBD>J exit <20><> quit <20>Ө<EFBFBD><D3A8><EFBFBD><EFBFBD>w<EFBFBD>˵{<7B>ǡC
|
||||
',
|
||||
IS_UPGRADE => "<22>аݱz<DDB1>n<EFBFBD>i<EFBFBD><69><EFBFBD><EFBFBD><EFBFBD>s<EFBFBD>w<EFBFBD>˩άO<CEAC>N<EFBFBD>{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ɯšH",
|
||||
ENTER_ADMIN_PATH => "\n<>п<EFBFBD><D0BF>J<EFBFBD>ܲ{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> admin <20><><EFBFBD>|",
|
||||
UNARCHIVING => '<27><><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD><59>',
|
||||
TAR_OPEN => "<22>L<EFBFBD>k<EFBFBD>}<7D><> %s<>C<EFBFBD><43><EFBFBD>]<5D>G %s",
|
||||
TAR_READ => "<22>q %s Ū<>X<EFBFBD><58><EFBFBD>Ʈɵo<C9B5>Ϳ<EFBFBD><CDBF>~<7E>C<EFBFBD><43>Ū<EFBFBD>X %s bytes<65>A<EFBFBD><41><EFBFBD>uŪ<75>X %s.",
|
||||
TAR_BINMODE => "<22>L<EFBFBD>k binmode %s<>C<EFBFBD><43><EFBFBD>]<5D>G %s",
|
||||
TAR_BADARGS => "<22>L<EFBFBD>Ĥơ]arguments<74>^<5E>ǤJ %s<>C<EFBFBD><43><EFBFBD>]<5D>G %s",
|
||||
TAR_CHECKSUM => "<22>ѪR tar <20>ɮɵo<C9B5><6F> Checksum <20><><EFBFBD>~<7E>C<EFBFBD>o<EFBFBD><6F> tar <20>ɫܥi<DCA5><69><EFBFBD>O<EFBFBD>l<EFBFBD>a<EFBFBD>ɮסC\n<><6E><EFBFBD>Y<EFBFBD>G %s\nChecksum<75>G %s\n<>ɮסG %s\n",
|
||||
TAR_NOBODY => "'%s' does not have a body!",
|
||||
TAR_CANTFIND => "<22>b tar <20><><EFBFBD>Y<EFBFBD>ɸ̧䤣<CCA7><E4A4A3><EFBFBD>ɮסG '%s' <20>C",
|
||||
TAR_CHMOD => "<22>L<EFBFBD>k chmod %s<>C<EFBFBD><43><EFBFBD>]<5D>G %s",
|
||||
TAR_DIRFILE => "'%s' <20>s<EFBFBD>b<EFBFBD>ӥB<D3A5>O<EFBFBD><4F><EFBFBD>ɮסC<D7A1>L<EFBFBD>k<EFBFBD>إߥؿ<DFA5>",
|
||||
TAR_MKDIR => "<22>L<EFBFBD>k mkdir %s<>C<EFBFBD><43><EFBFBD>]<5D>G %s",
|
||||
TAR_RENAME => "<22>L<EFBFBD>k<EFBFBD><6B><EFBFBD>s<EFBFBD>R<EFBFBD>W temp <20>ɡG '%s' <20><> tar <20><> '%s'<27>C<EFBFBD><43><EFBFBD>]<5D>G %s",
|
||||
TAR_NOGZIP => "<22>B<EFBFBD>z .tar.gz <20>ɮɡB<C9A1>ݭn Compress::Zlib <20>ҲաC",
|
||||
SKIPPING_FILE => "<22><><EFBFBD>L %s\n",
|
||||
OVERWRITTING_FILE => "<22>\<5C>L %s <20><><EFBFBD><EFBFBD>",
|
||||
SKIPPING_MATCHED => "<22>b<EFBFBD>ŦX<C5A6><58><EFBFBD>ؿ<EFBFBD><D8BF>̲<EFBFBD><CCB2>L %s \n",
|
||||
BACKING_UP_FILE => "<22>s<EFBFBD>@ %s <20>ƥ<EFBFBD>\n",
|
||||
ERR_OPENTAR => '
|
||||
<EFBFBD>L<EFBFBD>k<EFBFBD>}<7D><> install.dat<61>I<EFBFBD>w<EFBFBD>˵{<7B><><EFBFBD>ݭnŪ<6E><C5AA><EFBFBD><EFBFBD><EFBFBD>ɡC<C9A1>нT<D0BD>{<7B><><EFBFBD>ɮצs<D7A6>b<EFBFBD>B<EFBFBD>ɮ<EFBFBD><C9AE>v<EFBFBD><76><EFBFBD>]<5D>w<EFBFBD><77><EFBFBD>T<EFBFBD>C
|
||||
|
||||
<EFBFBD><EFBFBD><EFBFBD>~<7E>T<EFBFBD><54><EFBFBD>G
|
||||
%s
|
||||
|
||||
<EFBFBD>p<EFBFBD>G<EFBFBD>z<EFBFBD>ݭn<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>U<EFBFBD>A<EFBFBD>Ш<EFBFBD><EFBFBD>G
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
ERR_OPENTAR_UNKNOWN => '
|
||||
<EFBFBD>}<7D><> tar <20>ɮɵo<C9B5>ͤF<CDA4><46><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>~<7E>G
|
||||
%s
|
||||
|
||||
<EFBFBD>p<EFBFBD>G<EFBFBD>z<EFBFBD>ݭn<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>U<EFBFBD>A<EFBFBD>Ш<EFBFBD><EFBFBD>G
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
WE_HAVE_IT => "\n<>ڭ̤w<CCA4>`<60><><EFBFBD>F<EFBFBD>Ҧ<EFBFBD><D2A6><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>\n\n",
|
||||
ENTER_STARTS => "\n<><6E> ENTER <20>Ӷi<D3B6><69><EFBFBD>w<EFBFBD>ˡB<CBA1>Ϋ<EFBFBD> CTRL-C <20><><EFBFBD><EFBFBD>",
|
||||
NOW_UNARCHIVING => '
|
||||
|
||||
<EFBFBD>w<EFBFBD>˵{<7B><><EFBFBD>N<EFBFBD>dzƬ<C7B3> %s <20>i<EFBFBD><69><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ʧ@<40>C<EFBFBD>Э@<40>ߵ<EFBFBD><DFB5><EFBFBD>...
|
||||
',
|
||||
UPGRADE_DONE => '
|
||||
|
||||
<EFBFBD><EFBFBD><EFBFBD>߱z<EFBFBD>I<EFBFBD>z<EFBFBD><EFBFBD> %s <20><><EFBFBD><EFBFBD><EFBFBD>w<EFBFBD><77><EFBFBD>\<5C><><EFBFBD>ɯŦ<C9AF> %s <20><><EFBFBD>C<EFBFBD>w<EFBFBD><77><EFBFBD>ɮפw<D7A4>Q<EFBFBD><51><EFBFBD><EFBFBD><EFBFBD>C
|
||||
|
||||
<EFBFBD>p<EFBFBD>G<EFBFBD>z<EFBFBD>ݭn<EFBFBD><EFBFBD><EFBFBD>s<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>w<EFBFBD>ˡA<EFBFBD>Хѱz<EFBFBD>̪<EFBFBD><EFBFBD>U<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ɤ<EFBFBD><EFBFBD>N<EFBFBD>w<EFBFBD><EFBFBD><EFBFBD>ɮ<EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>C
|
||||
',
|
||||
INSTALL_DONE => '
|
||||
|
||||
%s <20>w<EFBFBD><77><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ʧ@<40>C<EFBFBD>w<EFBFBD><77><EFBFBD>ɮפw<D7A4>Q<EFBFBD><51><EFBFBD><EFBFBD><EFBFBD>C
|
||||
<EFBFBD>p<EFBFBD>G<EFBFBD>z<EFBFBD>ݭn<EFBFBD><EFBFBD><EFBFBD>s<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>w<EFBFBD>ˡA<EFBFBD>Хѱz<EFBFBD>̪<EFBFBD><EFBFBD>U<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ɤ<EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>C
|
||||
|
||||
<EFBFBD>Ƶ<EFBFBD><EFBFBD>G<EFBFBD><EFBFBD><EFBFBD>קK<EFBFBD>N<EFBFBD>z<EFBFBD>̪쪺 .tar.gz <20>ɮׯd<D7AF>b<EFBFBD>z<EFBFBD><7A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ؿ<EFBFBD><D8BF><EFBFBD><EFBFBD>I
|
||||
|
||||
',
|
||||
TELNET_ERR => '<27><><EFBFBD>~<7E>G %s',
|
||||
FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title><3E>w<EFBFBD><77><EFBFBD>ϥ<EFBFBD> <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
<20>w<EFBFBD><77></b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2"><3E>w<EFBFBD><77><EFBFBD>ϥ<EFBFBD> <%product%><3E>C<EFBFBD><43><EFBFBD>w<EFBFBD>˵{<7B><><EFBFBD>N<EFBFBD>|<7C><><EFBFBD><EFBFBD> <%product%> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ʧ@<40>B
|
||||
<20>]<5D>w<EFBFBD>Ҧ<EFBFBD><D2A6>ɮ<EFBFBD><C9AE>v<EFBFBD><76><EFBFBD>B<EFBFBD>Υ<EFBFBD><CEA5>T<EFBFBD><54><EFBFBD>]<5D>w<EFBFBD><77> Perl <20><><EFBFBD><EFBFBD><EFBFBD>|<7C>C
|
||||
|
||||
<%error%>
|
||||
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%message%>
|
||||
<tr>
|
||||
<td colspan="2"><font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<20>аݱz<DDB1>n<EFBFBD>@<40><><EFBFBD>s<EFBFBD>w<EFBFBD>˩άO<CEAC>N<EFBFBD>{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ɯšH
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="150"><font face="Tahoma,Arial,Helvetica" size="2"><b><3E><><EFBFBD>s<EFBFBD>w<EFBFBD><77></b></font></td>
|
||||
<td width="300"><font face="Tahoma,Arial,Helvetica" size="2"><input type="radio" name="upgrade_choice" value="No" checked></font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="150"><font face="Tahoma,Arial,Helvetica" size="2"><b><3E><><EFBFBD><EFBFBD><EFBFBD>ɯ<EFBFBD></b></font></td>
|
||||
<td width="300"><font face="Tahoma,Arial,Helvetica" size="2"><input type="radio" name="upgrade_choice" value="Yes"></font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="450" colspan=2><font face="Tahoma,Arial,Helvetica" size="2"><3E>ܲ{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD> admin <20><><EFBFBD>|<7C>]<5D><><EFBFBD><EFBFBD><EFBFBD>ɯš^<5E>G</font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="450" colspan=2><font face="Tahoma,Arial,Helvetica" size="2"><input type="text" name="install_dir" size=40 value="<%install_dir%>"></font></td>
|
||||
</tr>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="<22>U<EFBFBD>@<40>B >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
UPGRADE_FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title><3E>w<EFBFBD><77><EFBFBD>ϥ<EFBFBD> <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<input type=hidden name="upgrade_second" value="1">
|
||||
<input type=hidden name="install_dir" value="<%GT_ADMIN_PATH%>">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
<20>w<EFBFBD><77></b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2"><3E>w<EFBFBD><77><EFBFBD>ϥ<EFBFBD> <%product%><3E>C<EFBFBD><43><EFBFBD>w<EFBFBD>˵{<7B><><EFBFBD>N<EFBFBD>|<7C><><EFBFBD><EFBFBD> <%product%> <20><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ʧ@<40>B
|
||||
<20>]<5D>w<EFBFBD>Ҧ<EFBFBD><D2A6>ɮ<EFBFBD><C9AE>v<EFBFBD><76><EFBFBD>B<EFBFBD>Υ<EFBFBD><CEA5>T<EFBFBD><54><EFBFBD>]<5D>w<EFBFBD><77> Perl <20><><EFBFBD><EFBFBD><EFBFBD>|<7C>C<EFBFBD>b<EFBFBD>i<EFBFBD><69><EFBFBD>U<EFBFBD>@<40>B<EFBFBD><42><EFBFBD>e<EFBFBD>A<EFBFBD>z<EFBFBD><7A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<EFBFBD>H<EFBFBD>U<EFBFBD><55><EFBFBD><EFBFBD><EFBFBD>ơC<C6A1>j<EFBFBD><6A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>쳣<EFBFBD>w<EFBFBD><77><EFBFBD>J<EFBFBD>X<EFBFBD>z<EFBFBD><7A><EFBFBD>w<EFBFBD>]<5D>ȡA
|
||||
<20><><EFBFBD><EFBFBD><EFBFBD>ˬd<CBAC><64><EFBFBD>̬O<CCAC>_<EFBFBD><5F><EFBFBD>T<EFBFBD>C
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%upgrade_form%>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="<22>U<EFBFBD>@<40>B >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
UPGRADE_SECOND_SCREEN_FIRST => '
|
||||
<html>
|
||||
<head>
|
||||
<title><3E>w<EFBFBD><77><EFBFBD>ϥ<EFBFBD> <%product%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
<20>w<EFBFBD><77></b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<20>{<7B>b<EFBFBD><62><EFBFBD>N<EFBFBD>{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>A<EFBFBD>бz<D0B1>@<40>ߵ<EFBFBD><DFB5>ԡA<D4A1><41><EFBFBD>n<EFBFBD><6E><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>C
|
||||
</font></p>
|
||||
</blockquote>
|
||||
</td>
|
||||
</tr></table>
|
||||
<blockquote>
|
||||
<pre>
|
||||
',
|
||||
UPGRADE_SECOND_SCREEN_SECOND => '
|
||||
</pre>
|
||||
</blockquote>
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500"><tr><td>
|
||||
<blockquote>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><br><%product%> <20>w<EFBFBD><77><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ʧ@<40>C
|
||||
|
||||
<%install_message%>
|
||||
|
||||
<p><3E><><EFBFBD>קK<D7A7>N<EFBFBD>z<EFBFBD>̪쪺 .tar.gz <20>ɮׯd<D7AF>b<EFBFBD>z<EFBFBD><7A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ؿ<EFBFBD><D8BF><EFBFBD><EFBFBD>I
|
||||
|
||||
<p><3E>p<EFBFBD>G<EFBFBD>z<EFBFBD><7A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<EFBFBD>A<EFBFBD>z<EFBFBD>i<EFBFBD>H<EFBFBD><48><EFBFBD>ڭ̪<DAAD><a href="http://gossamer-threads.com/perl/gforum/"><3E>䴩<EFBFBD>Q<EFBFBD>װ<EFBFBD></a><3E>M<EFBFBD>D<EFBFBD>䴩<EFBFBD>C
|
||||
<%message%>
|
||||
<br>
|
||||
</td></tr></table>
|
||||
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INSTALL_WARNING => '<p><b>ĵ<>i<EFBFBD>G</b> <20>бN install.cgi <20>M install.dat <20>q<EFBFBD><71><EFBFBD>ؿ<EFBFBD><D8BF><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>C<EFBFBD>N<EFBFBD>o<EFBFBD><6F><EFBFBD>ɮׯd<D7AF>b<EFBFBD>o<EFBFBD>̱N<CCB1>ް_<DEB0>w<EFBFBD><77><EFBFBD>W<EFBFBD><57><EFBFBD>ü{<7B>C',
|
||||
INSTALL_REMOVED => '<p><3E>w<EFBFBD><77><EFBFBD>ɮפw<D7A4>Q<EFBFBD><51><EFBFBD><EFBFBD><EFBFBD>C<EFBFBD>p<EFBFBD>G<EFBFBD>z<EFBFBD>ݭn<DDAD><6E><EFBFBD>s<EFBFBD><73><EFBFBD><EFBFBD><EFBFBD>w<EFBFBD>ˡA<CBA1>Хѱz<D1B1>̪<EFBFBD><CCAA>U<EFBFBD><55><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ɤ<EFBFBD><C9A4><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>C',
|
||||
|
||||
OVERWRITE => '<27>\<5C>L\n',
|
||||
BACKUP => '<27>ƥ<EFBFBD>',
|
||||
SKIP => '<27><><EFBFBD>L',
|
||||
INSTALL_FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title><3E>w<EFBFBD><77><EFBFBD>ϥ<EFBFBD> <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<input type=hidden name="install" value="1">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
<20>w<EFBFBD><77></b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2"><3E>w<EFBFBD><77><EFBFBD>ϥ<EFBFBD> <%product%><3E>C<EFBFBD><43><EFBFBD>w<EFBFBD>˵{<7B><><EFBFBD>N<EFBFBD>|<7C><><EFBFBD><EFBFBD> <%product%><3E><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ʧ@<40>B<EFBFBD>]<5D>w<EFBFBD>Ҧ<EFBFBD><D2A6>ɮ<EFBFBD><C9AE>v<EFBFBD><76><EFBFBD>B
|
||||
<20>Υ<EFBFBD><CEA5>T<EFBFBD><54><EFBFBD>]<5D>w<EFBFBD><77> Perl <20><><EFBFBD><EFBFBD><EFBFBD>|<7C>C <20>b<EFBFBD>i<EFBFBD><69><EFBFBD>U<EFBFBD>@<40>B<EFBFBD><42><EFBFBD>e<EFBFBD>A<EFBFBD>z<EFBFBD><7A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<EFBFBD>H<EFBFBD>U<EFBFBD><55><EFBFBD><EFBFBD><EFBFBD>ơC<C6A1>j<EFBFBD><6A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>쳣<EFBFBD>w<EFBFBD><77><EFBFBD>J<EFBFBD>X<EFBFBD>z<EFBFBD><7A><EFBFBD>w<EFBFBD>]<5D>ȡA<C8A1><41><EFBFBD><EFBFBD><EFBFBD>ˬd<CBAC><64><EFBFBD>̬O<CCAC>_<EFBFBD><5F><EFBFBD>T<EFBFBD>C
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%form%>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="<22>U<EFBFBD>@<40>B >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INSTALL_SECOND_SCREEN_FIRST => '
|
||||
<html>
|
||||
<head>
|
||||
<title><3E>w<EFBFBD><77><EFBFBD>ϥ<EFBFBD> <%product%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
<20>w<EFBFBD><77></b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<20>{<7B>b<EFBFBD><62><EFBFBD>N<EFBFBD>{<7B><><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>C<EFBFBD>бz<D0B1>@<40>ߵ<EFBFBD><DFB5>ԡA<D4A1><41><EFBFBD>n<EFBFBD><6E><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>C
|
||||
</font></p>
|
||||
</blockquote>
|
||||
</td>
|
||||
</tr></table>
|
||||
<blockquote>
|
||||
<pre>
|
||||
',
|
||||
INSTALL_SECOND_SCREEN_SECOND => '
|
||||
</pre>
|
||||
</blockquote>
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500"><tr><td>
|
||||
<blockquote>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><br><%product%> <20>w<EFBFBD><77><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>Y<EFBFBD>ʧ@<40>C
|
||||
|
||||
<%install_message%>
|
||||
|
||||
<p><3E><><EFBFBD>קK<D7A7>N<EFBFBD>z<EFBFBD>̪쪺 .tar.gz <20>ɮׯd<D7AF>b<EFBFBD>z<EFBFBD><7A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>ؿ<EFBFBD><D8BF><EFBFBD><EFBFBD>I
|
||||
|
||||
<p><3E>p<EFBFBD>G<EFBFBD>z<EFBFBD><7A><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD><EFBFBD>D<EFBFBD>A<EFBFBD>z<EFBFBD>i<EFBFBD>H<EFBFBD><48><EFBFBD>ڭ̪<DAAD><a href="http://gossamer-threads.com/perl/gforum/"><3E>䴩<EFBFBD>Q<EFBFBD>װ<EFBFBD></a><3E>M<EFBFBD>D<EFBFBD>䴩<EFBFBD>C
|
||||
<%message%>
|
||||
<br>
|
||||
</td></tr></table>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
CGI_ERROR_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Error</title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><3E><><EFBFBD>~</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2"><3E>o<EFBFBD>Ϳ<EFBFBD><CDBF>~<7E>G
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
</blockquote>
|
||||
</td></tr></table>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INVALID_RESPONCE => "\n<>L<EFBFBD>Ī<EFBFBD><C4AA>^<5E><> (%s)\n",
|
||||
);
|
||||
|
||||
1434
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.de
Normal file
1434
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.de
Normal file
File diff suppressed because it is too large
Load Diff
1234
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.en
Normal file
1234
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.en
Normal file
File diff suppressed because it is too large
Load Diff
368
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.fr
Normal file
368
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.fr
Normal file
@ -0,0 +1,368 @@
|
||||
|
||||
%GT::Installer::LANG = (
|
||||
ERR_REQUIRED => "%s ne peut pas <20>tre vide.",
|
||||
ERR_PATH => "Le chemin (%s) n'existe pas sur ce syst<73>me.",
|
||||
ERR_PATHWRITE => "Impossible d'<27>crire dans le r<>pertoire (%s). Raison : (%s)",
|
||||
ERR_PATHCREATE => "Impossible de cr<63>er le r<>pertoire (%s). Raison : (%s)",
|
||||
ERR_URLFMT => "(%s) ne semble pas <20>tre une URL",
|
||||
ERR_FTPFMT => "(%s) ne semble pas <20>tre une URL FTP",
|
||||
ERR_EMAILFMT => "(%s) ne semble pas <20>tre un email",
|
||||
ERR_SENDMAIL => "Le chemin (%s) n'existe pas sur votre syst<73>me ou n'est pas ex<65>cutable",
|
||||
ERR_SMTP => "(%s) n'est pas une adresse de serveur smtp valide",
|
||||
ERR_PERL => "Le chemin de Perl sp<73>cifi<66> (%s) %s",
|
||||
ERR_DIREXISTS => "%s n'est pas un r<>pertoire mais existe, impossible de cr<63>er un r<>pertoire de ce nom",
|
||||
ERR_WRITEOPEN => "Impossible d'ouvrir %s pour y <20>crire. Raison : %s",
|
||||
ERR_READOPEN => "Impossible d'ouvrir %s pour le lire. Raison : %s",
|
||||
ERR_RENAME => "Impossible de renommer %s par %s; Raison : %s",
|
||||
ENTER_REG => 'Merci d\'entrer votre num<75>ro d\'enregistrement',
|
||||
REG_NUM => 'Num<75>ro d\'enregistrement',
|
||||
ENTER_SENDMAIL => 'Entrez soit le chemin de sendmail, soit un serveur SMTP <20> utiliser pour envoyer des emails',
|
||||
MAILER => 'Mailer',
|
||||
ENTER_PERL => 'Entrez le chemin de Perl 5',
|
||||
PATH_PERL => 'Chemin de Perl',
|
||||
CREATE_DIRS => 'Cr<43>ation des R<>pertoires',
|
||||
INSTALL_CURRUPTED => '
|
||||
install.dat semble corrompu. Soyez s<>r d\'avoir transf<73>r<EFBFBD> le fichier en mode BINAIRE avec votre FTP. Ou alors vous avez peut-<2D>tre un fichier corrompu, dans ce cas vous devriez essayer de t<>l<EFBFBD>charger un nouveau fichier <20> partir de Gossamer Threads.
|
||||
|
||||
Si vous avez besoin d\'aide visitez :
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
INSTALL_VERSION => '
|
||||
Ce programme requiert Perl version 5.004_04 ou plus pour fonctionner. Votre syst<73>me utilise seulement la version %s. Essayez de changer le chemin de Perl dans install.cgi pour une version sup<75>rieure, ou contactez votre h<>bergeur pour de l\'aide.
|
||||
',
|
||||
ADMIN_PATH_ERROR => "Vous devez sp<73>cifier le chemin d'installation pr<70>c<EFBFBD>dent de la zone d'Administration",
|
||||
INTRO => '
|
||||
%s Installation Rapide http://gossamer-threads.com
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved
|
||||
Redistribution in part or in whole strictly prohibited.
|
||||
|
||||
Lisez le fichier LICENSE pour plus de d<>tails.
|
||||
',
|
||||
WELCOME => '
|
||||
Bienvenue dans l\'auto-installation de %s. Ce programme va d<>compresser le programme %s, cr<63>er tous les fichiers n<>cessaires, et param<61>trer toutes les permissions proprement.
|
||||
|
||||
Pour commencer, entrez les informations suivantes. Vous pouvez sortir <20> tout moment pour abandonner.
|
||||
',
|
||||
IS_UPGRADE => "Est-ce une mise <20> jour d'une installation existante",
|
||||
ENTER_ADMIN_PATH => "\nEntrez le chemin vers l'administration actuelle",
|
||||
UNARCHIVING => 'D<>compactage',
|
||||
TAR_OPEN => "Impossible d'ouvrir %s. Raison: %s",
|
||||
TAR_READ => "Il s'est produit une erreur en lisant %s. Nous aurions d<> lire %s octets, mais en avons seulement eu %s.",
|
||||
TAR_BINMODE => "Impossible de binmode %s. Raison: %s",
|
||||
TAR_BADARGS => "Mauvais arguments transmis <20> %s. Raison: %s",
|
||||
TAR_CHECKSUM => "Erreur de Checksum en pla<6C>ant le fichier tar. Il s'agit tr<74>s probablement d'un tar corrompu.\nHeader: %s\nChecksum: %s\nFichier: %s\n",
|
||||
TAR_NOBODY => "Le fichier '%s' n'a pas de corps!",
|
||||
TAR_CANTFIND => "Impossible de trouver un fichier dans l'archive, nomm<6D>: '%s'.",
|
||||
TAR_CHMOD => "Impossible de chmoder %s, Raison: %s",
|
||||
TAR_DIRFILE => "'%s' existe et est un fichier. Impossible de cr<63>er le r<>pertoire",
|
||||
TAR_MKDIR => "Impossible de cr<63>er %s, Raison: %s",
|
||||
TAR_RENAME => "Impossible de renommer le fichier temp: '%s' par le fichier tar '%s'. Raison: %s",
|
||||
TAR_NOGZIP => "Compression::Module Zlib requis pour faire fonctionner des fichiers .tar.gz.",
|
||||
SKIPPING_FILE => "Ignorer %s\n",
|
||||
OVERWRITTING_FILE => "Remplacer %s\n",
|
||||
SKIPPING_MATCHED => "Ignorer %s dans le r<>pertoire trouv<75>\n",
|
||||
BACKING_UP_FILE => "Sauvegarde de %s\n",
|
||||
ERR_OPENTAR => '
|
||||
Impossible d\'ouvrir le fichier install.dat! Soyez certain que le fichier existe, et que les permissions sont param<61>tr<74>es correctement pour que le programme lise le fichier.
|
||||
|
||||
Le message d\'erreur est le suivant:
|
||||
%s
|
||||
|
||||
Si vous avez besoin d\'aide visitez:
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
ERR_OPENTAR_UNKNOWN => '
|
||||
Erreur inconnue en ouvrant le fichier tar:
|
||||
%s
|
||||
|
||||
Si vous avez besoin d\'aide visitez:
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
WE_HAVE_IT => "\nNous avons tout ce qui est n<>cessaire pour proc<6F>der.\n\n",
|
||||
ENTER_STARTS => "\nAppuyez sur ENTR<54>E pour installer, ou CTRL-C pour abandonner",
|
||||
NOW_UNARCHIVING => '
|
||||
|
||||
Nous d<>compactons actuellement %s et nous d<>compresserons tous les fichiers rapidement. Patientez s\'il vous pla<6C>t...
|
||||
',
|
||||
UPGRADE_DONE => '
|
||||
|
||||
F<EFBFBD>licitations! Votre copie de %s a <20>t<EFBFBD> mise <20> jour vers la version %s. Les fichiers d\'installation ont <20>t<EFBFBD> supprim<69>s.
|
||||
|
||||
Si vous devez relancer l\'installation, d<>compactez le fichier original une nouvelle fois.
|
||||
',
|
||||
INSTALL_DONE => '
|
||||
|
||||
%s est maintenant d<>compact<63>. Les fichiers d\'installation ont <20>t<EFBFBD> supprim<69>s. Si vous devez relancer l\'installation, d<>compactez le fichier original une nouvelle fois.
|
||||
|
||||
NOTE: Ne laissez pas votre fichier original .tar.gz dans votre r<>pertoire web!
|
||||
|
||||
',
|
||||
TELNET_ERR => 'Erreur: %s',
|
||||
FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Bienvenue dans <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b>Installation de <%product%>
|
||||
</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Bienvenue dans <%product%>. Ce programme va d<>compacter <%product%>, et param<61>trer toutes les permissions de fichier
|
||||
ainsi que le chemin de Perl correctement.
|
||||
|
||||
<%error%>
|
||||
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%message%>
|
||||
<tr>
|
||||
<td colspan="2"><font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Merci de choisir si vous souhaitez r<>aliser une nouvelle installation ou bien effectuer une mise <20> jour.
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="150"><font face="Tahoma,Arial,Helvetica" size="2"><b>Nouvelle Installation</b></font></td>
|
||||
<td width="300"><font face="Tahoma,Arial,Helvetica" size="2"><input type="radio" name="upgrade_choice" value="No" checked></font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="150"><font face="Tahoma,Arial,Helvetica" size="2"><b>Mettre <20> Jour une Installation <20>xistante</b></font></td>
|
||||
<td width="300"><font face="Tahoma,Arial,Helvetica" size="2"><input type="radio" name="upgrade_choice" value="Yes"></font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="450" colspan=2><font face="Tahoma,Arial,Helvetica" size="2">Chemin de la zone d\'administration existante:</font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="450" colspan=2><font face="Tahoma,Arial,Helvetica" size="2"><input type="text" name="install_dir" size=40 value="<%install_dir%>"></font></td>
|
||||
</tr>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="Suivant >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
UPGRADE_FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Bienvenue dans <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<input type=hidden name="upgrade_second" value="1">
|
||||
<input type=hidden name="install_dir" value="<%GT_ADMIN_PATH%>">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b>Installation de <%product%>
|
||||
</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Bienvenue dans <%product%>. Ce programme va d<>compacter <%product%>, et param<61>trer toutes les permissions de fichier
|
||||
ainsi que le chemin de Perl correctement. Vous devez conna<6E>tre les informations suivantes avant de continuer. Des param<61>tres par d<>faut ont <20>t<EFBFBD> choisis, mais v<>rifiez
|
||||
qu\'ils sont bien corrects.
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%upgrade_form%>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="Suivant >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
UPGRADE_SECOND_SCREEN_FIRST => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Bienvenue dans <%product%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b>Installation de <%product%>
|
||||
</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Nous allons maintenant d<>compacter le script, veuillez patienter s\'il vous pla<6C>t, et ne pas cliquer sur Arr<72>ter.
|
||||
</font></p>
|
||||
</blockquote>
|
||||
</td>
|
||||
</tr></table>
|
||||
<blockquote>
|
||||
<pre>
|
||||
',
|
||||
UPGRADE_SECOND_SCREEN_SECOND => '
|
||||
</pre>
|
||||
</blockquote>
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500"><tr><td>
|
||||
<blockquote>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><br><%product%> est maintenant d<>compact<63>.
|
||||
|
||||
<%install_message%>
|
||||
|
||||
<p>Merci de ne pas laisser votre fichier .tar.gz original dans votre r<>pertoire web!
|
||||
|
||||
<p>Si vous avez un probl<62>me, visitez notre <a href="http://gossamer-threads.com/perl/forum/">forum d\'assistance</a>.
|
||||
<%message%>
|
||||
<br>
|
||||
</td></tr></table>
|
||||
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INSTALL_WARNING => '<p><b>ATTENTION:</b> Supprimez les fichiers install.cgi et install.dat de ce r<>pertoire. Il y a un risque de s<>curit<69> en les laissant ici.',
|
||||
INSTALL_REMOVED => '<p>Les fichiers d\'installation ont <20>t<EFBFBD> supprim<69>s. Si vous devez relancer l\'installation, d<>compactez une nouvelle fois le fichier original.',
|
||||
|
||||
OVERWRITE => 'Remplacer',
|
||||
BACKUP => 'Sauvegarder',
|
||||
SKIP => 'Ignorer',
|
||||
INSTALL_FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Bienvenue dans <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<input type=hidden name="install" value="1">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b>Installation de <%product%>
|
||||
</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Bienvenue dans <%product%>. Ce programme va d<>compacter <%product%>, et param<61>trer toutes les permissions de fichier
|
||||
ainsi que le chemin de Perl correctement. Vous devez conna<6E>tre les informations suivantes avant de continuer. Des param<61>tres par d<>faut ont <20>t<EFBFBD> choisis, mais v<>rifiez
|
||||
qu\'ils sont bien corrects.
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%form%>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="Suivant >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INSTALL_SECOND_SCREEN_FIRST => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Bienvenue dans <%product%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b>Installation de <%product%>
|
||||
</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Nous allons maintenant d<>compacter le script, veuillez patienter s\'il vous pla<6C>t, et ne pas cliquer sur Arr<72>ter.
|
||||
</font></p>
|
||||
</blockquote>
|
||||
</td>
|
||||
</tr></table>
|
||||
<blockquote>
|
||||
<pre>
|
||||
',
|
||||
INSTALL_SECOND_SCREEN_SECOND => '
|
||||
</pre>
|
||||
</blockquote>
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500"><tr><td>
|
||||
<blockquote>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><br><%product%> est maintenant d<>compact<63>.
|
||||
|
||||
<%install_message%>
|
||||
|
||||
<p><p>Merci de ne pas laisser votre fichier .tar.gz original dans votre r<>pertoire web!
|
||||
|
||||
<p>Si vous avez des probl<62>mes, visitez notre <a href="http://gossamer-threads.com/perl/forum/">forum d\'assistance</a>.
|
||||
<%message%>
|
||||
<br>
|
||||
</td></tr></table>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
CGI_ERROR_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Erreur</title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b>Erreur</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Une erreur s\'est produite:
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
</blockquote>
|
||||
</td></tr></table>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INVALID_RESPONCE => "\nR<6E>ponse Invalide (%s)\n",
|
||||
);
|
||||
|
||||
386
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.it
Normal file
386
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.it
Normal file
@ -0,0 +1,386 @@
|
||||
|
||||
%GT::Installer::LANG = (
|
||||
ERR_REQUIRED => "%s can not be left blank.",
|
||||
ERR_PATH => "The path (%s) does not exist on this system",
|
||||
ERR_PATHWRITE => "Unable to write to directory (%s). Reason: (%s)",
|
||||
ERR_PATHCREATE => "Unable to create directory (%s). Reason: (%s)",
|
||||
ERR_URLFMT => "(%s) does not look like a URL",
|
||||
ERR_FTPFMT => "(%s) does not look like and FTP URL",
|
||||
ERR_EMAILFMT => "(%s) does not look like an email",
|
||||
ERR_SENDMAIL => "The path (%s) does not exist on your system or is not executable",
|
||||
ERR_SMTP => "(%s) is not a valid smtp server address",
|
||||
ERR_PERL => "The path to Perl you specified (%s) %s",
|
||||
ERR_DIREXISTS => "%s is not a directory but exists, unable to make a directory of that name",
|
||||
ERR_WRITEOPEN => "Could not open %s for writting; Reason: %s",
|
||||
ERR_READOPEN => "Could not open %s for reading; Reason: %s",
|
||||
ERR_RENAME => "Could not rename %s to %s; Reason: %s",
|
||||
ENTER_REG => 'Please enter your registration number',
|
||||
REG_NUM => 'Registration Number',
|
||||
ENTER_SENDMAIL => 'Please enter either a path to sendmail, or a SMTP server to use for sending mail',
|
||||
MAILER => 'Mailer',
|
||||
ENTER_PERL => 'Please enter the path to Perl 5',
|
||||
PATH_PERL => 'Path to Perl',
|
||||
CREATE_DIRS => 'Create Directories',
|
||||
INSTALL_CURRUPTED => '
|
||||
install.dat appears to be corrupted. Please make sure you transfer
|
||||
the file in BINARY mode when using FTP. Otherwise you may have a
|
||||
corrupted file, and you should try downloading a new file from
|
||||
Gossamer Threads.
|
||||
|
||||
If you need assistance, please visit:
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
INSTALL_VERSION => '
|
||||
This program requires Perl version 5.004_04 or greater to run. Your
|
||||
system is only running version %s. Try changing the path to Perl in
|
||||
install.cgi to a newer version, or contact your ISP for help.
|
||||
',
|
||||
ADMIN_PATH_ERROR => "You must specify the path to the previous install's admin area",
|
||||
INTRO => '
|
||||
%s Quick Install http://gossamer-threads.com
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved
|
||||
Redistribution in part or in whole strictly prohibited.
|
||||
|
||||
Please see LICENSE file for full details.
|
||||
',
|
||||
WELCOME => '
|
||||
Welcome to the %s auto install. This program will
|
||||
unarchive the %s program, and create all the
|
||||
files neccessary, and set all permissions properly.
|
||||
|
||||
To begin, please enter the following information. Type exit or
|
||||
quit at any time to abort.
|
||||
',
|
||||
IS_UPGRADE => "Is this an upgrade of an existing installation",
|
||||
ENTER_ADMIN_PATH => "\nPlease enter path to current admin",
|
||||
UNARCHIVING => 'Unarchiving',
|
||||
TAR_OPEN => "Could not open %s. Reason: %s",
|
||||
TAR_READ => "There was an error reading from %s. Expected to read %s bytes, but only got %s.",
|
||||
TAR_BINMODE => "Could not binmode %s. Reason: %s",
|
||||
TAR_BADARGS => "Bad arguments passed to %s. Reason: %s",
|
||||
TAR_CHECKSUM => "Checksum Error parsing tar file. Most likely this is a corrupt tar.\nHeader: %s\nChecksum: %s\nFile: %s\n",
|
||||
TAR_NOBODY => "File '%s' does not have a body!",
|
||||
TAR_CANTFIND => "Unable to find a file named: '%s' in tar archive.",
|
||||
TAR_CHMOD => "Could not chmod %s, Reason: %s",
|
||||
TAR_DIRFILE => "'%s' exists and is a file. Cannot create directory",
|
||||
TAR_MKDIR => "Could not mkdir %s, Reason: %s",
|
||||
TAR_RENAME => "Unable to rename temp file: '%s' to tar file '%s'. Reason: %s",
|
||||
TAR_NOGZIP => "Compress::Zlib module is required to work with .tar.gz files.",
|
||||
SKIPPING_FILE => "Skipping %s\n",
|
||||
OVERWRITTING_FILE => "Overwritting %s\n",
|
||||
SKIPPING_MATCHED => "Skipping %s in matched directory\n",
|
||||
BACKING_UP_FILE => "Backing up %s\n",
|
||||
ERR_OPENTAR => '
|
||||
Unable to open the install.dat file! Please make sure the
|
||||
file exists, and the permissions are set properly so the
|
||||
program can read the file.
|
||||
|
||||
The error message was:
|
||||
%s
|
||||
|
||||
If you need assistance, please visit:
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
ERR_OPENTAR_UNKNOWN => '
|
||||
Unknown error opening tar file:
|
||||
%s
|
||||
|
||||
If you need assistance, please visit:
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
WE_HAVE_IT => "\nWe have everything we need to proceed.\n\n",
|
||||
ENTER_STARTS => "\nPress ENTER to install, or CTRL-C to abort",
|
||||
NOW_UNARCHIVING => '
|
||||
|
||||
We are now unarchiving %s and will be extracting
|
||||
all the files shortly. Please be patient ...
|
||||
',
|
||||
UPGRADE_DONE => '
|
||||
|
||||
Congratulations! Your copy of %s has now been
|
||||
updated to version %s. The install files have
|
||||
been removed.
|
||||
|
||||
If you need to re-run the install, please unarchive the
|
||||
original file again.
|
||||
',
|
||||
INSTALL_DONE => '
|
||||
|
||||
%s is now unarchived. The install files have been
|
||||
removed. If you need to re-run the install, please unarchive
|
||||
the original file again.
|
||||
|
||||
NOTE: Please do not leave your original .tar.gz file in your
|
||||
web directory!
|
||||
|
||||
',
|
||||
TELNET_ERR => 'Error: %s',
|
||||
FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Welcome to <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Welcome to <%product%>. This program will unarchive <%product%>, and set all the file permissions
|
||||
and path to Perl properly.
|
||||
|
||||
<%error%>
|
||||
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%message%>
|
||||
<tr>
|
||||
<td colspan="2"><font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Please select if this is a new install or an upgrade to an exiting version.
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="150"><font face="Tahoma,Arial,Helvetica" size="2"><b>New Install</b></font></td>
|
||||
<td width="300"><font face="Tahoma,Arial,Helvetica" size="2"><input type="radio" name="upgrade_choice" value="No" checked></font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="150"><font face="Tahoma,Arial,Helvetica" size="2"><b>Upgrade Existing Installation</b></font></td>
|
||||
<td width="300"><font face="Tahoma,Arial,Helvetica" size="2"><input type="radio" name="upgrade_choice" value="Yes"></font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="450" colspan=2><font face="Tahoma,Arial,Helvetica" size="2">Path to Existing Installation admin area:</font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="450" colspan=2><font face="Tahoma,Arial,Helvetica" size="2"><input type="text" name="install_dir" size=40 value="<%install_dir%>"></font></td>
|
||||
</tr>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="Next >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
UPGRADE_FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Welcome to <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<input type=hidden name="upgrade_second" value="1">
|
||||
<input type=hidden name="install_dir" value="<%GT_ADMIN_PATH%>">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Welcome to <%product%>. This program will unarchive <%product%>, and set all the file permissions
|
||||
and path to Perl properly. You need to know the following information before continuing. Sensible defaults have been chosen, but please double check
|
||||
that they are correct.
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%upgrade_form%>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="Next >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
UPGRADE_SECOND_SCREEN_FIRST => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Welcome to <%product%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
We are now going to unarchive the script, please be patient and do not hit stop.
|
||||
</font></p>
|
||||
</blockquote>
|
||||
</td>
|
||||
</tr></table>
|
||||
<blockquote>
|
||||
<pre>
|
||||
',
|
||||
UPGRADE_SECOND_SCREEN_SECOND => '
|
||||
</pre>
|
||||
</blockquote>
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500"><tr><td>
|
||||
<blockquote>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><br><%product%> is now unarchived.
|
||||
|
||||
<%install_message%>
|
||||
|
||||
<p>Please do not leave your original .tar.gz file in your web directory!
|
||||
|
||||
<p>If you have any problems, please visit our <a href="http://gossamer-threads.com/perl/forum/">support forum</a>.
|
||||
<%message%>
|
||||
<br>
|
||||
</td></tr></table>
|
||||
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INSTALL_WARNING => '<p><b>WARNING:</b> Please remove the install.cgi and install.dat file from this directory. It is a security risk to leave those files here.',
|
||||
INSTALL_REMOVED => '<p>The install files have been removed. If you need to re-run the install, please unarchive the
|
||||
original file again.',
|
||||
|
||||
OVERWRITE => 'Overwrite',
|
||||
BACKUP => 'Backup',
|
||||
SKIP => 'Skip',
|
||||
INSTALL_FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Welcome to <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<input type=hidden name="install" value="1">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Welcome to <%product%>. This program will unarchive <%product%>, and set all the file permissions
|
||||
and path to Perl properly. You need to know the following information before continuing. Sensible defaults have been chosen, but please double check
|
||||
that they are correct.
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%form%>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="Next >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INSTALL_SECOND_SCREEN_FIRST => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Welcome to <%product%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
We are now going to unarchive the script, please be patient and do not hit stop.
|
||||
</font></p>
|
||||
</blockquote>
|
||||
</td>
|
||||
</tr></table>
|
||||
<blockquote>
|
||||
<pre>
|
||||
',
|
||||
INSTALL_SECOND_SCREEN_SECOND => '
|
||||
</pre>
|
||||
</blockquote>
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500"><tr><td>
|
||||
<blockquote>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><br><%product%> is now unarchived.
|
||||
|
||||
<%install_message%>
|
||||
|
||||
<p>Please do not leave your original .tar.gz file in your web directory!
|
||||
|
||||
<p>If you have any problems, please visit our <a href="http://gossamer-threads.com/perl/forum/">support forum</a>.
|
||||
<%message%>
|
||||
<br>
|
||||
</td></tr></table>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
CGI_ERROR_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Error</title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b>Error</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">An error occurred:
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
</blockquote>
|
||||
</td></tr></table>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INVALID_RESPONCE => "\nInvalid Responce (%s)\n",
|
||||
);
|
||||
|
||||
383
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.sp
Normal file
383
site/slowtwitch.com/cgi-bin/articles/GT/Installer/language.sp
Normal file
@ -0,0 +1,383 @@
|
||||
|
||||
%GT::Installer::LANG = (
|
||||
ERR_REQUIRED => "%s no se puede dejar en blanco.",
|
||||
ERR_PATH => "El path (%s) no existe en el sistema",
|
||||
ERR_PATHWRITE => "Incapaz de escribir en el directorio (%s). Razon: (%s)",
|
||||
ERR_PATHCREATE => "Incapaz de crear directorio (%s). Razon: (%s)",
|
||||
ERR_URLFMT => "(%s) parece no ser un URL",
|
||||
ERR_FTPFMT => "(%s) parece no ser un URL de FTP",
|
||||
ERR_EMAILFMT => "(%s) parece no ser un email",
|
||||
ERR_SENDMAIL => "El path (%s) no existe en su sistema o no es ejecutable",
|
||||
ERR_SMTP => "(%s) no es una direccion de servidor smptp valida",
|
||||
ERR_PERL => "El path a Perl usted especifico (%s) %s",
|
||||
ERR_DIREXISTS => "%s no es un directorio pero existe, no se puede hacer un directorio de ese nombre",
|
||||
ERR_WRITEOPEN => "No se pudo abrir %s por escritura; Razon: %s",
|
||||
ERR_READOPEN => "No se pudo abrir %s por lectura; Razon: %s",
|
||||
ERR_RENAME => "No se pudo renombrar %s to %s; Razon: %s",
|
||||
ENTER_REG => 'Por favor ingrese su numero de registro',
|
||||
REG_NUM => 'Numero de Registro',
|
||||
ENTER_SENDMAIL => 'Por favor ingrese ya sea el path a sendmail, o el servidor SMTP a usar para enviar Correo',
|
||||
MAILER => 'Mailer',
|
||||
ENTER_PERL => 'Por favor ingrese el path a Perl 5',
|
||||
PATH_PERL => 'Path a Perl',
|
||||
CREATE_DIRS => 'Crear Directorios',
|
||||
INSTALL_CURRUPTED => '
|
||||
install.dat parece estar corrupto. favor de asegurarse que transfiere el archivo en modo BINARIO
|
||||
cuando use FTP. de otro modo usted podra obtener el archivo corrupto, y tendra que volver a bajar un nuevo archivo desde
|
||||
Gossamer Threads.
|
||||
|
||||
Si necesita asistencia, favor de visitar:
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
INSTALL_VERSION => '
|
||||
Este programa requiere la version Perl 5.004_04 o mas nueva para correr. Su
|
||||
Sistema esta corriendo la version %s. Trate cambiando el path a Perl en
|
||||
install.cgi a la version mas actual, o contacte a su ISP para ayuda.
|
||||
',
|
||||
ADMIN_PATH_ERROR => "Usted tiene que especificar el path al area de administracion de la instalacion previa",
|
||||
INTRO => '
|
||||
%s Quick Install http://gossamer-threads.com
|
||||
Copyright (c) 2004 Gossamer Threads Inc. Todos los derechos Reservados
|
||||
Redistribucion en parte o total es extrictamente prohibida.
|
||||
|
||||
Por favor vea el archivo de LICENCIA para detalles mas completos.
|
||||
',
|
||||
WELCOME => '
|
||||
Bienvenido al %s auto install. Este programa
|
||||
descompactara el %s programa, y creara todos los
|
||||
archivos necesarios, y pondra todos los permisos de manera propia.
|
||||
|
||||
Para empezar, por favor ingrese la siguiente informacion. presione exit o
|
||||
quit en cualquier momento para abortar.
|
||||
',
|
||||
IS_UPGRADE => "Es esta una actualizacion de una instalacion ya existente",
|
||||
ENTER_ADMIN_PATH => "\npor favor ingrese el path al actual admin",
|
||||
UNARCHIVING => 'Descomprimiendo',
|
||||
TAR_OPEN => "No se pudo abrir %s. Razon: %s",
|
||||
TAR_READ => "Hubo un error leyendo desde %s. Se suponia leyera %s bytes, pero solo leyo %s.",
|
||||
TAR_BINMODE => "No se pudo modo binario %s. Razon: %s",
|
||||
TAR_BADARGS => "Malos argumentos se pasaron a %s. Razon: %s",
|
||||
TAR_CHECKSUM => "analisis de chequeo de archivo tar. Es muy probable este corrupto el tar.\nHeader: %s\nChecksum: %s\nFile: %s\n",
|
||||
TAR_NOBODY => "Archivo '%s' no tiene contenido!",
|
||||
TAR_CANTFIND => "Incapaz de encontrar un archivo llamado: '%s' en archivo tar.",
|
||||
TAR_CHMOD => "No se pudo chmod %s, Razon: %s",
|
||||
TAR_DIRFILE => "'%s' existe y es un archivo. No se puede crear directorio",
|
||||
TAR_MKDIR => "No se pudo mkdir %s, Razon: %s",
|
||||
TAR_RENAME => "No se puede renombrar el archivo temporal: '%s' to tar file '%s'. Razon: %s",
|
||||
TAR_NOGZIP => "Comprimir::El modulo Zlib es requerido para trabajar con archivos .tar.gz .",
|
||||
SKIPPING_FILE => "Saltandose %s\n",
|
||||
OVERWRITTING_FILE => "Sobreescribiendo %s\n",
|
||||
SKIPPING_MATCHED => "Saltandose %s en directorio concordante\n",
|
||||
BACKING_UP_FILE => "Respaldando %s\n",
|
||||
ERR_OPENTAR => '
|
||||
No se puede abrir el archivo install.dat! por favor asegurese de que
|
||||
el archivo existe, y los permisos estan puestos apropiadamente y asi el programa
|
||||
podra leer el archivo.
|
||||
|
||||
El mensaje de error fue:
|
||||
%s
|
||||
|
||||
Si necesita asistencia, favor de visitar:
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
ERR_OPENTAR_UNKNOWN => '
|
||||
error desconocido al abrir el archivo tar:
|
||||
%s
|
||||
|
||||
Si necesita asistencia, favor de visitar:
|
||||
http://gossamer-threads.com/scripts/support/
|
||||
',
|
||||
WE_HAVE_IT => "\nTenemos todo lo que necesitamos para proceder.\n\n",
|
||||
ENTER_STARTS => "\nPresione ENTER para instalar, o CTRL-C para abortar",
|
||||
NOW_UNARCHIVING => '
|
||||
|
||||
Ahora estamos descomprimiendo %s y terminara de extraer todos los archivos
|
||||
dentro de poco. Sea paciente ...
|
||||
',
|
||||
UPGRADE_DONE => '
|
||||
|
||||
Felicidades! Su copia de %s ha sido ya
|
||||
actualizada a la version %s. Los archivos de instalacion han sido eliminados.
|
||||
|
||||
Si necesita volver a correr el instalador, favor de descomprimir el archivo
|
||||
original de nuevo.
|
||||
',
|
||||
INSTALL_DONE => '
|
||||
|
||||
%s esta ya desomprimido. Los archivos de instalacion han sido eliminados.
|
||||
Si necesita volver a correr el instalador, favor de descomprimir el archivo
|
||||
original de nuevo.
|
||||
|
||||
NOTA: Por favor no deje el archivo original .tar.gz file en su
|
||||
directorio web!
|
||||
|
||||
',
|
||||
TELNET_ERR => 'Error: %s',
|
||||
FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Bienvenido a <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Bienvenido a <%product%>. Este programa descomprimira <%product%>, y pondra todos los permisos de archivo y el path a Perl de manera propia.
|
||||
|
||||
<%error%>
|
||||
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%message%>
|
||||
<tr>
|
||||
<td colspan="2"><font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Por favor seleccione si esta es una nueva instalacion o una actualizacion de una version existente.
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="150"><font face="Tahoma,Arial,Helvetica" size="2"><b>Nueva Instalacion</b></font></td>
|
||||
<td width="300"><font face="Tahoma,Arial,Helvetica" size="2"><input type="radio" name="upgrade_choice" value="No" checked></font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="150"><font face="Tahoma,Arial,Helvetica" size="2"><b>Actualizar Instalacion Existente</b></font></td>
|
||||
<td width="300"><font face="Tahoma,Arial,Helvetica" size="2"><input type="radio" name="upgrade_choice" value="Yes"></font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="450" colspan=2><font face="Tahoma,Arial,Helvetica" size="2">Path a el area de admin de la Instalacion Existente:</font></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td width="450" colspan=2><font face="Tahoma,Arial,Helvetica" size="2"><input type="text" name="install_dir" size=40 value="<%install_dir%>"></font></td>
|
||||
</tr>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="Siguiente >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
UPGRADE_FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Bienvenido a <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<input type=hidden name="upgrade_second" value="1">
|
||||
<input type=hidden name="install_dir" value="<%GT_ADMIN_PATH%>">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Bienvenido a <%product%>. Este programa descomprimira <%product%>, y pondra todos los permisos de archivo
|
||||
y path a Perl de manera propia. Usted necesita saber la siguiente informacion antes de continuar. Los defaults sensibles han sido escogidos, pero por favor cheque de
|
||||
nuevo que son correctos.
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%upgrade_form%>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="Siguiente >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
UPGRADE_SECOND_SCREEN_FIRST => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Welcome to <%product%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Ahora descomprimiremos el script, por favor sea paciente y no cancele ni presione stop.
|
||||
</font></p>
|
||||
</blockquote>
|
||||
</td>
|
||||
</tr></table>
|
||||
<blockquote>
|
||||
<pre>
|
||||
',
|
||||
UPGRADE_SECOND_SCREEN_SECOND => '
|
||||
</pre>
|
||||
</blockquote>
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500"><tr><td>
|
||||
<blockquote>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><br><%product%> esta ahora descomprimido.
|
||||
|
||||
<%install_message%>
|
||||
|
||||
<p>Por favor no deje su archivo original .tar.gz en su directorio web!
|
||||
|
||||
<p>Si usted tiene algun problema, por favor visite nuestro sitio de soporter <a href="http://gossamer-threads.com/perl/forum/"></a>.
|
||||
<%message%>
|
||||
<br>
|
||||
</td></tr></table>
|
||||
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INSTALL_WARNING => '<p><b>PRECAUCION:</b> Por favor remueva los archivos install.cgi e install.dat de este directorio. Habra un riesgo de seguridad si los deja aqui.',
|
||||
INSTALL_REMOVED => '<p>Los archivos de instalacion han sido eliminados. Si usted necesita volver a correr el instalador, por favor descomprima
|
||||
el archivo original de nuevo.',
|
||||
|
||||
OVERWRITE => 'Sobreescribir',
|
||||
BACKUP => 'Respaldar',
|
||||
SKIP => 'Saltar',
|
||||
INSTALL_FIRST_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Bienvenido a <%product%> <%version%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<form action="install.cgi" method="POST">
|
||||
<input type="hidden" name="lite" value="<%lite%>">
|
||||
<input type=hidden name="install" value="1">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Bienvenido a <%product%>. Este programa descomprimira <%product%>, y pondra todos los permisos de archivo
|
||||
y path a Perl de manera propia. Usted necesita saber la siguiente informacion antes de continuar. Los defaults sensibles han sido seleccionados, pero por favor
|
||||
cheque de nuevo que son correctos.
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
|
||||
<table border="0">
|
||||
<%form%>
|
||||
</table>
|
||||
<p align="center"><center><font face="Tahoma,Arial,Helvetica" size="2"> <input type="submit" value="Siguiente >>"></center>
|
||||
</font><br>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INSTALL_SECOND_SCREEN_FIRST => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Bienvenido a <%product%></title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b><%product%>
|
||||
Install</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Ahora descomprimiremos el script, por favor sea paciente y no cancele o presione stop.
|
||||
</font></p>
|
||||
</blockquote>
|
||||
</td>
|
||||
</tr></table>
|
||||
<blockquote>
|
||||
<pre>
|
||||
',
|
||||
INSTALL_SECOND_SCREEN_SECOND => '
|
||||
</pre>
|
||||
</blockquote>
|
||||
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500"><tr><td>
|
||||
<blockquote>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><br><%product%> esta ahora descomprimido.
|
||||
|
||||
<%install_message%>
|
||||
|
||||
<p>Por favor no deje el archivo original .tar.gz en su directorio web!
|
||||
|
||||
<p>Si usted tiene algun problema, por favor visite nuestro sitio de soporte <a href="http://gossamer-threads.com/perl/forum/"></a>.
|
||||
<%message%>
|
||||
<br>
|
||||
</td></tr></table>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
CGI_ERROR_SCREEN => '
|
||||
<html>
|
||||
<head>
|
||||
<title>Error</title>
|
||||
</head>
|
||||
<body bgcolor="#FFFFFF">
|
||||
<table border="1" cellpadding="0" cellspacing="0" width="500">
|
||||
<tr><td bgcolor="#DDDDDD">
|
||||
<p align="center"><font face="Tahoma,Arial,Helvetica" size="2"> </font><font face="Tahoma,Arial,Helvetica" size="3"><b>Error</b></font>
|
||||
</p>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<blockquote>
|
||||
<p><br>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">Un error ha ocurrido:
|
||||
|
||||
<%error%>
|
||||
<br>
|
||||
</blockquote>
|
||||
</td></tr></table>
|
||||
<p><font face="Tahoma,Arial,Helvetica" size="2"><p><font face="Tahoma,Arial,Helvetica" size="2"><b>Copyright 2004 <a href="http://gossamer-threads.com/">Gossamer
|
||||
Threads Inc.</a></b> </font></p>
|
||||
</body>
|
||||
</html>
|
||||
',
|
||||
INVALID_RESPONCE => "\nRespuesta Invalida (%s)\n",
|
||||
);
|
||||
|
||||
1832
site/slowtwitch.com/cgi-bin/articles/GT/JSON.pm
Normal file
1832
site/slowtwitch.com/cgi-bin/articles/GT/JSON.pm
Normal file
File diff suppressed because it is too large
Load Diff
2128
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP.pm
Normal file
2128
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP.pm
Normal file
File diff suppressed because it is too large
Load Diff
26
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP/Boolean.pm
Normal file
26
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP/Boolean.pm
Normal file
@ -0,0 +1,26 @@
|
||||
=head1 NAME
|
||||
|
||||
GT::JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# do not "use" yourself
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module exists only to provide overload resolution for Storable and similar modules. See
|
||||
L<GT::JSON::PP> for more info about this class.
|
||||
|
||||
=cut
|
||||
|
||||
use GT::JSON::PP ();
|
||||
use strict;
|
||||
|
||||
1;
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
|
||||
|
||||
=cut
|
||||
|
||||
148
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP5005.pm
Normal file
148
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP5005.pm
Normal file
@ -0,0 +1,148 @@
|
||||
package GT::JSON::PP5005;
|
||||
|
||||
use 5.005;
|
||||
use strict;
|
||||
|
||||
my @properties;
|
||||
|
||||
$GT::JSON::PP5005::VERSION = '1.08';
|
||||
|
||||
BEGIN {
|
||||
|
||||
sub utf8::is_utf8 {
|
||||
0; # It is considered that UTF8 flag off for Perl 5.005.
|
||||
}
|
||||
|
||||
sub utf8::upgrade {
|
||||
}
|
||||
|
||||
sub utf8::downgrade {
|
||||
1; # must always return true.
|
||||
}
|
||||
|
||||
sub utf8::encode {
|
||||
}
|
||||
|
||||
sub utf8::decode {
|
||||
}
|
||||
|
||||
*GT::JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
|
||||
*GT::JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
|
||||
*GT::JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
|
||||
*GT::JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
|
||||
|
||||
# missing in B module.
|
||||
sub B::SVf_IOK () { 0x00010000; }
|
||||
sub B::SVf_NOK () { 0x00020000; }
|
||||
sub B::SVf_POK () { 0x00040000; }
|
||||
sub B::SVp_IOK () { 0x01000000; }
|
||||
sub B::SVp_NOK () { 0x02000000; }
|
||||
|
||||
$INC{'bytes.pm'} = 1; # dummy
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub _encode_ascii {
|
||||
join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) );
|
||||
}
|
||||
|
||||
|
||||
sub _encode_latin1 {
|
||||
join('', map { chr($_) } unpack('C*', $_[0]) );
|
||||
}
|
||||
|
||||
|
||||
sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm
|
||||
my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode
|
||||
my $bit = unpack('B32', pack('N', $uni));
|
||||
|
||||
if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) {
|
||||
my ($w, $x, $y, $z) = ($1, $2, $3, $4);
|
||||
return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z));
|
||||
}
|
||||
else {
|
||||
Carp::croak("Invalid surrogate pair");
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub _decode_unicode {
|
||||
my ($u) = @_;
|
||||
my ($utf8bit);
|
||||
|
||||
if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff
|
||||
return pack( 'H2', $1 );
|
||||
}
|
||||
|
||||
my $bit = unpack("B*", pack("H*", $u));
|
||||
|
||||
if ( $bit =~ /^00000(.....)(......)$/ ) {
|
||||
$utf8bit = sprintf('110%s10%s', $1, $2);
|
||||
}
|
||||
elsif ( $bit =~ /^(....)(......)(......)$/ ) {
|
||||
$utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3);
|
||||
}
|
||||
else {
|
||||
Carp::croak("Invalid escaped unicode");
|
||||
}
|
||||
|
||||
return pack('B*', $utf8bit);
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_parse {
|
||||
local $Carp::CarpLevel = 1;
|
||||
( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_parse( @_ );
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_text {
|
||||
$_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new;
|
||||
|
||||
if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
|
||||
Carp::croak("incr_text can not be called when the incremental parser already started parsing");
|
||||
}
|
||||
|
||||
$_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 );
|
||||
$_[0]->{_incr_parser}->{incr_text};
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_skip {
|
||||
( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_skip;
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_reset {
|
||||
( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_reset;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::JSON::PP5005 - Helper module in using GT::JSON::PP in Perl 5.005
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::JSON::PP calls internally.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
|
||||
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2007-2008 by Makamaka Hannyaharamitu
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
198
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP56.pm
Normal file
198
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP56.pm
Normal file
@ -0,0 +1,198 @@
|
||||
package GT::JSON::PP56;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
|
||||
my @properties;
|
||||
|
||||
$GT::JSON::PP56::VERSION = '1.07';
|
||||
|
||||
BEGIN {
|
||||
|
||||
sub utf8::is_utf8 {
|
||||
my $len = length $_[0]; # char length
|
||||
{
|
||||
use bytes; # byte length;
|
||||
return $len != length $_[0]; # if !=, UTF8-flagged on.
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub utf8::upgrade {
|
||||
; # noop;
|
||||
}
|
||||
|
||||
|
||||
sub utf8::downgrade ($;$) {
|
||||
return 1 unless ( utf8::is_utf8( $_[0] ) );
|
||||
|
||||
if ( _is_valid_utf8( $_[0] ) ) {
|
||||
my $downgrade;
|
||||
for my $c ( unpack( "U*", $_[0] ) ) {
|
||||
if ( $c < 256 ) {
|
||||
$downgrade .= pack("C", $c);
|
||||
}
|
||||
else {
|
||||
$downgrade .= pack("U", $c);
|
||||
}
|
||||
}
|
||||
$_[0] = $downgrade;
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
Carp::croak("Wide character in subroutine entry") unless ( $_[1] );
|
||||
0;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub utf8::encode ($) { # UTF8 flag off
|
||||
if ( utf8::is_utf8( $_[0] ) ) {
|
||||
$_[0] = pack( "C*", unpack( "C*", $_[0] ) );
|
||||
}
|
||||
else {
|
||||
$_[0] = pack( "U*", unpack( "C*", $_[0] ) );
|
||||
$_[0] = pack( "C*", unpack( "C*", $_[0] ) );
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub utf8::decode ($) { # UTF8 flag on
|
||||
if ( _is_valid_utf8( $_[0] ) ) {
|
||||
utf8::downgrade( $_[0] );
|
||||
$_[0] = pack( "U*", unpack( "U*", $_[0] ) );
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
*GT::JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
|
||||
*GT::JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
|
||||
*GT::JSON::PP::JSON_PP_decode_surrogates = \>::JSON::PP::_decode_surrogates;
|
||||
*GT::JSON::PP::JSON_PP_decode_unicode = \>::JSON::PP::_decode_unicode;
|
||||
|
||||
unless ( defined &B::SVp_NOK ) { # missing in B module.
|
||||
eval q{ sub B::SVp_NOK () { 0x02000000; } };
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
||||
sub _encode_ascii {
|
||||
join('',
|
||||
map {
|
||||
$_ <= 127 ?
|
||||
chr($_) :
|
||||
$_ <= 65535 ?
|
||||
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', GT::JSON::PP::_encode_surrogates($_));
|
||||
} _unpack_emu($_[0])
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
sub _encode_latin1 {
|
||||
join('',
|
||||
map {
|
||||
$_ <= 255 ?
|
||||
chr($_) :
|
||||
$_ <= 65535 ?
|
||||
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', GT::JSON::PP::_encode_surrogates($_));
|
||||
} _unpack_emu($_[0])
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
sub _unpack_emu { # for Perl 5.6 unpack warnings
|
||||
return !utf8::is_utf8($_[0]) ? unpack('C*', $_[0])
|
||||
: _is_valid_utf8($_[0]) ? unpack('U*', $_[0])
|
||||
: unpack('C*', $_[0]);
|
||||
}
|
||||
|
||||
|
||||
sub _is_valid_utf8 {
|
||||
my $str = $_[0];
|
||||
my $is_utf8;
|
||||
|
||||
while ($str =~ /(?:
|
||||
(
|
||||
[\x00-\x7F]
|
||||
|[\xC2-\xDF][\x80-\xBF]
|
||||
|[\xE0][\xA0-\xBF][\x80-\xBF]
|
||||
|[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
|
||||
|[\xED][\x80-\x9F][\x80-\xBF]
|
||||
|[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
|
||||
|[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
|
||||
|[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
|
||||
|[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
|
||||
)
|
||||
| (.)
|
||||
)/xg)
|
||||
{
|
||||
if (defined $1) {
|
||||
$is_utf8 = 1 if (!defined $is_utf8);
|
||||
}
|
||||
else {
|
||||
$is_utf8 = 0 if (!defined $is_utf8);
|
||||
if ($is_utf8) { # eventually, not utf8
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return $is_utf8;
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_parse {
|
||||
local $Carp::CarpLevel = 1;
|
||||
( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_parse( @_ );
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_text : lvalue {
|
||||
$_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new;
|
||||
|
||||
if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
|
||||
Carp::croak("incr_text can not be called when the incremental parser already started parsing");
|
||||
}
|
||||
$_[0]->{_incr_parser}->{incr_text};
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_skip {
|
||||
( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_skip;
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_reset {
|
||||
( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_reset;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::JSON::PP56 - Helper module in using GT::JSON::PP in Perl 5.6
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::JSON::PP calls internally.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
|
||||
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2007-2008 by Makamaka Hannyaharamitu
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
93
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP58.pm
Normal file
93
site/slowtwitch.com/cgi-bin/articles/GT/JSON/PP58.pm
Normal file
@ -0,0 +1,93 @@
|
||||
package GT::JSON::PP58;
|
||||
|
||||
use 5.008;
|
||||
use strict;
|
||||
|
||||
my @properties;
|
||||
|
||||
$GT::JSON::PP58::VERSION = '1.02';
|
||||
|
||||
|
||||
BEGIN {
|
||||
|
||||
unless ( defined &utf8::is_utf8 ) {
|
||||
require Encode;
|
||||
*utf8::is_utf8 = *Encode::is_utf8;
|
||||
}
|
||||
|
||||
*GT::JSON::PP::JSON_PP_encode_ascii = \>::JSON::PP::_encode_ascii;
|
||||
*GT::JSON::PP::JSON_PP_encode_latin1 = \>::JSON::PP::_encode_latin1;
|
||||
*GT::JSON::PP::JSON_PP_decode_surrogates = \>::JSON::PP::_decode_surrogates;
|
||||
*GT::JSON::PP::JSON_PP_decode_unicode = \>::JSON::PP::_decode_unicode;
|
||||
|
||||
if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
|
||||
package GT::JSON::PP;
|
||||
require subs;
|
||||
subs->import('join');
|
||||
eval q|
|
||||
sub join {
|
||||
return '' if (@_ < 2);
|
||||
my $j = shift;
|
||||
my $str = shift;
|
||||
for (@_) { $str .= $j . $_; }
|
||||
return $str;
|
||||
}
|
||||
|;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_parse {
|
||||
local $Carp::CarpLevel = 1;
|
||||
( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_parse( @_ );
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_text : lvalue {
|
||||
$_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new;
|
||||
|
||||
if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
|
||||
Carp::croak("incr_text can not be called when the incremental parser already started parsing");
|
||||
}
|
||||
$_[0]->{_incr_parser}->{incr_text};
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_skip {
|
||||
( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_skip;
|
||||
}
|
||||
|
||||
|
||||
sub GT::JSON::PP::incr_reset {
|
||||
( $_[0]->{_incr_parser} ||= GT::JSON::PP::IncrParser->new )->incr_reset;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::JSON::PP58 - Helper module in using GT::JSON::PP in Perl 5.8 and lator
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::JSON::PP calls internally.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
|
||||
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2008 by Makamaka Hannyaharamitu
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
178
site/slowtwitch.com/cgi-bin/articles/GT/Lock.pm
Normal file
178
site/slowtwitch.com/cgi-bin/articles/GT/Lock.pm
Normal file
@ -0,0 +1,178 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Lock
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Lock.pm,v 1.7 2007/02/11 21:56:56 sbeck Exp $
|
||||
#
|
||||
# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: a small autonomous locking module.
|
||||
#
|
||||
package GT::Lock;
|
||||
|
||||
use vars qw/@EXPORT_OK $error $SAFETY $ERRORS/;
|
||||
use strict;
|
||||
use bases
|
||||
'Exporter' => '',
|
||||
'GT::Base' => '';
|
||||
|
||||
use constants
|
||||
MASK => 0777,
|
||||
SLEEPTIME => 0.05,
|
||||
TIMEOUT => 10,
|
||||
LOCK_TRY => 1,
|
||||
LOCK_FORCE => 2;
|
||||
|
||||
use POSIX qw/errno_h/;
|
||||
use GT::TempFile;
|
||||
|
||||
$ERRORS = {
|
||||
'TIMEOUT' => 'Could not lock %s; We timed out',
|
||||
'NOLOCK' => 'No lock was found for name %s'
|
||||
};
|
||||
@EXPORT_OK = qw/lock unlock LOCK_FORCE LOCK_TRY/;
|
||||
|
||||
sub lock {
|
||||
#---------------------------------------------------------------------------------
|
||||
defined( $_[0] ) or GT::Lock->fatal( BADARGS => 'First argument must be a defined value' );
|
||||
my $name = escape($_[0]);
|
||||
my $timeout = defined $_[1] ? $_[1] : TIMEOUT;
|
||||
my $opt = defined $_[2] ? $_[2] : LOCK_FORCE;
|
||||
my $max_age = $_[3];
|
||||
my $tmp_dir = $GT::TempFile::TMP_DIR || GT::TempFile::find_tmpdir();
|
||||
my $lock_dir = "$tmp_dir/$name";
|
||||
if ($max_age and -d $lock_dir and time - (stat $lock_dir)[9] > $max_age) {
|
||||
rmdir $lock_dir or $! == ENOENT or GT::Lock->fatal(RMDIR => $lock_dir, "$!");
|
||||
}
|
||||
my $start_time = time;
|
||||
until (mkdir $lock_dir, MASK) {
|
||||
select undef, undef, undef, SLEEPTIME;
|
||||
if ($timeout and $start_time + $timeout < time) {
|
||||
if ($opt == LOCK_TRY) {
|
||||
return GT::Lock->warn(TIMEOUT => unescape($name));
|
||||
}
|
||||
else {
|
||||
# XXX - 2 appears to be No such file or directory, but may not be entirely portable.
|
||||
unless (rmdir $lock_dir and $! != ENOENT) {
|
||||
# The rmdir failed which *may* be due to two processes
|
||||
# holding the same lock then the other one deleting it
|
||||
# just before this one attempted to. In such a case, we
|
||||
# allow double the timeout to try to avoid the race -
|
||||
# though this reduces the frequency of race conditions, it
|
||||
# does not completely eliminate it.
|
||||
if ($timeout and $start_time + 2 * $timeout < time) {
|
||||
GT::Lock->fatal(RMDIR => $lock_dir, "$!");
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub unlock {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $name = escape($_[0]);
|
||||
my $tmp_dir = $GT::TempFile::TMP_DIR || GT::TempFile::find_tmpdir();
|
||||
my $lock_dir = "$tmp_dir/$name";
|
||||
if (-d $lock_dir) {
|
||||
rmdir $lock_dir or return GT::Lock->fatal(RMDIR => $lock_dir, "$!");
|
||||
}
|
||||
else {
|
||||
return GT::Lock->warn(NOLOCK => $name);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub escape {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $toencode = $_[0];
|
||||
return unless (defined $toencode);
|
||||
$toencode =~ s/([^\w. -])/sprintf "%%%02X", ord $1/eg;
|
||||
$toencode =~ s/ /%20/g;
|
||||
return $toencode;
|
||||
}
|
||||
|
||||
sub unescape {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $todecode = $_[0];
|
||||
return unless (defined $todecode);
|
||||
$todecode =~ tr/+/ /; # pluses become spaces
|
||||
$todecode =~ s/%([0-9a-fA-F]{2})/chr hex $1/ge;
|
||||
return $todecode;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Lock - a small autonomous locking module.
|
||||
|
||||
=head2 SYNOPSIS
|
||||
|
||||
use GT::Lock qw/lock unlock LOCK_TRY LOCK_FORCE/;
|
||||
|
||||
# attempt to lock foobar for 10 seconds
|
||||
if (lock 'foobar', 10, LOCK_TRY) {
|
||||
# do some code that needs to be locked
|
||||
unlock 'foobar';
|
||||
}
|
||||
else {
|
||||
# oops out lock failed
|
||||
die "Lock failed: $GT::Lock::error\n";
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Lock is a very simple module to impliment autonomous named locking. Locking
|
||||
can be used for many things but is most commonly used to lock files for IO to
|
||||
them.
|
||||
|
||||
Nothing is exported by default. You may request the lock, unlock routines be
|
||||
exported. You can also get the two constants for lock types exported:
|
||||
C<LOCK_TRY> and C<LOCK_FORCE>.
|
||||
|
||||
=head2 lock - Lock a name.
|
||||
|
||||
lock NAME [, TIMOUT, TYPE, AGE ]
|
||||
|
||||
This method is used to create a lock. Its arguments are the name you wish to
|
||||
give the lock, the timeout in seconds for the lock to happen, the type of lock,
|
||||
and the maximum lock age (in seconds). The types are C<LOCK_FORCE> and
|
||||
C<LOCK_TRY>. If C<LOCK_FORCE> is given a lock always succeeds, e.g. if the
|
||||
lock times out the lock is removed and your lock succeeds. Try attempts to get
|
||||
the lock and returns false if the lock can not be had in the specified
|
||||
C<TIMEOUT>. If C<TIMEOUT> is zero this method will attempt to lock forever.
|
||||
C<TIMEOUT> defaults to 10 seconds. The AGE parameter can be used to ensure
|
||||
that stale locks are not preserved - if the lock already exists and is older
|
||||
than AGE seconds, it will be removed before attempting to get the lock.
|
||||
Omitting it uses the default value, undef, which does not attempt to remove
|
||||
stale locks.
|
||||
|
||||
=head2 unlock - unlock a name.
|
||||
|
||||
unlock NAME
|
||||
|
||||
This method is used to unlock a name. It's argument is the name of the lock to
|
||||
unlock. Returns true on success and false on errors and sets the error in
|
||||
$GT::Lock::error.
|
||||
|
||||
=head1 DEPENDANCIES
|
||||
|
||||
L<GT::Lock> depends on L<GT::TempFile>, L<bases>, and L<constants>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Lock.pm,v 1.7 2007/02/11 21:56:56 sbeck Exp $
|
||||
|
||||
=cut
|
||||
520
site/slowtwitch.com/cgi-bin/articles/GT/MD5.pm
Normal file
520
site/slowtwitch.com/cgi-bin/articles/GT/MD5.pm
Normal file
@ -0,0 +1,520 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::MD5
|
||||
# Author: Scott Beck (see pod for details)
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: MD5.pm,v 1.19 2004/11/17 01:23:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# See bottom for addition Copyrights.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: This is an implementation of the MD5 algorithm in perl.
|
||||
#
|
||||
|
||||
package GT::MD5;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORTER @EXPORT_OK $DATA);
|
||||
|
||||
@EXPORT_OK = qw(md5 md5_hex md5_base64);
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.19 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
$DATA = <<'END_OF_CODE';
|
||||
use integer;
|
||||
|
||||
# I-Vektor
|
||||
sub A() { 0x67_45_23_01 }
|
||||
sub B() { 0xef_cd_ab_89 }
|
||||
sub C() { 0x98_ba_dc_fe }
|
||||
sub D() { 0x10_32_54_76 }
|
||||
|
||||
# for internal use
|
||||
sub MAX() { 0xFFFFFFFF }
|
||||
|
||||
@GT::MD5::DATA = split "\n", q|
|
||||
FF,$a,$b,$c,$d,$_[4],7,0xd76aa478,/* 1 */
|
||||
FF,$d,$a,$b,$c,$_[5],12,0xe8c7b756,/* 2 */
|
||||
FF,$c,$d,$a,$b,$_[6],17,0x242070db,/* 3 */
|
||||
FF,$b,$c,$d,$a,$_[7],22,0xc1bdceee,/* 4 */
|
||||
FF,$a,$b,$c,$d,$_[8],7,0xf57c0faf,/* 5 */
|
||||
FF,$d,$a,$b,$c,$_[9],12,0x4787c62a,/* 6 */
|
||||
FF,$c,$d,$a,$b,$_[10],17,0xa8304613,/* 7 */
|
||||
FF,$b,$c,$d,$a,$_[11],22,0xfd469501,/* 8 */
|
||||
FF,$a,$b,$c,$d,$_[12],7,0x698098d8,/* 9 */
|
||||
FF,$d,$a,$b,$c,$_[13],12,0x8b44f7af,/* 10 */
|
||||
FF,$c,$d,$a,$b,$_[14],17,0xffff5bb1,/* 11 */
|
||||
FF,$b,$c,$d,$a,$_[15],22,0x895cd7be,/* 12 */
|
||||
FF,$a,$b,$c,$d,$_[16],7,0x6b901122,/* 13 */
|
||||
FF,$d,$a,$b,$c,$_[17],12,0xfd987193,/* 14 */
|
||||
FF,$c,$d,$a,$b,$_[18],17,0xa679438e,/* 15 */
|
||||
FF,$b,$c,$d,$a,$_[19],22,0x49b40821,/* 16 */
|
||||
GG,$a,$b,$c,$d,$_[5],5,0xf61e2562,/* 17 */
|
||||
GG,$d,$a,$b,$c,$_[10],9,0xc040b340,/* 18 */
|
||||
GG,$c,$d,$a,$b,$_[15],14,0x265e5a51,/* 19 */
|
||||
GG,$b,$c,$d,$a,$_[4],20,0xe9b6c7aa,/* 20 */
|
||||
GG,$a,$b,$c,$d,$_[9],5,0xd62f105d,/* 21 */
|
||||
GG,$d,$a,$b,$c,$_[14],9,0x2441453,/* 22 */
|
||||
GG,$c,$d,$a,$b,$_[19],14,0xd8a1e681,/* 23 */
|
||||
GG,$b,$c,$d,$a,$_[8],20,0xe7d3fbc8,/* 24 */
|
||||
GG,$a,$b,$c,$d,$_[13],5,0x21e1cde6,/* 25 */
|
||||
GG,$d,$a,$b,$c,$_[18],9,0xc33707d6,/* 26 */
|
||||
GG,$c,$d,$a,$b,$_[7],14,0xf4d50d87,/* 27 */
|
||||
GG,$b,$c,$d,$a,$_[12],20,0x455a14ed,/* 28 */
|
||||
GG,$a,$b,$c,$d,$_[17],5,0xa9e3e905,/* 29 */
|
||||
GG,$d,$a,$b,$c,$_[6],9,0xfcefa3f8,/* 30 */
|
||||
GG,$c,$d,$a,$b,$_[11],14,0x676f02d9,/* 31 */
|
||||
GG,$b,$c,$d,$a,$_[16],20,0x8d2a4c8a,/* 32 */
|
||||
HH,$a,$b,$c,$d,$_[9],4,0xfffa3942,/* 33 */
|
||||
HH,$d,$a,$b,$c,$_[12],11,0x8771f681,/* 34 */
|
||||
HH,$c,$d,$a,$b,$_[15],16,0x6d9d6122,/* 35 */
|
||||
HH,$b,$c,$d,$a,$_[18],23,0xfde5380c,/* 36 */
|
||||
HH,$a,$b,$c,$d,$_[5],4,0xa4beea44,/* 37 */
|
||||
HH,$d,$a,$b,$c,$_[8],11,0x4bdecfa9,/* 38 */
|
||||
HH,$c,$d,$a,$b,$_[11],16,0xf6bb4b60,/* 39 */
|
||||
HH,$b,$c,$d,$a,$_[14],23,0xbebfbc70,/* 40 */
|
||||
HH,$a,$b,$c,$d,$_[17],4,0x289b7ec6,/* 41 */
|
||||
HH,$d,$a,$b,$c,$_[4],11,0xeaa127fa,/* 42 */
|
||||
HH,$c,$d,$a,$b,$_[7],16,0xd4ef3085,/* 43 */
|
||||
HH,$b,$c,$d,$a,$_[10],23,0x4881d05,/* 44 */
|
||||
HH,$a,$b,$c,$d,$_[13],4,0xd9d4d039,/* 45 */
|
||||
HH,$d,$a,$b,$c,$_[16],11,0xe6db99e5,/* 46 */
|
||||
HH,$c,$d,$a,$b,$_[19],16,0x1fa27cf8,/* 47 */
|
||||
HH,$b,$c,$d,$a,$_[6],23,0xc4ac5665,/* 48 */
|
||||
II,$a,$b,$c,$d,$_[4],6,0xf4292244,/* 49 */
|
||||
II,$d,$a,$b,$c,$_[11],10,0x432aff97,/* 50 */
|
||||
II,$c,$d,$a,$b,$_[18],15,0xab9423a7,/* 51 */
|
||||
II,$b,$c,$d,$a,$_[9],21,0xfc93a039,/* 52 */
|
||||
II,$a,$b,$c,$d,$_[16],6,0x655b59c3,/* 53 */
|
||||
II,$d,$a,$b,$c,$_[7],10,0x8f0ccc92,/* 54 */
|
||||
II,$c,$d,$a,$b,$_[14],15,0xffeff47d,/* 55 */
|
||||
II,$b,$c,$d,$a,$_[5],21,0x85845dd1,/* 56 */
|
||||
II,$a,$b,$c,$d,$_[12],6,0x6fa87e4f,/* 57 */
|
||||
II,$d,$a,$b,$c,$_[19],10,0xfe2ce6e0,/* 58 */
|
||||
II,$c,$d,$a,$b,$_[10],15,0xa3014314,/* 59 */
|
||||
II,$b,$c,$d,$a,$_[17],21,0x4e0811a1,/* 60 */
|
||||
II,$a,$b,$c,$d,$_[8],6,0xf7537e82,/* 61 */
|
||||
II,$d,$a,$b,$c,$_[15],10,0xbd3af235,/* 62 */
|
||||
II,$c,$d,$a,$b,$_[6],15,0x2ad7d2bb,/* 63 */
|
||||
II,$b,$c,$d,$a,$_[13],21,0xeb86d391,/* 64 */|;
|
||||
|
||||
|
||||
# padd a message to a multiple of 64
|
||||
sub padding {
|
||||
my $l = length (my $msg = shift() . chr(128));
|
||||
$msg .= "\0" x (($l%64<=56?56:120)-$l%64);
|
||||
$l = ($l-1)*8;
|
||||
$msg .= pack 'VV', $l & MAX , ($l >> 16 >> 16);
|
||||
}
|
||||
|
||||
|
||||
sub rotate_left($$) {
|
||||
#$_[0] << $_[1] | $_[0] >> (32 - $_[1]);
|
||||
#my $right = $_[0] >> (32 - $_[1]);
|
||||
#my $rmask = (1 << $_[1]) - 1;
|
||||
($_[0] << $_[1]) | (( $_[0] >> (32 - $_[1]) ) & ((1 << $_[1]) - 1));
|
||||
#$_[0] << $_[1] | (($_[0]>> (32 - $_[1])) & (1 << (32 - $_[1])) - 1);
|
||||
}
|
||||
|
||||
sub gen_code {
|
||||
# Discard upper 32 bits on 64 bit archs.
|
||||
my $MSK = ((1 << 16) << 16) ? ' & ' . MAX : '';
|
||||
# FF => "X0=rotate_left(((X1&X2)|(~X1&X3))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
# GG => "X0=rotate_left(((X1&X3)|(X2&(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
my %f = (
|
||||
FF => "X0=rotate_left((X3^(X1&(X2^X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
GG => "X0=rotate_left((X2^(X3&(X1^X2)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
HH => "X0=rotate_left((X1^X2^X3)+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
II => "X0=rotate_left((X2^(X1|(~X3)))+X0+X4+X6$MSK,X5)+X1$MSK;",
|
||||
);
|
||||
#unless ( (1 << 16) << 16) { %f = %{$CODES{'32bit'}} }
|
||||
#else { %f = %{$CODES{'64bit'}} }
|
||||
|
||||
my %s = ( # shift lengths
|
||||
S11 => 7, S12 => 12, S13 => 17, S14 => 22, S21 => 5, S22 => 9, S23 => 14,
|
||||
S24 => 20, S31 => 4, S32 => 11, S33 => 16, S34 => 23, S41 => 6, S42 => 10,
|
||||
S43 => 15, S44 => 21
|
||||
);
|
||||
|
||||
my $insert = "\n";
|
||||
# while(<DATA>) {
|
||||
for (@GT::MD5::DATA) {
|
||||
# chomp;
|
||||
next unless /^[FGHI]/;
|
||||
my ($func,@x) = split /,/;
|
||||
my $c = $f{$func};
|
||||
$c =~ s/X(\d)/$x[$1]/g;
|
||||
$c =~ s/(S\d{2})/$s{$1}/;
|
||||
$c =~ s/^(.*)=rotate_left\((.*),(.*)\)\+(.*)$//;
|
||||
|
||||
my $su = 32 - $3;
|
||||
my $sh = (1 << $3) - 1;
|
||||
|
||||
$c = "$1=(((\$r=$2)<<$3)|((\$r>>$su)&$sh))+$4";
|
||||
|
||||
#my $rotate = "(($2 << $3) || (($2 >> (32 - $3)) & (1 << $2) - 1)))";
|
||||
# $c = "\$r = $2;
|
||||
# $1 = ((\$r << $3) | ((\$r >> (32 - $3)) & ((1 << $3) - 1))) + $4";
|
||||
$insert .= "\t$c\n";
|
||||
}
|
||||
# close DATA;
|
||||
|
||||
my $dump = '
|
||||
sub round {
|
||||
my ($a,$b,$c,$d) = @_[0 .. 3];
|
||||
my $r;' . $insert . '
|
||||
$_[0]+$a' . $MSK . ', $_[1]+$b ' . $MSK .
|
||||
', $_[2]+$c' . $MSK . ', $_[3]+$d' . $MSK . ';
|
||||
}';
|
||||
eval $dump;
|
||||
# print "$dump\n";
|
||||
# exit 0;
|
||||
}
|
||||
|
||||
gen_code();
|
||||
|
||||
#########################################
|
||||
# Private output converter functions:
|
||||
sub _encode_hex { unpack 'H*', $_[0] }
|
||||
sub _encode_base64 {
|
||||
my $res;
|
||||
while ($_[0] =~ /(.{1,45})/gs) {
|
||||
$res .= substr pack('u', $1), 1;
|
||||
chop $res;
|
||||
}
|
||||
$res =~ tr|` -_|AA-Za-z0-9+/|;#`
|
||||
chop $res; chop $res;
|
||||
$res
|
||||
}
|
||||
|
||||
#########################################
|
||||
# OOP interface:
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref $proto || $proto;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
$self->reset();
|
||||
$self
|
||||
}
|
||||
|
||||
sub reset {
|
||||
my $self = shift;
|
||||
delete $self->{_data};
|
||||
$self->{_state} = [A,B,C,D];
|
||||
$self->{_length} = 0;
|
||||
$self
|
||||
}
|
||||
|
||||
sub add {
|
||||
my $self = shift;
|
||||
$self->{_data} .= join '', @_ if @_;
|
||||
my ($i,$c);
|
||||
for $i (0 .. (length $self->{_data})/64-1) {
|
||||
my @X = unpack 'V16', substr $self->{_data}, $i*64, 64;
|
||||
@{$self->{_state}} = round(@{$self->{_state}},@X);
|
||||
++$c;
|
||||
}
|
||||
if ($c) {
|
||||
substr ($self->{_data}, 0, $c*64) = '';
|
||||
$self->{_length} += $c*64;
|
||||
}
|
||||
$self
|
||||
}
|
||||
|
||||
sub finalize {
|
||||
my $self = shift;
|
||||
$self->{_data} .= chr(128);
|
||||
my $l = $self->{_length} + length $self->{_data};
|
||||
$self->{_data} .= "\0" x (($l%64<=56?56:120)-$l%64);
|
||||
$l = ($l-1)*8;
|
||||
$self->{_data} .= pack 'VV', $l & MAX , ($l >> 16 >> 16);
|
||||
$self->add();
|
||||
$self
|
||||
}
|
||||
|
||||
sub addfile {
|
||||
my ($self,$fh) = @_;
|
||||
if (!ref($fh) && ref(\$fh) ne "GLOB") {
|
||||
require Symbol;
|
||||
$fh = Symbol::qualify($fh, scalar caller);
|
||||
}
|
||||
# $self->{_data} .= do{local$/;<$fh>};
|
||||
my $read = 0;
|
||||
my $buffer = '';
|
||||
$self->add($buffer) while $read = read $fh, $buffer, 8192;
|
||||
die "GT::MD5 read failed: $!" unless defined $read;
|
||||
$self
|
||||
}
|
||||
|
||||
sub add_bits {
|
||||
my $self = shift;
|
||||
return $self->add( pack 'B*', shift ) if @_ == 1;
|
||||
my ($b,$n) = @_;
|
||||
die "GT::MD5 Invalid number of bits\n" if $n%8;
|
||||
$self->add( substr $b, 0, $n/8 )
|
||||
}
|
||||
|
||||
sub digest {
|
||||
my $self = shift;
|
||||
$self->finalize();
|
||||
my $res = pack 'V4', @{$self->{_state}};
|
||||
$self->reset();
|
||||
$res
|
||||
}
|
||||
|
||||
sub hexdigest {
|
||||
_encode_hex($_[0]->digest)
|
||||
}
|
||||
|
||||
sub b64digest {
|
||||
_encode_base64($_[0]->digest)
|
||||
}
|
||||
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
my $clone = {
|
||||
_state => [@{$self->{_state}}],
|
||||
_length => $self->{_length},
|
||||
_data => $self->{_data}
|
||||
};
|
||||
bless $clone, ref $self || $self;
|
||||
}
|
||||
|
||||
#########################################
|
||||
# Procedural interface:
|
||||
sub md5 {
|
||||
my $message = padding(join'',@_);
|
||||
my ($a,$b,$c,$d) = (A,B,C,D);
|
||||
my $i;
|
||||
for $i (0 .. (length $message)/64-1) {
|
||||
my @X = unpack 'V16', substr $message,$i*64,64;
|
||||
($a,$b,$c,$d) = round($a,$b,$c,$d,@X);
|
||||
}
|
||||
pack 'V4',$a,$b,$c,$d;
|
||||
}
|
||||
sub md5_hex { _encode_hex &md5 }
|
||||
sub md5_base64 { _encode_base64 &md5 }
|
||||
END_OF_CODE
|
||||
|
||||
# Load either Digest::MD5 or GT::MD5 functions.
|
||||
eval {
|
||||
local $SIG{__DIE__};
|
||||
require Digest::MD5;
|
||||
foreach (@EXPORT_OK) { delete $GT::MD5::{$_}; } # Do not remove.
|
||||
import Digest::MD5 (@EXPORT_OK);
|
||||
*GT::MD5::md5_hex = sub { &Digest::MD5::md5_hex };
|
||||
*GT::MD5::md5 = sub { &Digest::MD5::md5 };
|
||||
*GT::MD5::md5_base64 = sub { &Digest::MD5::md5_base64 };
|
||||
@ISA = 'Digest::MD5';
|
||||
1;
|
||||
}
|
||||
or do {
|
||||
local $@;
|
||||
eval $DATA;
|
||||
$@ and die "GT::MD5 => can't compile: $@";
|
||||
};
|
||||
|
||||
require Exporter;
|
||||
import Exporter;
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::MD5 - Perl implementation of Ron Rivests MD5 Algorithm
|
||||
|
||||
=head1 DISCLAIMER
|
||||
|
||||
Majority of this module's code is borrowed from Digest::Perl::MD5 (Version 1.8).
|
||||
|
||||
This is B<not> an interface (like C<Digest::MD5>) but a Perl implementation of MD5.
|
||||
It is written in perl only and because of this it is slow but it works without C-Code.
|
||||
You should use C<Digest::MD5> instead of this module if it is available.
|
||||
This module is only usefull for
|
||||
|
||||
=over 4
|
||||
|
||||
=item
|
||||
|
||||
computers where you cannot install C<Digest::MD5> (e.g. lack of a C-Compiler)
|
||||
|
||||
=item
|
||||
|
||||
encrypting only small amounts of data (less than one million bytes). I use it to
|
||||
hash passwords.
|
||||
|
||||
=item
|
||||
|
||||
educational purposes
|
||||
|
||||
=back
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Functional style
|
||||
use Digest::MD5 qw(md5 md5_hex md5_base64);
|
||||
|
||||
$hash = md5 $data;
|
||||
$hash = md5_hex $data;
|
||||
$hash = md5_base64 $data;
|
||||
|
||||
|
||||
# OO style
|
||||
use Digest::MD5;
|
||||
|
||||
$ctx = Digest::MD5->new;
|
||||
|
||||
$ctx->add($data);
|
||||
$ctx->addfile(*FILE);
|
||||
|
||||
$digest = $ctx->digest;
|
||||
$digest = $ctx->hexdigest;
|
||||
$digest = $ctx->b64digest;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This modules has the same interface as the much faster C<Digest::MD5>. So you can
|
||||
easily exchange them, e.g.
|
||||
|
||||
BEGIN {
|
||||
eval {
|
||||
require Digest::MD5;
|
||||
import Digest::MD5 'md5_hex'
|
||||
};
|
||||
if ($@) { # ups, no Digest::MD5
|
||||
require Digest::Perl::MD5;
|
||||
import Digest::Perl::MD5 'md5_hex'
|
||||
}
|
||||
}
|
||||
|
||||
If the C<Digest::MD5> module is available it is used and if not you take
|
||||
C<Digest::Perl::MD5>.
|
||||
|
||||
You can also install the Perl part of Digest::MD5 together with Digest::Perl::MD5
|
||||
and use Digest::MD5 as normal, it falls back to Digest::Perl::MD5 if it
|
||||
cannot load its object files.
|
||||
|
||||
For a detailed Documentation see the C<Digest::MD5> module.
|
||||
|
||||
=head1 EXAMPLES
|
||||
|
||||
The simplest way to use this library is to import the md5_hex()
|
||||
function (or one of its cousins):
|
||||
|
||||
use Digest::Perl::MD5 'md5_hex';
|
||||
print 'Digest is ', md5_hex('foobarbaz'), "\n";
|
||||
|
||||
The above example would print out the message
|
||||
|
||||
Digest is 6df23dc03f9b54cc38a0fc1483df6e21
|
||||
|
||||
provided that the implementation is working correctly. The same
|
||||
checksum can also be calculated in OO style:
|
||||
|
||||
use Digest::MD5;
|
||||
|
||||
$md5 = Digest::MD5->new;
|
||||
$md5->add('foo', 'bar');
|
||||
$md5->add('baz');
|
||||
$digest = $md5->hexdigest;
|
||||
|
||||
print "Digest is $digest\n";
|
||||
|
||||
The digest methods are destructive. That means you can only call them
|
||||
once and the $md5 objects is reset after use. You can make a copy with clone:
|
||||
|
||||
$md5->clone->hexdigest
|
||||
|
||||
=head1 LIMITATIONS
|
||||
|
||||
This implementation of the MD5 algorithm has some limitations:
|
||||
|
||||
=over 4
|
||||
|
||||
=item
|
||||
|
||||
It's slow, very slow. I've done my very best but Digest::MD5 is still about 100 times faster.
|
||||
You can only encrypt Data up to one million bytes in an acceptable time. But it's very usefull
|
||||
for encrypting small amounts of data like passwords.
|
||||
|
||||
=item
|
||||
|
||||
You can only encrypt up to 2^32 bits = 512 MB on 32bit archs. But You should
|
||||
use C<Digest::MD5> for those amounts of data anyway.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Digest::MD5>
|
||||
|
||||
L<md5(1)>
|
||||
|
||||
RFC 1321
|
||||
|
||||
tools/md5: a small BSD compatible md5 tool written in pure perl.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
Copyright 2000 Christian Lackas, Imperia Software Solutions
|
||||
Copyright 1998-1999 Gisle Aas.
|
||||
Copyright 1995-1996 Neil Winton.
|
||||
Copyright 1991-1992 RSA Data Security, Inc.
|
||||
|
||||
The MD5 algorithm is defined in RFC 1321. The basic C code
|
||||
implementing the algorithm is derived from that in the RFC and is
|
||||
covered by the following copyright:
|
||||
|
||||
=over 4
|
||||
|
||||
=item
|
||||
|
||||
Copyright (C) 1991-1992, RSA Data Security, Inc. Created 1991. All
|
||||
rights reserved.
|
||||
|
||||
License to copy and use this software is granted provided that it
|
||||
is identified as the "RSA Data Security, Inc. MD5 Message-Digest
|
||||
Algorithm" in all material mentioning or referencing this software
|
||||
or this function.
|
||||
|
||||
License is also granted to make and use derivative works provided
|
||||
that such works are identified as "derived from the RSA Data
|
||||
Security, Inc. MD5 Message-Digest Algorithm" in all material
|
||||
mentioning or referencing the derived work.
|
||||
|
||||
RSA Data Security, Inc. makes no representations concerning either
|
||||
the merchantability of this software or the suitability of this
|
||||
software for any particular purpose. It is provided "as is"
|
||||
without express or implied warranty of any kind.
|
||||
|
||||
These notices must be retained in any copies of any part of this
|
||||
documentation and/or software.
|
||||
|
||||
=back
|
||||
|
||||
This copyright does not prohibit distribution of any version of Perl
|
||||
containing this extension under the terms of the GNU or Artistic
|
||||
licenses.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
The original MD5 interface was written by Neil Winton
|
||||
(<N.Winton (at) axion.bt.co.uk>).
|
||||
|
||||
C<Digest::MD5> was made by Gisle Aas <gisle (at) aas.no> (I took his Interface
|
||||
and part of the documentation).
|
||||
|
||||
Thanks to Guido Flohr for his 'use integer'-hint.
|
||||
|
||||
This release was made by Christian Lackas <delta (at) lackas.net>.
|
||||
|
||||
=cut
|
||||
175
site/slowtwitch.com/cgi-bin/articles/GT/MD5/Crypt.pm
Normal file
175
site/slowtwitch.com/cgi-bin/articles/GT/MD5/Crypt.pm
Normal file
@ -0,0 +1,175 @@
|
||||
# GT::MD5::Crypt - adapted from CPAN Crypt::PasswdMD5 for use in the
|
||||
# Gossamer Thread module library. gt_md5_crypt was added which uses
|
||||
# "$GT$" as the magic string instead of the unix "$1$" or apache "$apr1$"
|
||||
#
|
||||
# Crypt::PasswdMD5: Module to provide an interoperable crypt()
|
||||
# function for modern Unix O/S. This is based on the code for
|
||||
#
|
||||
# /usr/src/libcrypt/crypt.c
|
||||
#
|
||||
# on a FreeBSD 2.2.5-RELEASE system, which included the following
|
||||
# notice.
|
||||
#
|
||||
# ----------------------------------------------------------------------------
|
||||
# "THE BEER-WARE LICENSE" (Revision 42):
|
||||
# <phk@login.dknet.dk> wrote this file. As long as you retain this notice you
|
||||
# can do whatever you want with this stuff. If we meet some day, and you think
|
||||
# this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp
|
||||
# ----------------------------------------------------------------------------
|
||||
#
|
||||
# 19980710 lem@cantv.net: Initial release
|
||||
# 19990402 bryan@eai.com: Added apache_md5_crypt to create a valid hash
|
||||
# for use in .htpasswd files
|
||||
# 20001006 wrowe@lnd.com: Requested apache_md5_crypt to be
|
||||
# exported by default.
|
||||
#
|
||||
################
|
||||
|
||||
package GT::MD5::Crypt;
|
||||
$VERSION='1.1';
|
||||
require 5.000;
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(unix_md5_crypt apache_md5_crypt gt_md5_crypt);
|
||||
|
||||
|
||||
$Magic = '$1$'; # Magic string
|
||||
$itoa64 = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
|
||||
|
||||
local $^W;
|
||||
|
||||
use GT::MD5;
|
||||
|
||||
sub to64 {
|
||||
my ($v, $n) = @_;
|
||||
my $ret = '';
|
||||
while (--$n >= 0) {
|
||||
$ret .= substr($itoa64, $v & 0x3f, 1);
|
||||
$v >>= 6;
|
||||
}
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub apache_md5_crypt {
|
||||
# change the Magic string to match the one used by Apache
|
||||
local $Magic = '$apr1$';
|
||||
|
||||
unix_md5_crypt(@_);
|
||||
}
|
||||
|
||||
sub gt_md5_crypt {
|
||||
# change the Magic string to put our signature in the password
|
||||
local $Magic = '$GT$';
|
||||
|
||||
unix_md5_crypt(@_);
|
||||
}
|
||||
|
||||
sub unix_md5_crypt {
|
||||
my($pw, $salt) = @_;
|
||||
my $passwd;
|
||||
|
||||
$salt =~ s/^\Q$Magic//; # Take care of the magic string if
|
||||
# if present.
|
||||
|
||||
$salt =~ s/^(.*)\$.*$/$1/; # Salt can have up to 8 chars...
|
||||
$salt = substr($salt, 0, 8);
|
||||
|
||||
$ctx = new GT::MD5; # Here we start the calculation
|
||||
$ctx->add($pw); # Original password...
|
||||
$ctx->add($Magic); # ...our magic string...
|
||||
$ctx->add($salt); # ...the salt...
|
||||
|
||||
my ($final) = new GT::MD5;
|
||||
$final->add($pw);
|
||||
$final->add($salt);
|
||||
$final->add($pw);
|
||||
$final = $final->digest;
|
||||
|
||||
for ($pl = length($pw); $pl > 0; $pl -= 16) {
|
||||
$ctx->add(substr($final, 0, $pl > 16 ? 16 : $pl));
|
||||
}
|
||||
|
||||
# Now the 'weird' xform
|
||||
|
||||
for ($i = length($pw); $i; $i >>= 1) {
|
||||
if ($i & 1) { $ctx->add(pack("C", 0)); }
|
||||
# This comes from the original version,
|
||||
# where a memset() is done to $final
|
||||
# before this loop.
|
||||
else { $ctx->add(substr($pw, 0, 1)); }
|
||||
}
|
||||
|
||||
$final = $ctx->digest;
|
||||
# The following is supposed to make
|
||||
# things run slower. In perl, perhaps
|
||||
# it'll be *really* slow!
|
||||
|
||||
for ($i = 0; $i < 1000; $i++) {
|
||||
$ctx1 = new GT::MD5;
|
||||
if ($i & 1) { $ctx1->add($pw); }
|
||||
else { $ctx1->add(substr($final, 0, 16)); }
|
||||
if ($i % 3) { $ctx1->add($salt); }
|
||||
if ($i % 7) { $ctx1->add($pw); }
|
||||
if ($i & 1) { $ctx1->add(substr($final, 0, 16)); }
|
||||
else { $ctx1->add($pw); }
|
||||
$final = $ctx1->digest;
|
||||
}
|
||||
|
||||
# Final xform
|
||||
|
||||
$passwd = '';
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 0, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 6, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 12, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 1, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 7, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 13, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 2, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 8, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 14, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 3, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 9, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 15, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", (substr($final, 4, 1))) << 16)
|
||||
| int(unpack("C", (substr($final, 10, 1))) << 8)
|
||||
| int(unpack("C", (substr($final, 5, 1)))), 4);
|
||||
$passwd .= to64(int(unpack("C", substr($final, 11, 1))), 2);
|
||||
|
||||
$final = '';
|
||||
$Magic . $salt . '$' . $passwd;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
unix_md5_crypt - Provides interoperable MD5-based crypt() function
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::MD5::Crypt;
|
||||
|
||||
$cryptedpassword = unix_md5_crypt($password, $salt);
|
||||
|
||||
$valid = $cryptedpassword eq unix_md5_crypt($password, $cryptedpassword);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
the C<unix_md5_crypt()> provides a crypt()-compatible interface to the
|
||||
rather new MD5-based crypt() function found in modern operating systems.
|
||||
It's based on the implementation found on FreeBSD 2.2.[56]-RELEASE and
|
||||
contains the following license in it:
|
||||
|
||||
"THE BEER-WARE LICENSE" (Revision 42):
|
||||
<phk@login.dknet.dk> wrote this file. As long as you retain this notice you
|
||||
can do whatever you want with this stuff. If we meet some day, and you think
|
||||
this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp
|
||||
|
||||
C<apache_md5_crypt()> provides a function compatible with Apache's
|
||||
C<.htpasswd> files. This was contributed by Bryan Hart <bryan@eai.com>.
|
||||
As suggested by William A. Rowe, Jr. <wrowe@lnd.com>, it is
|
||||
exported by default.
|
||||
|
||||
=cut
|
||||
457
site/slowtwitch.com/cgi-bin/articles/GT/MIMETypes.pm
Normal file
457
site/slowtwitch.com/cgi-bin/articles/GT/MIMETypes.pm
Normal file
@ -0,0 +1,457 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::MIMETypes
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: MIMETypes.pm,v 1.30 2012/01/26 00:36:19 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Provides methods to guess mime types.
|
||||
#
|
||||
|
||||
package GT::MIMETypes;
|
||||
# ===================================================================
|
||||
use strict;
|
||||
use vars qw/%CONTENT_EXT %MIME_EXT %MIME_TYPE/;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$COMPILE{guess_type} = __LINE__ . <<'END_OF_SUB';
|
||||
sub guess_type {
|
||||
# -------------------------------------------------------------------
|
||||
# Makes it's best guess based on input. Returns application/octet-stream
|
||||
# on failure to guess.
|
||||
# Possible arguments
|
||||
#{
|
||||
# filename => name of the file
|
||||
# filepath => full path to the file
|
||||
#}
|
||||
# No arguments are required but you will get application/octet-stream
|
||||
# with no arguments.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $msg = shift;
|
||||
|
||||
if (!ref $msg) {
|
||||
%CONTENT_EXT or content_ext();
|
||||
if ($msg =~ /\.([^.]+)$/ and exists $CONTENT_EXT{lc $1}) {
|
||||
return $CONTENT_EXT{lc $1};
|
||||
}
|
||||
else {
|
||||
return 'application/octet-stream';
|
||||
}
|
||||
}
|
||||
|
||||
# If we have a filename with an extension use that
|
||||
if ($msg->{filename} or $msg->{filepath}) {
|
||||
my $f;
|
||||
if ($msg->{filename}) {
|
||||
$f = $msg->{filename};
|
||||
}
|
||||
else {
|
||||
$f = $msg->{filepath};
|
||||
}
|
||||
%CONTENT_EXT or content_ext();
|
||||
if ($f =~ /\.([^.]+)$/ and exists $CONTENT_EXT{lc $1}) {
|
||||
return $CONTENT_EXT{lc $1};
|
||||
}
|
||||
}
|
||||
return 'application/octet-stream';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{guess_image} = __LINE__ . <<'END_OF_SUB';
|
||||
sub guess_image {
|
||||
# -------------------------------------------------------------------
|
||||
# Makes it's best guess based on input. Returns unknown.gif
|
||||
# on failure to guess.
|
||||
# Possible arguments
|
||||
#{
|
||||
# filename => name of the file
|
||||
# filepath => full path to the file
|
||||
# type => mime type
|
||||
#}
|
||||
# No arguments are required but you will get unknown.gif
|
||||
# with no arguments.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
my $msg = shift;
|
||||
my $image;
|
||||
|
||||
if (!ref $msg) {
|
||||
if ($msg =~ /\.([^.]+)$/) {
|
||||
%MIME_EXT or mime_ext();
|
||||
return $MIME_EXT{lc $1} || 'unknown.gif';
|
||||
}
|
||||
else {
|
||||
return 'unknown.gif';
|
||||
}
|
||||
}
|
||||
if ($msg->{filepath} and -d $msg->{filepath}) {
|
||||
return 'folder.gif';
|
||||
}
|
||||
|
||||
# If we have a filename with an extension use that
|
||||
my $f;
|
||||
if ($msg->{filename} or $msg->{filepath}) {
|
||||
if ($msg->{filename}) {
|
||||
$f = $msg->{filename};
|
||||
}
|
||||
else {
|
||||
$f = $msg->{filepath};
|
||||
}
|
||||
%MIME_EXT or mime_ext();
|
||||
if ($f =~ /\.([^.]+)$/ and exists $MIME_EXT{lc $1}) {
|
||||
return $MIME_EXT{lc $1};
|
||||
}
|
||||
}
|
||||
|
||||
# If a content type was passed in see if we know anything about it
|
||||
%MIME_TYPE or mime_type();
|
||||
if (exists $MIME_TYPE{$msg->{type} || $msg->{mime_type}}) {
|
||||
return $MIME_TYPE{$msg->{type} || $msg->{mime_type}};
|
||||
}
|
||||
|
||||
# No luck so far, resort to other means
|
||||
elsif ($msg->{filepath} and -B $msg->{filepath}) {
|
||||
return 'binary.gif';
|
||||
}
|
||||
elsif ($f and lc($f) =~ /readme/) {
|
||||
return 'readme.gif';
|
||||
}
|
||||
elsif ($msg->{filepath} and -T _) {
|
||||
return 'txt.gif';
|
||||
}
|
||||
|
||||
# Oops nothing
|
||||
return 'unknown.gif';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{mime_ext} = __LINE__ . <<'END_OF_SUB';
|
||||
sub mime_ext {
|
||||
# -------------------------------------------------------------------
|
||||
# Map file extension to image file
|
||||
#
|
||||
%MIME_EXT = (
|
||||
css => 'html.gif',
|
||||
htm => 'html.gif',
|
||||
html => 'html.gif',
|
||||
shtm => 'html.gif',
|
||||
shtml => 'html.gif',
|
||||
c => 'source.gif',
|
||||
cc => 'source.gif',
|
||||
'c++' => 'source.gif',
|
||||
cpp => 'source.gif',
|
||||
h => 'source.gif',
|
||||
pl => 'source.gif',
|
||||
pm => 'source.gif',
|
||||
cgi => 'source.gif',
|
||||
txt => 'txt.gif',
|
||||
text => 'txt.gif',
|
||||
diff => 'txt.gif',
|
||||
patch => 'txt.gif',
|
||||
eml => 'email.gif',
|
||||
email => 'email.gif',
|
||||
mime => 'email.gif',
|
||||
java => 'source.gif',
|
||||
el => 'source.gif',
|
||||
pdf => 'pdf.gif',
|
||||
dvi => 'dvi.gif',
|
||||
eds => 'postscript.gif',
|
||||
ai => 'postscript.gif',
|
||||
ps => 'postscript.gif',
|
||||
tex => 'tex.gif',
|
||||
texinfo => 'tex.gif',
|
||||
tar => 'tar.gif',
|
||||
ustar => 'tar.gif',
|
||||
tgz => 'tgz.gif',
|
||||
gz => 'tgz.gif',
|
||||
snd => 'sound.gif',
|
||||
au => 'sound.gif',
|
||||
aifc => 'sound.gif',
|
||||
aif => 'sound.gif',
|
||||
aiff => 'sound.gif',
|
||||
wav => 'sound.gif',
|
||||
mp3 => 'sound.gif',
|
||||
ogg => 'sound.gif',
|
||||
bmp => 'image.gif',
|
||||
gif => 'image.gif',
|
||||
ief => 'image.gif',
|
||||
jfif => 'image.gif',
|
||||
'jfif-tbnl' => 'image.gif',
|
||||
jpe => 'image.gif',
|
||||
jpg => 'image.gif',
|
||||
jpeg => 'image.gif',
|
||||
tif => 'image.gif',
|
||||
tiff => 'image.gif',
|
||||
fpx => 'image.gif',
|
||||
fpix => 'image.gif',
|
||||
ras => 'image.gif',
|
||||
pnm => 'image.gif',
|
||||
pbn => 'image.gif',
|
||||
pgm => 'image.gif',
|
||||
ppm => 'image.gif',
|
||||
rgb => 'image.gif',
|
||||
xbm => 'image.gif',
|
||||
xpm => 'image.gif',
|
||||
xwd => 'image.gif',
|
||||
png => 'image.gif',
|
||||
mpg => 'video.gif',
|
||||
mpe => 'video.gif',
|
||||
mpeg => 'video.gif',
|
||||
mov => 'video.gif',
|
||||
qt => 'video.gif',
|
||||
avi => 'video.gif',
|
||||
asf => 'video.gif',
|
||||
movie => 'video.gif',
|
||||
mv => 'video.gif',
|
||||
ogv => 'video.gif',
|
||||
mp4 => 'video.gif',
|
||||
webm => 'video.gif',
|
||||
wmv => 'wvideo.gif',
|
||||
wma => 'wvideo.gif',
|
||||
sh => 'shellscript.gif',
|
||||
rpm => 'rpm.gif',
|
||||
ttf => 'font_true.gif',
|
||||
doc => 'doc.gif',
|
||||
docx => 'doc.gif',
|
||||
xls => 'excel.gif',
|
||||
xlsx => 'excel.gif',
|
||||
ppt => 'ppt.gif',
|
||||
pptx => 'ppt.gif',
|
||||
zip => 'zip.gif'
|
||||
) unless keys %MIME_EXT;
|
||||
|
||||
%MIME_EXT;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{content_ext} = __LINE__ . <<'END_OF_SUB';
|
||||
sub content_ext {
|
||||
# -------------------------------------------------------------------
|
||||
# To guess the content-type for files by extension
|
||||
#
|
||||
%CONTENT_EXT = (
|
||||
doc => 'application/msword',
|
||||
docx => 'application/vnd.openxmlformats-officedocument.wordprocessingml.document',
|
||||
ppt => 'application/vnd.ms-powerpoint',
|
||||
pptx => 'application/vnd.openxmlformats-officedocument.presentationml.presentation',
|
||||
xls => 'application/vnd.ms-excel',
|
||||
xlsx => 'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet',
|
||||
oda => 'application/oda',
|
||||
pdf => 'application/pdf',
|
||||
eds => 'application/postscript',
|
||||
ai => 'application/postscript',
|
||||
ps => 'application/postscript',
|
||||
rtf => 'application/rtf',
|
||||
dvi => 'application/x-dvi',
|
||||
hdf => 'application/x-hdf',
|
||||
latex => 'application/x-latex',
|
||||
nc => 'application/x-netcdf',
|
||||
cdf => 'application/x-netcdf',
|
||||
tex => 'application/x-tex',
|
||||
texinfo => 'application/x-texinfo',
|
||||
texi => 'application/x-texinfo',
|
||||
t => 'application/x-troff',
|
||||
tr => 'application/x-troff',
|
||||
roff => 'application/x-troff',
|
||||
man => 'application/x-troff-man',
|
||||
me => 'application/x-troff-me',
|
||||
ms => 'application/x-troff-ms',
|
||||
src => 'application/x-wais-source',
|
||||
wsrc => 'application/x-wais-source',
|
||||
zip => 'application/zip',
|
||||
bcpio => 'application/x-bcpio',
|
||||
cpio => 'application/x-cpio',
|
||||
gtar => 'application/x-gtar',
|
||||
sh => 'application/x-shar',
|
||||
shar => 'application/x-shar',
|
||||
sv4cpio => 'application/x-sv4cpio',
|
||||
sv4crc => 'application/x-sv4crc',
|
||||
tar => 'application/x-tar',
|
||||
ustar => 'application/x-ustar',
|
||||
snd => 'audio/basic',
|
||||
au => 'audio/basic',
|
||||
aifc => 'audio/x-aiff',
|
||||
aif => 'audio/x-aiff',
|
||||
aiff => 'audio/x-aiff',
|
||||
wav => 'audio/x-wav',
|
||||
mp3 => 'audio/mpeg',
|
||||
ogg => 'application/ogg',
|
||||
bmp => 'image/bmp',
|
||||
gif => 'image/gif',
|
||||
ief => 'image/ief',
|
||||
jfif => 'image/jpeg',
|
||||
'jfif-tbnl' => 'image/jpeg',
|
||||
jpe => 'image/jpeg',
|
||||
jpg => 'image/jpeg',
|
||||
jpeg => 'image/jpeg',
|
||||
tif => 'image/tiff',
|
||||
tiff => 'image/tiff',
|
||||
fpx => 'image/vnd.fpx',
|
||||
fpix => 'image/vnd.fpx',
|
||||
ras => 'image/x-cmu-rast',
|
||||
pnm => 'image/x-portable-anymap',
|
||||
pbn => 'image/x-portable-bitmap',
|
||||
pgm => 'image/x-portable-graymap',
|
||||
ppm => 'image/x-portable-pixmap',
|
||||
rgb => 'image/x-rgb',
|
||||
xbm => 'image/x-xbitmap',
|
||||
xpm => 'image/x-xbitmap',
|
||||
xwd => 'image/x-xwindowdump',
|
||||
png => 'image/png',
|
||||
css => 'text/css',
|
||||
htm => 'text/html',
|
||||
html => 'text/html',
|
||||
shtml => 'text/html',
|
||||
text => 'text/plain',
|
||||
c => 'text/plain',
|
||||
cc => 'text/plain',
|
||||
'c++' => 'text/plain',
|
||||
h => 'text/plain',
|
||||
pl => 'text/plain',
|
||||
pm => 'text/plain',
|
||||
cgi => 'text/plain',
|
||||
txt => 'text/plain',
|
||||
java => 'text/plain',
|
||||
el => 'text/plain',
|
||||
diff => 'text/plain',
|
||||
patch => 'text/plain',
|
||||
tsv => 'text/tab-separated-values',
|
||||
etx => 'text/x-setext',
|
||||
ogv => 'video/ogg',
|
||||
mp4 => 'video/mp4',
|
||||
webm => 'video/webm',
|
||||
mpg => 'video/mpeg',
|
||||
mpe => 'video/mpeg',
|
||||
mpeg => 'video/mpeg',
|
||||
mov => 'video/quicktime',
|
||||
qt => 'video/quicktime',
|
||||
avi => 'application/x-troff-msvideo',
|
||||
asf => 'video/x-ms-asf',
|
||||
movie => 'video/x-sgi-movie',
|
||||
mv => 'video/x-sgi-movie',
|
||||
wmv => 'video/x-ms-wmv',
|
||||
wma => 'audio/x-ms-wma',
|
||||
mime => 'message/rfc822',
|
||||
eml => 'message/rfc822',
|
||||
xml => 'application/xml'
|
||||
) unless keys %CONTENT_EXT;
|
||||
|
||||
%CONTENT_EXT;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{mime_type} = __LINE__ . <<'END_OF_SUB';
|
||||
sub mime_type {
|
||||
# -------------------------------------------------------------------
|
||||
# Map content-type to image file
|
||||
#
|
||||
%MIME_TYPE = (
|
||||
'text/css' => 'html.gif',
|
||||
'text/html' => 'html.gif',
|
||||
'text/plain' => 'txt.gif',
|
||||
'application/pdf' => 'pdf.gif',
|
||||
'application/dvi' => 'dvi.gif',
|
||||
'application/postscript' => 'postscript.gif',
|
||||
'application/x-tex' => 'tex.gif',
|
||||
'application/x-texinfo' => 'tex.gif',
|
||||
'application/gtar' => 'tar.gif',
|
||||
'application/x-tar' => 'tar.gif',
|
||||
'application/x-ustar' => 'tar.gif',
|
||||
'application/zip' => 'zip.gif',
|
||||
'application/powerpoint' => 'ppt.gif',
|
||||
'application/mspowerpoint' => 'ppt.gif',
|
||||
'application/vnd.ms-powerpoint' => 'ppt.gif',
|
||||
'application/x-mspowerpoint' => 'ppt.gif',
|
||||
'application/vnd.openxmlformats-officedocument.presentationml.presentation' => 'ppt.gif',
|
||||
'application/msword' => 'doc.gif',
|
||||
'application/vnd.openxmlformats-officedocument.wordprocessingml.document' => 'doc.gif',
|
||||
'application/excel' => 'excel.gif',
|
||||
'application/msexcel' => 'excel.gif',
|
||||
'application/vnd.ms-excel' => 'excel.gif',
|
||||
'application/x-msexcel' => 'excel.gif',
|
||||
'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet', => 'excel.gif',
|
||||
'message/rfc822' => 'email.gif',
|
||||
'message/external-body' => 'email.gif',
|
||||
'multipart/alternative' => 'email.gif',
|
||||
'multipart/appledouble' => 'email.gif',
|
||||
'multipart/digest' => 'email.gif',
|
||||
'multipart/mixed' => 'email.gif',
|
||||
'multipart/voice-message' => 'sound.gif',
|
||||
'audio/basic' => 'sound.gif',
|
||||
'audio/x-aiff' => 'sound.gif',
|
||||
'audio/x-wav' => 'sound.gif',
|
||||
'audio/mpeg' => 'sound.gif',
|
||||
'application/ogg' => 'sound.gif',
|
||||
'image/gif' => 'image.gif',
|
||||
'image/ief' => 'image.gif',
|
||||
'image/jpeg' => 'image.gif',
|
||||
'image/tiff' => 'image.gif',
|
||||
'image/vnd.fpx' => 'image.gif',
|
||||
'image/x-cmu-rast' => 'image.gif',
|
||||
'image/x-portable-anymap' => 'image.gif',
|
||||
'image/x-portable-bitmap' => 'image.gif',
|
||||
'image/x-portable-graymap' => 'image.gif',
|
||||
'image/x-portable-pixmap' => 'image.gif',
|
||||
'image/x-rgb' => 'image.gif',
|
||||
'image/x-xbitmap' => 'image.gif',
|
||||
'image/x-xwindowdump' => 'image.gif',
|
||||
'image/png' => 'image.gif',
|
||||
'image/bmp' => 'image.gif',
|
||||
'video/ogg' => 'video.gif',
|
||||
'video/mp4' => 'video.gif',
|
||||
'video/webm' => 'video.gif',
|
||||
'video/mpeg' => 'video.gif',
|
||||
'video/quicktime' => 'video.gif',
|
||||
'video/x-ms-asf' => 'video.gif',
|
||||
'application/x-troff-msvideo' => 'video.gif',
|
||||
'video/x-sgi-movie' => 'video.gif',
|
||||
'video/x-ms-wmv' => 'wvideo.gif',
|
||||
'video/x-ms-wma' => 'wvideo.gif',
|
||||
'audio/x-ms-wma' => 'wvideo.gif',
|
||||
) unless keys %MIME_TYPE;
|
||||
|
||||
%MIME_TYPE;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::MIMETypes - Methods to guess MIME Types of files.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::MIMETypes;
|
||||
|
||||
my $file = '/foo/bar/abc.doc';
|
||||
my $mime = GT::MIMETypes::guess_type($file);
|
||||
my $img = GT::MIMETypes::guess_image($file);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::MIMETypes provides two simple methods C<guess_type> and C<guess_image>.
|
||||
They take either a filename or a hash reference.
|
||||
|
||||
C<guess_type> returns the MIME type of the file, and guess_image returns an
|
||||
image name that represents the file.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: MIMETypes.pm,v 1.30 2012/01/26 00:36:19 brewt Exp $
|
||||
|
||||
=cut
|
||||
|
||||
988
site/slowtwitch.com/cgi-bin/articles/GT/Mail.pm
Normal file
988
site/slowtwitch.com/cgi-bin/articles/GT/Mail.pm
Normal file
@ -0,0 +1,988 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Mail.pm,v 1.77 2007/08/01 23:35:15 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface to sending, creating, and
|
||||
# parsing emails.
|
||||
#
|
||||
|
||||
package GT::Mail;
|
||||
# ==================================================================
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw/$DEBUG @ISA $ERRORS $CRLF @HEADER $VERSION %CONTENT $CONTENT/;
|
||||
|
||||
# Internal modules
|
||||
use GT::Base;
|
||||
use GT::MIMETypes;
|
||||
use GT::Mail::Encoder;
|
||||
use GT::Mail::Parts;
|
||||
use GT::Mail::Send;
|
||||
|
||||
# Damn warnings
|
||||
$GT::Mail::error = '' if 0;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.77 $ =~ /(\d+)\.(\d+)/;
|
||||
@ISA = qw(GT::Base);
|
||||
$DEBUG = 0;
|
||||
$CRLF = "\012";
|
||||
$| = 1;
|
||||
|
||||
$ERRORS = {
|
||||
PARSE => "Unable to parse message: %s",
|
||||
SEND => "Unable to send email: %s",
|
||||
NOIO => "No input to parse!",
|
||||
NOBOUND => "Multipart message has not boundary",
|
||||
NOEMAIL => "No message head was specified",
|
||||
NOBODY => "No body was found in message",
|
||||
};
|
||||
|
||||
# To guess the content-type for files by extension
|
||||
%CONTENT = GT::MIMETypes->content_ext;
|
||||
$CONTENT = \%CONTENT; # Other programs still access this as a hash reference.
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# CLASS->new(
|
||||
# debug => 1,
|
||||
# to => 'user1@domain',
|
||||
# from => 'user2@domain',
|
||||
# subject => 'Hi Alex',
|
||||
# type => 'multipart/mixed',
|
||||
# ...
|
||||
# );
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returm a new mail object. If you pass in the header information the new
|
||||
# mail's header will be initialized with those fields.
|
||||
my $this = shift;
|
||||
my $self;
|
||||
|
||||
# Calling this as an object method does not create a new object.
|
||||
if (ref $this) { $self = $this }
|
||||
else { $self = bless {}, $this }
|
||||
|
||||
$self->args(@_) if @_;
|
||||
exists($self->{_debug}) or $self->{_debug} = $DEBUG;
|
||||
|
||||
$self->debug("Created new object ($self).") if ($self->{_debug} > 1);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub args {
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
elsif (ref $_[0] eq 'HASH') { $opt = shift }
|
||||
|
||||
$self->{_debug} = exists($opt->{debug}) ? delete $opt->{debug} : $DEBUG;
|
||||
$self->{smtp} = delete $opt->{smtp} || '';
|
||||
$self->{smtp_port} = delete $opt->{smtp_port} || '';
|
||||
$self->{smtp_ssl} = delete $opt->{smtp_ssl} || '';
|
||||
$self->{smtp_user} = delete $opt->{smtp_user} || '';
|
||||
$self->{smtp_pass} = delete $opt->{smtp_pass} || '';
|
||||
$self->{smtp_helo} = delete $opt->{smtp_helo} || '';
|
||||
$self->{pbs_user} = delete $opt->{pbs_user} || '';
|
||||
$self->{pbs_pass} = delete $opt->{pbs_pass} || '';
|
||||
$self->{pbs_host} = delete $opt->{pbs_host} || '';
|
||||
$self->{pbs_port} = delete $opt->{pbs_port} || '';
|
||||
$self->{pbs_auth_mode} = delete $opt->{pbs_auth_mode} || 'PASS';
|
||||
$self->{pbs_ssl} = delete $opt->{pbs_ssl} || '';
|
||||
$self->{flags} = delete $opt->{flags} || '';
|
||||
$self->{sendmail} = delete $opt->{sendmail} || '';
|
||||
$self->{header_charset} = delete $opt->{header_charset} || 'ISO-8859-1';
|
||||
|
||||
if (keys %{$opt} and !$self->{head}) {
|
||||
$self->{head} = $self->new_part($opt);
|
||||
}
|
||||
elsif (keys %{$opt} and $self->{head}) {
|
||||
$self->header($self->{head}, $opt);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->parse(\*FH [, eol-sequence]);
|
||||
# -----------------------------------
|
||||
# $obj->parse('/path/to/file' [, eol-sequence]);
|
||||
# ----------------------------------------------
|
||||
# $obj->parse($SCALAR_REF -or- $SCALAR [, eol-sequence]);
|
||||
# -------------------------------------------------------
|
||||
# Takes a path to a file, file handle, scalar or scalar reference containing
|
||||
# the e-mail, and optionally a second argument specifying the EOL sequence to
|
||||
# use when parsing (defaults to "\n" - corresponds directly to the
|
||||
# GT::Mail::Parse crlf method).
|
||||
# Returns head part on success and undef on failure. If a filehandle is
|
||||
# specified this will attempt to seek back to 0, 0 on exit.
|
||||
#
|
||||
my ($self, $io, $eol) = @_;
|
||||
|
||||
# Require our parser
|
||||
require GT::Mail::Parse;
|
||||
|
||||
# Get a new parser object
|
||||
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
||||
$self->{parser}->crlf($eol) if $eol;
|
||||
$self->_set_io($io) or return;
|
||||
$self->debug("\n\t--------------> Parsing email.") if $self->{_debug};
|
||||
$self->{head} = $self->{parser}->parse or return $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
|
||||
$self->debug("\n\t<-------------- Email parsed.") if $self->{_debug};
|
||||
return $self->{head};
|
||||
}
|
||||
|
||||
sub parse_head {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->parse_head (\*FH [, eol-sequence]);
|
||||
# -----------------------------------------
|
||||
# $obj->parse_head ('/path/to/file' [, eol-sequence]);
|
||||
# ----------------------------------------------------
|
||||
# This method does the exact same thing as the parse method except it will only
|
||||
# parse the header of the file or filehandle. This is a nice way to save
|
||||
# overhead when all you need is the header parsed and do not care about the
|
||||
# rest of the email.
|
||||
# NOTE: The top level part is returned from this and not stored.
|
||||
#
|
||||
my ($self, $io, $eol) = @_;
|
||||
|
||||
# Require our parser
|
||||
require GT::Mail::Parse;
|
||||
|
||||
# Get a new parser object
|
||||
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
||||
$self->{parser}->crlf($eol) if $eol;
|
||||
$self->_set_io($io) or return;
|
||||
$self->debug("\n\t--------------> Parsing head") if $self->{_debug};
|
||||
my $part = $self->{parser}->parse_head or $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
|
||||
$self->debug("\n\t<-------------- Head parsed") if $self->{_debug};
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub parser {
|
||||
# -----------------------------------------------------------------------------
|
||||
# my $parser = $mail->parser;
|
||||
# ---------------------------
|
||||
# $mail->parser($parser);
|
||||
# -----------------------
|
||||
# Set or get method for the parser object that is used when you call
|
||||
# parse_head() or parse(). This object must conform to the method parse and
|
||||
# parse_head. If no object is passed to this method a GT::Mail::Parse object is
|
||||
# created when needed.
|
||||
#
|
||||
my ($self, $parser) = @_;
|
||||
if (defined $parser) {
|
||||
$self->{parser} = $parser;
|
||||
$self->{head} = $parser->top_part;
|
||||
}
|
||||
return $self->{parser};
|
||||
}
|
||||
|
||||
sub send {
|
||||
# -----------------------------------------------------------------------------
|
||||
# CLASS->send(smtp => 'host.com', smtp_ssl => 1, smtp_port => 4650, To => '...', ...);
|
||||
# ------------------------------------------------------------------------------------
|
||||
# $obj->send(smtp => 'host.com', smtp_ssl => 1, smtp_port => 4560);
|
||||
# -----------------------------------------------------------------
|
||||
# $obj->send(sendmail => '/path/to/sendmail', flags => $additional_flags);
|
||||
# ------------------------------------------------------------------------
|
||||
# Sends the current email through either smtp or sendmail. The sendmail send
|
||||
# takes additional arguments as flags that get passed to sendmail (e.g.
|
||||
# "-t -oi -oem"). If these flags are specified they override the default which
|
||||
# is "-t -oi -oem". The smtp send also looks for smtp_port and smtp_ssl, but
|
||||
# these are optional and default to port 110, non-encrypted. Note that using
|
||||
# an SSL encrypted connection requires Net::SSLeay. Also not that attempting
|
||||
# to establish an SSL connection when Net::SSLeay (at least version 1.06) is
|
||||
# not available will cause a fatal error to occur.
|
||||
#
|
||||
my $self = shift;
|
||||
unless (ref $self) {
|
||||
$self = $self->new(@_);
|
||||
}
|
||||
elsif (@_) {
|
||||
$self->args(@_);
|
||||
}
|
||||
$self->{head} or return $self->error("NOEMAIL", "FATAL");
|
||||
|
||||
# Set a Message-Id if we don't have one set already
|
||||
my $host = $self->{smtp} && $self->{smtp} ne 'localhost' && $self->{smtp} !~ /^\s*127\.\d+\.\d+\.\d+\s*$/ ? $self->{smtp} : $ENV{SERVER_NAME} && $ENV{SERVER_NAME} ne 'localhost' ? $ENV{SERVER_NAME} : '';
|
||||
if (not defined $self->{head}->get('Message-Id') and $host) {
|
||||
$self->{head}->set('Message-Id' => '<' . time . '.' . $$ . rand(10000) . '@' . $host . '>');
|
||||
}
|
||||
|
||||
if ($self->{sendmail} and -e $self->{sendmail} and -x _) {
|
||||
$self->debug("\n\t--------------> Sending email through Sendmail path: ($self->{sendmail})") if $self->{_debug};
|
||||
my @flags = exists($self->{flags}) ? (flags => $self->{flags}) : ();
|
||||
my $return = ($self->parse_address($self->{head}->get('Reply-To') || $self->{head}->get('From')))[1];
|
||||
$self->{head}->set('Return-Path' => "<$return>") unless $self->{head}->get('Return-Path');
|
||||
GT::Mail::Send->sendmail(
|
||||
debug => $self->{_debug},
|
||||
path => $self->{sendmail},
|
||||
mail => $self,
|
||||
@flags
|
||||
) or return $self->error("SEND", "WARN", $GT::Mail::Send::error);
|
||||
$self->debug("\n\t<-------------- Email sent through Sendmail") if $self->{_debug};
|
||||
}
|
||||
elsif ($self->{smtp} and $self->{smtp} =~ /\S/) {
|
||||
# SMTP requires \r\n
|
||||
local $CRLF = "\015\012";
|
||||
local $GT::Mail::Parts::CRLF = "\015\012";
|
||||
local $GT::Mail::Encoder::CRLF = "\015\012";
|
||||
$self->{head}->set(date => $self->date_stamp) unless ($self->{head}->get('date'));
|
||||
$self->debug("\n\t--------------> Sending email through SMTP host: ($self->{smtp}:$self->{smtp_port})") if $self->{_debug};
|
||||
GT::Mail::Send->smtp(
|
||||
debug => $self->{_debug},
|
||||
host => $self->{smtp},
|
||||
port => $self->{smtp_port}, # Optional; GT::Mail::Send will set a default if not present
|
||||
ssl => $self->{smtp_ssl}, # Make sure Net::SSLeay is available if you use this
|
||||
user => $self->{smtp_user}, # Optional; Used for SMTP AUTH (CRAM-MD5, PLAIN, LOGIN)
|
||||
pass => $self->{smtp_pass},
|
||||
helo => $self->{smtp_helo},
|
||||
pbs_host => $self->{pbs_host}, # Optional; Perform a POP3 login before sending mail
|
||||
pbs_port => $self->{pbs_port},
|
||||
pbs_user => $self->{pbs_user},
|
||||
pbs_pass => $self->{pbs_pass},
|
||||
pbs_auth_mode => $self->{pbs_auth_mode},
|
||||
pbs_ssl => $self->{pbs_ssl},
|
||||
mail => $self
|
||||
) or return $self->error("SEND", "WARN", $GT::Mail::Send::error);
|
||||
$self->debug("\n\t<-------------- Email sent through SMTP") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
return $self->error("BADARGS", "FATAL", '$obj->send (%opts); smtp or sendmail and a head part must exist at this point.');
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub top_part {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->top_part ($part);
|
||||
# -----------------------
|
||||
# This allows you to set the top level part directly.
|
||||
# This is used to produce the email when sending or writing to file.
|
||||
#
|
||||
# my $top = $obj->top_part;
|
||||
# -------------------------
|
||||
# Returns the current top level part.
|
||||
#
|
||||
|
||||
my ($self, $part) = @_;
|
||||
if ($part and ref $part) {
|
||||
$self->{head} = $part;
|
||||
}
|
||||
return $self->{head};
|
||||
}
|
||||
|
||||
sub new_part {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->new_part;
|
||||
# ---------------
|
||||
# $obj->new_part(
|
||||
# to => 'user1@domain',
|
||||
# from => 'user2@domain',
|
||||
# subject => 'Hi Alex',
|
||||
# type => 'multipart/mixed',
|
||||
# ...
|
||||
# );
|
||||
# ---------------------------------
|
||||
# Returns a new part. If arguments a given they are passed to the header method
|
||||
# in the parts module. See the parts module for details.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $part = new GT::Mail::Parts (debug => $self->{_debug}, header_charset => $self->{header_charset});
|
||||
$self->header($part, @_) if @_;
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub header {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->header(%header);
|
||||
# ----------------------
|
||||
# Mostly private method to set the arguments for the emails header.
|
||||
# This is called by new and new_part.
|
||||
# The options are:
|
||||
#
|
||||
# disposition => Sets the Content-Disposition.
|
||||
# filename => Sets the Content-Disposition to attachment and the
|
||||
# file name to what to specify.
|
||||
# encoding => Sets the Content-Transfer-Encoding (You really
|
||||
# should not set this).
|
||||
# header_charset => The header encoding charset.
|
||||
# type => Sets the Content-Type.
|
||||
# body_data => Sets the top level body data to the in memory string
|
||||
# specified.
|
||||
# msg => Same as body_data.
|
||||
# body_handle => Sets the top level body to the File Handle.
|
||||
# body_path => Sets the top level body path.
|
||||
#
|
||||
|
||||
my $self = shift;
|
||||
my $part = shift;
|
||||
|
||||
my $opt;
|
||||
if (!@_) { return $self->error("BADARGS", "FATAL", '$obj->header(to => \'someone@somedomain\', from => \'someone@somedomain\');') }
|
||||
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
elsif (ref $_[0] and ref $_[0] eq 'HASH') { $opt = shift }
|
||||
else { return $self->error("BADARGS", "FATAL", '$obj->header(to => \'someone@somedomain\', from => \'someone@somedomain\');') }
|
||||
|
||||
for my $tag (keys %{$opt}) {
|
||||
next unless defined $opt->{$tag};
|
||||
my $key = $tag;
|
||||
if ($tag eq 'disposition') { $tag = 'Content-Disposition' }
|
||||
elsif ($tag eq 'filename') { $tag = 'Content-Disposition'; $opt->{$key} = 'attachment; filename="' . $opt->{$key} . '"' }
|
||||
elsif ($tag eq 'encoding') { $tag = 'Content-Transfer-Encoding' }
|
||||
elsif ($tag eq 'type') { $part->mime_type($opt->{$tag}); next }
|
||||
elsif ($tag eq 'body_data') { $part->body_data($opt->{$tag}); next }
|
||||
elsif ($tag eq 'header_charset') { $part->header_charset($opt->{$tag}); next }
|
||||
|
||||
# For Alex :)
|
||||
elsif ($tag eq 'msg') { $part->body_data($opt->{$tag}); next }
|
||||
elsif ($tag eq 'body_handle') { $part->body_handle($opt->{$tag}); next }
|
||||
elsif ($tag eq 'body_path') { $part->body_path($opt->{$tag}); next }
|
||||
$self->debug("Setting ($tag) to ($opt->{$key})") if ($self->{_debug} > 1);
|
||||
$part->set($tag => $opt->{$key});
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub attach {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->attach($mail_object);
|
||||
# ---------------------------
|
||||
# Attaches an rfc/822 to the current email. $mail_object is a GT::Mail object.
|
||||
#
|
||||
# $obj->attach(
|
||||
# disposition => 'inline',
|
||||
# type => 'text/plain',
|
||||
# body_data => 'Hello how are ya'
|
||||
# );
|
||||
# --------------------------------------
|
||||
# Attaches the given data to the email. See header for a list of the options.
|
||||
#
|
||||
my $self = shift;
|
||||
if (!$self->{head}) { return $self->error("NOEMAIL", "FATAL") }
|
||||
|
||||
my $attach;
|
||||
if (ref $_[0] eq ref $self) {
|
||||
$self->debug("Adding rfc/822 email attachment.") if $self->{_debug};
|
||||
push @{$self->{mail_attach}}, @_;
|
||||
return 1;
|
||||
}
|
||||
elsif (ref $_[0] eq 'GT::Mail::Parts') {
|
||||
$attach = $_[0];
|
||||
}
|
||||
else {
|
||||
$attach = $self->new_part(@_);
|
||||
}
|
||||
$self->debug("Adding attachment.") if $self->{_debug};
|
||||
|
||||
# Guess the content-type if none was specified
|
||||
if (!$attach->mime_type and $attach->body_path) {
|
||||
(my $ext = $attach->body_path) =~ s/^.*\.//;
|
||||
$attach->mime_type(exists($CONTENT{$ext}) ? $CONTENT{$ext} : 'application/octet-stream');
|
||||
}
|
||||
$self->{head}->parts($attach);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub to_string { shift->as_string }
|
||||
|
||||
sub as_string {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->as_string;
|
||||
# ----------------
|
||||
# Returns the entire email as a sting. The parts will be encoded for sending at
|
||||
# this point.
|
||||
# NOTE: Not a recommended method for emails with binary attachments.
|
||||
my $self = shift;
|
||||
my $ret = '';
|
||||
$self->build_email(sub { $ret .= $_[0] });
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub build_email {
|
||||
my ($self, $code) = @_;
|
||||
$GT::Mail::Encoder::CRLF = $CRLF;
|
||||
# Need a code ref to continue.
|
||||
ref($code) eq 'CODE' or return $self->error("BADARGS", "FATAL", '$obj->build_email(sub {do something });');
|
||||
|
||||
$self->debug("\n\t--------------> Creating email") if $self->{_debug};
|
||||
# Need the head to continue
|
||||
$self->{head} or return $self->error("NOEMAIL", "FATAL");
|
||||
unless ($self->{head}->get('MIME-Version')) { $self->{head}->set('MIME-Version', '1.0') }
|
||||
|
||||
my $io = $self->_get_body_handle($self->{head});
|
||||
my $bound = $self->{head}->multipart_boundary;
|
||||
|
||||
# If the message has parts
|
||||
|
||||
if (@{$self->{head}->{parts}} > 0) {
|
||||
$self->debug("Creating multipart email.") if $self->{_debug};
|
||||
$self->_build_multipart_head($code, $io);
|
||||
}
|
||||
|
||||
# Else we are single part and have either a body IO handle or the body is in memory
|
||||
elsif (defined $io) {
|
||||
$self->debug("Creating singlepart email.") if $self->{_debug};
|
||||
$self->_build_singlepart_head($code, $io);
|
||||
}
|
||||
else {
|
||||
$self->error("NOBODY", "WARN");
|
||||
$code->($self->{head}->header_as_string . $CRLF . $CRLF);
|
||||
}
|
||||
|
||||
# If we have parts go through all of them and add them.
|
||||
if (@{$self->{head}->{parts}} > 0) {
|
||||
my $num_parts = $#{$self->{head}->{parts}};
|
||||
for my $num (0 .. $num_parts) {
|
||||
next unless $self->{head}->{parts}->[$num];
|
||||
$self->debug("Creating part ($num).") if $self->{_debug};
|
||||
$self->_build_parts($code, $self->{head}->{parts}->[$num]);
|
||||
if ($num_parts == $num) {
|
||||
$self->debug("Boundary\n\t--$bound--") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . '--' . $CRLF);
|
||||
}
|
||||
else {
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . $CRLF);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Add the epilogue if we are multipart
|
||||
if (@{$self->{head}->{parts}} > 0) {
|
||||
my $epilogue = join('', @{ $self->{head}->epilogue || [] }) || '';
|
||||
$epilogue =~ s/\015?\012//g;
|
||||
$self->debug("Setting epilogue to ($epilogue)") if $self->{_debug};
|
||||
$code->($epilogue . $CRLF . $CRLF) if $epilogue;
|
||||
}
|
||||
$self->debug("\n\t<-------------- Email created.") if $self->{_debug};
|
||||
return $self->{head};
|
||||
}
|
||||
|
||||
sub write {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->write ('/path/to/file');
|
||||
# ------------------------------
|
||||
# $obj->write (*FH);
|
||||
# ------------------
|
||||
# Writes the email to the specified file or file handle. The email will be
|
||||
# encoded properly. This is nice for writing to an mbox file. If a file path
|
||||
# is specified this will attempt to open it >. Returns 1 on success and undef
|
||||
# on failure.
|
||||
#
|
||||
my ($self, $file) = @_;
|
||||
my $io;
|
||||
if (ref $file and ref $file eq 'GLOB' and defined fileno($file)) {
|
||||
$self->debug("Filehandle passed to write: fileno (" . fileno($file) . ").") if $self->{_debug};
|
||||
$io = $file;
|
||||
}
|
||||
elsif (open FH, ">$file") {
|
||||
$io = \*FH;
|
||||
$self->debug("Opening ($file) for reading.") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
return $self->error("BADARGS", "FATAL", '$obj->write ("/path/to/file"); -or- $obj->write (\*FH);');
|
||||
}
|
||||
$self->build_email(sub { print $io @_ }) or return;
|
||||
select((select($io), $| = 1)[0]);
|
||||
$self->debug("Email written to fileno (" . fileno($io) . ")") if $self->{_debug};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _set_io {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private function to decide what to do with the arguments passed into parse
|
||||
# and parse_head.
|
||||
#
|
||||
my ($self, $io) = @_;
|
||||
|
||||
CASE: {
|
||||
ref($io) eq 'SCALAR' and do { $self->{parser}->in_string($io); last CASE };
|
||||
ref($io) and ref($io) =~ /^GLOB|FileHandle$/ and do { $self->{parser}->in_handle($io); last CASE };
|
||||
-f $io and do { $self->{parser}->in_file($io); last CASE };
|
||||
ref $io or do { $self->{parser}->in_string($io); last CASE };
|
||||
return $self->error("NOIO", "FATAL");
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _encoding {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to guess the encoding type.
|
||||
#
|
||||
my ($self, $part) = @_;
|
||||
my $encoding;
|
||||
$encoding = $part->mime_attr('content-transfer-encoding');
|
||||
if ($encoding and lc($encoding) ne '-guess') {
|
||||
return $encoding;
|
||||
}
|
||||
else {
|
||||
return $part->suggest_encoding;
|
||||
}
|
||||
}
|
||||
|
||||
sub date_stamp {
|
||||
# --------------------------------------------------------------------------
|
||||
# Set an RFC date, e.g.: Mon, 08 Apr 2002 13:56:22 -0700
|
||||
#
|
||||
my $self = shift;
|
||||
require GT::Date;
|
||||
local @GT::Date::MONTHS_SH = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
|
||||
local @GT::Date::DAYS_SH = qw/Sun Mon Tue Wed Thu Fri Sat/;
|
||||
return GT::Date::date_get(time, '%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% %o%');
|
||||
}
|
||||
|
||||
sub parse_address {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Parses out the name and e-mail address of a given "address". For example,
|
||||
# from: "Jason Rhinelander" <jason@gossamer-threads.com>, this will return
|
||||
# ('Jason Rhinelander', 'jason@gossamer-threads.com'). It handes escapes as
|
||||
# well - "Jason \(\"jagerman\"\) Rhinelander" <jason@gossamer-threads.com>
|
||||
# returns 'Jason ("jagerman") Rhinelander' for the name.
|
||||
#
|
||||
my ($self, $email_from) = @_;
|
||||
|
||||
my ($name, $email) = ('', '');
|
||||
if ($email_from =~ /"?((?:[^<"\\]|\\.)+?)"?\s*<([^>]*)>/) {
|
||||
($name, $email) = ($1, $2);
|
||||
$name =~ s/\\(.)/$1/g;
|
||||
$name =~ s/^\s*$//;
|
||||
}
|
||||
elsif ($email_from =~ /<([^>]*)>/) {
|
||||
$email = $1;
|
||||
}
|
||||
else {
|
||||
$email = $email_from || '';
|
||||
$email =~ s/\([^)]+\)//g;
|
||||
}
|
||||
return ($name, $email);
|
||||
}
|
||||
|
||||
sub _get_body_handle {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to get a body handle on a given part.
|
||||
#
|
||||
my ($self, $part) = @_;
|
||||
my $in = $part->body_in || 'NONE';
|
||||
my $io;
|
||||
if ($in eq 'MEMORY') {
|
||||
$self->debug("Body is in MEMORY.") if $self->{_debug};
|
||||
return $part->body_data;
|
||||
}
|
||||
elsif ($in eq 'FILE') {
|
||||
$self->debug("Body is in FILE: " . $part->body_path) if $self->{_debug};
|
||||
$io = $part->open('r');
|
||||
}
|
||||
elsif ($in eq 'HANDLE') {
|
||||
$self->debug("Body is in HANDLE.") if $self->{_debug};
|
||||
$io = $part->body_handle;
|
||||
binmode($io);
|
||||
}
|
||||
return $io;
|
||||
}
|
||||
|
||||
sub _build_multipart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a multipart header.
|
||||
#
|
||||
my ($self, $code, $io) = @_;
|
||||
my $bound = $self->{head}->multipart_boundary;
|
||||
my $encoding = $self->_encoding($self->{head});
|
||||
$self->debug("Setting encoding to ($encoding).") if $self->{_debug};
|
||||
$self->{head}->set(
|
||||
'Content-Transfer-Encoding' => $encoding
|
||||
);
|
||||
if (defined $io) {
|
||||
my $mime = 'text/plain';
|
||||
my ($type, $subtype) = split '/' => $self->{head}->mime_type;
|
||||
if ($type and lc($type) ne 'multipart') {
|
||||
$subtype ||= 'mixed';
|
||||
$mime = "$type/$subtype";
|
||||
}
|
||||
my %new = (
|
||||
type => $mime,
|
||||
encoding => $encoding,
|
||||
disposition => "inline"
|
||||
);
|
||||
|
||||
# Body is in a handle
|
||||
if (ref $io) { $new{body_handle} = $io }
|
||||
|
||||
# Body is in memory
|
||||
else { $new{body_data} = $io }
|
||||
|
||||
my $new = $self->new_part(%new);
|
||||
$self->{head}->{body_in} = 'NONE';
|
||||
unshift @{$self->{head}->{parts}}, $new;
|
||||
}
|
||||
$bound ||= "---------=_" . time . "-$$-" . int(rand(time)/2);
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $self->{head}->get('Content-Type');
|
||||
if (!$c or $c !~ /\Q$bound/i) {
|
||||
if ($c and lc($c) !~ /boundary=/) {
|
||||
$c =~ /multipart/ or $c = 'multipart/mixed';
|
||||
$self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug};
|
||||
$self->{head}->set('Content-Type' => $c . qq|; boundary="$bound"|);
|
||||
}
|
||||
else {
|
||||
$self->debug("Setting multipart boundary to ($bound).") if $self->{_debug};
|
||||
$self->{head}->set('Content-Type' => qq!multipart/mixed; boundary="$bound"!);
|
||||
}
|
||||
}
|
||||
|
||||
my $preamble = join('', @{$self->{head}->preamble || []})
|
||||
|| "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug("Setting preamble to ($preamble).") if $self->{_debug};
|
||||
(my $head = $self->{head}->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($head . $CRLF . $preamble . $CRLF . $CRLF . '--' . $bound . $CRLF);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_singlepart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a single part header.
|
||||
#
|
||||
my ($self, $code, $io) = @_;
|
||||
my $encoding = $self->_encoding($self->{head});
|
||||
$self->debug("Setting encoding to ($encoding).") if $self->{_debug};
|
||||
$self->{head}->set('Content-Transfer-Encoding' => $encoding);
|
||||
(my $head = $self->{head}->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$code->($head . $CRLF);
|
||||
$self->debug("Encoding body with ($encoding).") if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode(
|
||||
debug => $self->{_debug},
|
||||
encoding => $encoding,
|
||||
in => $io,
|
||||
out => $code
|
||||
) or return $self->error("ENCODE", "WARN", $GT::Mail::Encoder::error);
|
||||
|
||||
# Must seek to the beginning for additional calls
|
||||
seek($io, 0, 0) if ref $io;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method that builds the parts for the email.
|
||||
#
|
||||
my ($self, $code, $part) = @_;
|
||||
|
||||
# Need a code ref to continue.
|
||||
ref($code) eq 'CODE' or return $self->error("BADARGS", "FATAL", '$obj->build_email(sub { do something });');
|
||||
|
||||
# Need the head to contiue
|
||||
$self->{head} or return $self->error("NOEMAIL", "FATAL");
|
||||
|
||||
my ($body, $io, $encoding, $bound);
|
||||
|
||||
# Get the io handle for the body
|
||||
$io = $self->_get_body_handle($part);
|
||||
$bound = $part->multipart_boundary;
|
||||
|
||||
# The body is in an io stream.
|
||||
if (defined $io) {
|
||||
|
||||
# Find the encoding for the part and set it.
|
||||
$encoding = $self->_encoding($part);
|
||||
$self->debug("Setting encoding to ($encoding).") if $self->{_debug};
|
||||
$part->set('Content-Transfer-Encoding' => $encoding);
|
||||
}
|
||||
|
||||
# If the message has parts and has a multipart boundary
|
||||
if ((@{$part->{parts}} > 0) and ($bound)) {
|
||||
$self->debug("Part is multpart.") if $self->{_debug};
|
||||
|
||||
# Set the multipart boundary
|
||||
$self->debug("Setting boundary to ($bound).") if $self->{_debug};
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
if (my $c = $part->get('Content-Type')) {
|
||||
unless ($c =~ /;\s*boundary="\Q$bound\E"/i) {
|
||||
$self->debug(qq|Setting content type to ($c; boundary="$bound")|) if $self->{_debug};
|
||||
$part->set('Content-Type' => qq{$c; boundary="$bound"});
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->debug("Setting multipart boundary to ($bound).") if $self->{_debug};
|
||||
$part->set('Content-Type' => qq{multipart/mixed; boundary="$bound"});
|
||||
}
|
||||
|
||||
my $preamble = join('', @{$part->preamble || []})
|
||||
|| "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug("Setting preamble to ($preamble).") if $self->{_debug};
|
||||
(my $head = $part->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($head . $CRLF . $preamble . $CRLF . '--' . $bound . $CRLF);
|
||||
}
|
||||
else {
|
||||
$self->debug("Part is single part.") if $self->{_debug};
|
||||
(my $head = $part->header_as_string) =~ s/\015?\012/$CRLF/g;
|
||||
$code->($head . $CRLF);
|
||||
}
|
||||
|
||||
# Set the body only if we have one. We would not have one on the head an multipart
|
||||
if ($io) {
|
||||
$self->debug("Encoding body with ($encoding).") if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode(
|
||||
encoding => $encoding,
|
||||
debug => $self->{_debug},
|
||||
in => $io,
|
||||
out => $code
|
||||
) or return $self->error("ENCODE", "WARN", $GT::Mail::Encoder);
|
||||
|
||||
# Must reseek IO for multiple calls.
|
||||
seek($io, 0, 0) if ref $io;
|
||||
}
|
||||
else {
|
||||
$self->debug("Part has no body!") if $self->{_debug};
|
||||
}
|
||||
|
||||
# Add the rest of the parts
|
||||
if (@{$part->{parts}} > 0) {
|
||||
$self->debug("Part has parts.") if $self->{_debug};
|
||||
my $num_parts = $#{$part->{parts}};
|
||||
for my $num (0 .. $num_parts) {
|
||||
next unless $part->{parts}->[$num];
|
||||
$self->debug("Creating part ($num).") if $self->{_debug};
|
||||
$self->_build_parts($code, $part->{parts}->[$num]) or return;
|
||||
if ($bound) {
|
||||
if ($num_parts == $num) {
|
||||
$self->debug("Boundary\n\t--$bound--") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . '--' . $CRLF);
|
||||
}
|
||||
else {
|
||||
$self->debug("Boundary\n\t--$bound") if $self->{_debug};
|
||||
$code->($CRLF . '--' . $bound . $CRLF);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
undef $io;
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail - A simple interface to parsing, sending, and creating email.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail;
|
||||
|
||||
# Create and Sending
|
||||
GT::Mail->send(
|
||||
smtp => 'gossamer-threads.com',
|
||||
smtp_port => 110, # optional; 110/465 (normal/SSL) will be used for the default
|
||||
smtp_ssl => 1, # establish an SSL connection. Requires Net::SSLeay 1.06 or newer.
|
||||
to => 'scott@gossamer-threads.com',
|
||||
from => 'scott@gossamer-threads.com',
|
||||
subject => 'Hello!!',
|
||||
msg => 'I am a text email'
|
||||
) or die "Error: $GT::Mail::error";
|
||||
|
||||
# Parsing and sending
|
||||
my $mail = GT::Mail->new(debug => 1);
|
||||
|
||||
# Parse an email that is in a file called mail.test
|
||||
my $parser = $mail->parse('mail.test') or die "Error: $GT::Mail::error";
|
||||
|
||||
# Change who it is to
|
||||
$parser->set("to", 'scott@gossamer-threads.com');
|
||||
|
||||
# Add an attachment to it
|
||||
$mail->attach (
|
||||
type => 'text/plain',
|
||||
encoding => '-guess',
|
||||
body_path => 'Mail.pm',
|
||||
filename => 'Mail.pm'
|
||||
);
|
||||
|
||||
# Send the email we just parsed and modified
|
||||
$mail->send(sendmail => '/usr/sbin/sendmail') or die "Error: $GT::Mail::error";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail is a simple interface for parsing, creating, and sending email. It
|
||||
uses GT::Mail::Send to send email and GT::Mail::Parse to parse and store email
|
||||
data structurs. All the creation work is done from within GT::Mail.
|
||||
|
||||
=head2 Creating a new GT::Mail object
|
||||
|
||||
The arguments to new() in GT::Mail are mostly the same for all the class
|
||||
methods in GT::Mail so I will be refering back to these further down. Mostly
|
||||
these arguments are used to set parts of the header for creating an email. The
|
||||
arguments can be passed in as either a hash or a hash ref. Any arguments aside
|
||||
from these will be added to the content header as raw header fields. The
|
||||
following is a list of the keys and a brief description.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debug level for this object. Anything but zero will produce ouput on
|
||||
STDERR.
|
||||
|
||||
=item disposition
|
||||
|
||||
Sets the Content-Disposition.
|
||||
|
||||
=item filename
|
||||
|
||||
Sets the Content-Disposition to attachment and the file name to what to
|
||||
specify.
|
||||
|
||||
=item encoding
|
||||
|
||||
Sets the Content-Transfer-Encoding (You really should not set this).
|
||||
|
||||
=item type
|
||||
|
||||
Sets the Content-Type.
|
||||
|
||||
=item body_data
|
||||
|
||||
Sets the top level body data to the in memory string specified.
|
||||
|
||||
=item msg
|
||||
|
||||
Same as body_data.
|
||||
|
||||
=item body_handle
|
||||
|
||||
Sets the top level body to the File Handle.
|
||||
|
||||
=item body_path
|
||||
|
||||
Sets the top level body path.
|
||||
|
||||
=back
|
||||
|
||||
=head2 parser - Set or get the parse object.
|
||||
|
||||
my $parser = $mail->parser;
|
||||
$mail->parser($parser);
|
||||
|
||||
Set or get method for the parser object that is used when you call parse_head()
|
||||
or parse(). This object must conform to the method parse and parse_head. If no
|
||||
object is passed to this method a L<GT::Mail::Parse> object is created when
|
||||
needed.
|
||||
|
||||
=head2 parse - Parsing an email.
|
||||
|
||||
Instance method that returns a parts object. Emails are stored recursivly in
|
||||
parts object. That is emails can have parts within parts within parts etc.. See
|
||||
L<GT::Mail::Parts> for details on the methods supported by the parts object
|
||||
that is returned.
|
||||
|
||||
The parse() method takes only one argument. It can be a GLOB ref to a file
|
||||
handle, a FileHandle object, or the path to a file. In any case the IO must
|
||||
contain a valid formated email.
|
||||
|
||||
Once an email is parsed, you can make changes to it as you need and call the
|
||||
send method to send it or call the write method to write it to file, etc.
|
||||
|
||||
This method will return false if an error occurs when parsing. The error
|
||||
message will be set in $GT::Mail::error.
|
||||
|
||||
=head2 parse_head - Parsing just the head.
|
||||
|
||||
This method does the exact same thing as the parse method but it will only
|
||||
parse the top level header of the email. Any IO's will be reset after the
|
||||
parsing.
|
||||
|
||||
Use this method if whether you want to parse and decode the body of the email
|
||||
depends on what is in the header of the email or if you only need access to the
|
||||
header. None of the parts will contain a body.
|
||||
|
||||
=head2 send - Sending an email.
|
||||
|
||||
Class/Instance method for sending email. It sends the currently in memory
|
||||
email. This means, if you parse an email, that email is in memory, if you
|
||||
specify params for an email to new(), that is the email that gets sent. You can
|
||||
also specify the params for the email to this method.
|
||||
|
||||
=head2 top_part - Getting a Parts object.
|
||||
|
||||
Instance method to set or get the top level part. If you are setting this, the
|
||||
object must be from L<GT::Mail::Parts>. You can use this to retrieve the part
|
||||
object after you specify params to create an email. This object will contain
|
||||
all the other parts for the email. e.g. attachments and emails that are
|
||||
attached. See L<GT::Mail::Parts> for more details on this object.
|
||||
|
||||
=head2 new_part - Creating a Parts object.
|
||||
|
||||
Instance method to get a new part object. This method takes the same arguments
|
||||
as the new() constructor. Returns the new part object. The part object is
|
||||
added to the current email only if arguments are given otherwize just returns
|
||||
an empty part.
|
||||
|
||||
=head2 attach - Attaching to an email.
|
||||
|
||||
Instance method to attach to the in memory email. You can pass in a GT::Mail
|
||||
object or you can pass the same arguments you would pass to new() to specify
|
||||
all the information about the attachment. In addition if you specify a file
|
||||
path and do not specify a mime type, this will attempt to guess the mime type
|
||||
from the file extention.
|
||||
|
||||
=head2 to_string - Getting the email as a string.
|
||||
|
||||
Returns the entire email as a string. Do not use this function if you have
|
||||
attachments and are worried about memory ussage.
|
||||
|
||||
=head2 as_string - Getting the email as a string.
|
||||
|
||||
Same as to_string.
|
||||
|
||||
=head2 build_email - Building an email.
|
||||
|
||||
Instance method that builds the currently in memory email. This method takes
|
||||
one argument, a code ref. It calles the code ref with one argument. The code
|
||||
ref is called for each section of the email that is created. A good example of
|
||||
how to use this is what the as_string method does:
|
||||
|
||||
my $ret = '';
|
||||
$obj->build_email(sub { $ret .= $_[0] });
|
||||
|
||||
This puts the entire created email into the string $ret. You can use this, for
|
||||
example to print the email to a filehandle (which is what the write() method
|
||||
does).
|
||||
|
||||
=head2 write - Writing an email to a file handle.
|
||||
|
||||
Instance mothod that writes the currently in memory email to a file or file
|
||||
handle. The only arguments this method takes is a file or a reference to a glob
|
||||
that is a filehandle or FileHandle object.
|
||||
|
||||
=head2 naming - Setting the naming scheme.
|
||||
|
||||
Instance method to specify a naming scheme for parsing emails. Calling this
|
||||
after the email is parsed has no effect. This method just wraps to the one in
|
||||
L<GT::Mail::Parse>.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Mail.pm,v 1.77 2007/08/01 23:35:15 brewt Exp $
|
||||
|
||||
=cut
|
||||
1275
site/slowtwitch.com/cgi-bin/articles/GT/Mail/BulkMail.pm
Normal file
1275
site/slowtwitch.com/cgi-bin/articles/GT/Mail/BulkMail.pm
Normal file
File diff suppressed because it is too large
Load Diff
524
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor.pm
Normal file
524
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor.pm
Normal file
@ -0,0 +1,524 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Editor
|
||||
#
|
||||
# Author: Jason Rhinelander
|
||||
# Revision: $Id: Editor.pm,v 1.25 2008/09/23 23:55:26 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# The backend to a web-based e-mail template editor. See the pod for
|
||||
# instructions. This is designed the be used primarily from templates.
|
||||
# This module respects local directories on saving, and both local and
|
||||
# inheritance directories when loading.
|
||||
#
|
||||
# Also, any subclasses must be (something)::Editor
|
||||
#
|
||||
|
||||
package GT::Mail::Editor;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG $ERRORS @ISA $ATTRIBS);
|
||||
|
||||
use GT::Base;
|
||||
use GT::Template;
|
||||
|
||||
@ISA = 'GT::Base';
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
$ERRORS = {
|
||||
PARSE => "An error occurred while parsing: %s",
|
||||
NODIR => "Template directory not specified",
|
||||
BADDIR => "Template directory '%s' does not exist or has the permissions set incorrectly",
|
||||
NOFILE => "No template filename specified",
|
||||
CANT_CREATE_DIR => "Unable to create directory '%s': %s",
|
||||
BADFILE => "Template '%s' does not exist or is not readable",
|
||||
SAVEERROR => "Unable to open '%s' for writing: %s",
|
||||
LOADERROR => "Unable to open '%s' for reading: %s",
|
||||
RECURSION => "Recursive inheritance detected and interrupted: '%s'",
|
||||
INVALIDDIR => "Invalid template directory %s",
|
||||
INVALIDTPL => "Invalid template %s",
|
||||
};
|
||||
|
||||
$ATTRIBS = {
|
||||
dir => '',
|
||||
template => '',
|
||||
file => '',
|
||||
headers => undef,
|
||||
extra_headers => '',
|
||||
body => ''
|
||||
};
|
||||
|
||||
# GT::Mail::Editor::tpl_save(header => To => $header_to, header => From => $header_from, ..., extra_headers => $extra_headers)
|
||||
# ($extra_headers will be parsed). Everything is optional, but you should give something to build headers from.
|
||||
# It is not necessary to use To, From, etc. - you can enter them directly in the "extra_headers" field.
|
||||
sub tpl_save {
|
||||
# Have to extract the three-argument arguments BEFORE getting $self
|
||||
my @headers;
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if ($_[$i] eq 'header') {
|
||||
push @headers, (splice @_, $i, 3)[1,2];
|
||||
redo;
|
||||
}
|
||||
}
|
||||
my $self = &_get_self;
|
||||
for (my $i = 0; $i < @headers; $i += 2) {
|
||||
$self->{headers}->{$headers[$i]} = $headers[$i+1];
|
||||
}
|
||||
if ($self->{extra_headers}) {
|
||||
for (split /\s*\n\s*/, $self->{extra_headers}) { # This will weed out any blank lines
|
||||
my ($key, $value) = split /\s*:\s*/, $_, 2;
|
||||
$self->{headers}->{$key} = $value if $key and $value;
|
||||
}
|
||||
}
|
||||
my $dir;
|
||||
if ($self->{dir} and $self->{template}) {
|
||||
$dir = "$self->{dir}/$self->{template}/local";
|
||||
if (!-d $dir) {
|
||||
# Attempt to create the "local" subdirectory
|
||||
mkdir($dir, 0777) or return $self->error(CANT_CREATE_DIR => 'FATAL' => $dir => "$!");
|
||||
chmod(0777, $dir);
|
||||
}
|
||||
}
|
||||
elsif ($self->{dir}) {
|
||||
$dir = $self->{dir};
|
||||
}
|
||||
|
||||
local *FILE;
|
||||
$self->{_error} = [];
|
||||
if (not $dir) {
|
||||
$self->error(NODIR => 'WARN');
|
||||
}
|
||||
elsif (not -d $dir or not -w $dir) {
|
||||
$self->error(BADDIR => WARN => $dir);
|
||||
}
|
||||
elsif (not $self->{file}) {
|
||||
$self->error(NOFILE => 'WARN');
|
||||
}
|
||||
elsif (-f "$dir/$self->{file}" and not -w _) {
|
||||
$self->error(BADFILE => WARN => "$dir/$self->{file}");
|
||||
}
|
||||
elsif (not open FILE, "> $dir/$self->{file}") {
|
||||
$self->error(SAVEERROR => WARN => "$dir/$self->{file}", "$!");
|
||||
}
|
||||
else { # Everything is good, now we have FILE open to the file.
|
||||
$self->debug("Saving $dir/$self->{file}");
|
||||
my $headers;
|
||||
while (my ($key, $val) = each %{$self->{headers}}) {
|
||||
next unless $key and $val;
|
||||
$key =~ s/\r?\n//g; $val =~ s/\r?\n//g; # Just in case...
|
||||
$headers .= "$key: $val\n";
|
||||
}
|
||||
print FILE $headers;
|
||||
print FILE "" . "\n"; # Blank line
|
||||
$self->{body} =~ s/\r\n/\n/g;
|
||||
print FILE $self->{body};
|
||||
close FILE;
|
||||
}
|
||||
|
||||
if (@{$self->{_error}}) {
|
||||
return { error => join("<br>\n", @{$self->{_error}}) };
|
||||
}
|
||||
else {
|
||||
return { success => 1, error => '' };
|
||||
}
|
||||
}
|
||||
|
||||
# GT::Mail::Editor::tpl_load(header => To, header => From, header => Subject)
|
||||
# In this case, "To", "From" and "Subject" will come to you as header_To,
|
||||
# header_From, and header_Subject.
|
||||
# What you get back is a hash reference, with either "error" set to an error
|
||||
# if something bad happened, or "success" set to 1, and the following template
|
||||
# variables:
|
||||
#
|
||||
# header_To, header_From, header_Subject, header_...
|
||||
# => The value of the To, From, Subject, etc. field.
|
||||
# -> Only present for individual headers that are requested with "header"
|
||||
# extra_headers => A loop of all the other headers with { name => To, From, etc., value => value }
|
||||
# body => The body of the e-mail. This will eventually change as this module
|
||||
# -> becomes capable of creating e-mails with multiple parts.
|
||||
sub tpl_load {
|
||||
my $self = &_get_self;
|
||||
my %sep_headers;
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if (lc $_[$i] eq 'header') {
|
||||
$sep_headers{$_[++$i]} = 1;
|
||||
}
|
||||
}
|
||||
my $dir;
|
||||
if ($self->{dir} and $self->{template} and $self->{file}
|
||||
and $self->{template} !~ m[[\\/\x00-\x1f]] and $self->{template} ne '..'
|
||||
and $self->{file} !~ m[[\\/\x00-\x1f]]) {
|
||||
$dir = "$self->{dir}/$self->{template}";
|
||||
if (-f "$dir/local/$self->{file}") {
|
||||
$dir .= "/local";
|
||||
}
|
||||
elsif (!-f "$dir/$self->{file}") {
|
||||
my ($tplinfo, %tplinfo);
|
||||
while ($tplinfo = GT::Template->load_tplinfo($dir) and my $inherit = $tplinfo->{inheritance}) {
|
||||
if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
|
||||
$dir = $inherit;
|
||||
}
|
||||
else {
|
||||
$dir .= "/$inherit";
|
||||
}
|
||||
if (-f "$dir/local/$self->{file}") {
|
||||
$dir .= "/local";
|
||||
last;
|
||||
}
|
||||
elsif (-f "$dir/$self->{file}") {
|
||||
last;
|
||||
}
|
||||
if (length $dir > 150 or $tplinfo{$dir}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
|
||||
$self->error(RECURSION => WARN => $dir);
|
||||
last; # End the loop - there is no more inheritance since we would just be recursing over what we already have
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $fh = \do { local *FILE; *FILE };
|
||||
$self->{_error} = [];
|
||||
my $return = { success => 0, error => '' };
|
||||
if ($self->{template} =~ m[[\\/\x00-\x1f]] or $self->{template} eq '..') {
|
||||
$self->error(INVALIDDIR => WARN => $self->{template});
|
||||
}
|
||||
elsif ($self->{file} =~ m[[\\/\x00-\x1f]]) {
|
||||
$self->error(INVALIDTPL => WARN => $self->{file});
|
||||
}
|
||||
elsif (not $dir) {
|
||||
$self->error(NODIR => 'WARN');
|
||||
}
|
||||
elsif (not -d $dir) {
|
||||
$self->error(BADDIR => WARN => $dir);
|
||||
}
|
||||
elsif (not $self->{file}) {
|
||||
$self->error(NOFILE => 'WARN');
|
||||
}
|
||||
elsif (not -r "$dir/$self->{file}") {
|
||||
$self->error(BADFILE => WARN => "$dir/$self->{file}");
|
||||
}
|
||||
elsif (not open $fh, "< $dir/$self->{file}") {
|
||||
$self->error(LOADERROR => WARN => "$dir/$self->{file}");
|
||||
}
|
||||
else { # Everything is good, now we have $fh open to the file.
|
||||
$return->{success} = 1;
|
||||
$self->load($fh);
|
||||
while (my ($name, $val) = each %{$self->{headers}}) {
|
||||
if ($sep_headers{$name}) {
|
||||
$return->{"header_$name"} = $val;
|
||||
}
|
||||
else {
|
||||
push @{$return->{extra_headers}}, { name => $name, value => $val };
|
||||
}
|
||||
}
|
||||
$return->{body} = $self->{body};
|
||||
}
|
||||
if ($self->{_error}) {
|
||||
$return->{error} = join "<br>\n", @{$self->{_error}};
|
||||
}
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub tpl_delete {
|
||||
my $self = &_get_self;
|
||||
|
||||
if ($self->{dir} and $self->{template} and $self->{file}
|
||||
and $self->{template} !~ m[[\\/\x00-\x1f]] and $self->{template} ne '..'
|
||||
and $self->{file} !~ m[[\\/\x00-\x1f]]) {
|
||||
my $tpl = "$self->{dir}/$self->{template}/local/$self->{file}";
|
||||
if (-f $tpl and not unlink $tpl) {
|
||||
return { error => "Unable to remove $tpl: $!" };
|
||||
}
|
||||
}
|
||||
return { success => 1, error => '' };
|
||||
}
|
||||
|
||||
# Loads a template from a filehandle or a file.
|
||||
# You must pass in a GLOB reference as a filehandle to be read from.
|
||||
# Otherwise, this method will attempt to open the file passed in and then read from it.
|
||||
# (the file opened will have directory and template prepended to it).
|
||||
sub load {
|
||||
my $self = shift;
|
||||
my $fh;
|
||||
my $file = shift;
|
||||
if (ref $file eq 'GLOB' or ref $file eq 'SCALAR' or ref $file eq 'LVALUE') {
|
||||
$fh = $file;
|
||||
}
|
||||
else {
|
||||
$fh = \do { local *FILE; *FILE };
|
||||
my $dir;
|
||||
if ($self->{template}) {
|
||||
$dir = "$self->{dir}/$self->{template}";
|
||||
if (-f "$dir/local/$file") {
|
||||
$dir .= "/local";
|
||||
}
|
||||
elsif (!-f "$dir/$file") {
|
||||
my ($tplinfo, %tplinfo);
|
||||
while ($tplinfo = GT::Template->load_tplinfo($dir) and my $inherit = $tplinfo->{inheritance}) {
|
||||
if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
|
||||
$dir = $inherit;
|
||||
}
|
||||
else {
|
||||
$dir .= "/$inherit";
|
||||
}
|
||||
if (-f "$dir/local/$file") {
|
||||
$dir .= "/local";
|
||||
last;
|
||||
}
|
||||
elsif (-f "$dir/$file") {
|
||||
last;
|
||||
}
|
||||
if (length $dir > 150 or $tplinfo{$dir}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
|
||||
$self->error(RECURSION => WARN => $dir);
|
||||
last; # End the loop - there is no more inheritance since we would just be recursing over what we already have
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$file = "$dir/$file";
|
||||
|
||||
open $fh, "< $file" or return $self->error(BADFILE => WARN => $file);
|
||||
}
|
||||
if (ref $fh eq 'GLOB') {
|
||||
while (<$fh>) { # The header
|
||||
s/\r?\n$//;
|
||||
last if not $_; # An empty line is the end of the headers
|
||||
my ($field, $value) = split /:\s*/, $_, 2;
|
||||
$self->{headers}->{$field} = $value;
|
||||
}
|
||||
while (<$fh>) { # The body
|
||||
$self->{body} .= $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
(my $header, $self->{body}) = split /\r?\n\r?\n/, $$fh, 2;
|
||||
my @h = split /\r?\n/, $header;
|
||||
for (@h) {
|
||||
my ($field, $value) = split /:\s*/, $_, 2;
|
||||
$self->{headers}->{$field} = $value;
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Creates and returns a $self object. Looks at $_[0] to see if it is already
|
||||
# an editor object, and if so uses that. Otherwise it calls new() with @_.
|
||||
# Should be called as &_get_self; If called as a class method, the first
|
||||
# argument will be removed. So, instead of: 'my $self = shift;' you should
|
||||
# use: 'my $self = &_get_self;'
|
||||
sub _get_self {
|
||||
my $self;
|
||||
if (ref $_[0] and substr(ref $_[0], -8) eq '::Editor') { # This will allow any subclass as long as it is something::Editor
|
||||
$self = shift;
|
||||
}
|
||||
elsif (@_ and substr($_[0], -8) eq '::Editor') { # Class methods
|
||||
my $class = shift;
|
||||
$self = $class->new(@_);
|
||||
}
|
||||
else {
|
||||
$self = __PACKAGE__->new(@_);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->set(@_);
|
||||
tie %{$self->{headers}}, __PACKAGE__ . '::Ordered';
|
||||
}
|
||||
|
||||
|
||||
package GT::Mail::Editor::Ordered;
|
||||
# Implements a hash that retains the order elements are inserted into it.
|
||||
|
||||
sub TIEHASH { bless { o => [], h => {}, p => 0 }, $_[0] }
|
||||
|
||||
sub STORE {
|
||||
my ($self, $key, $val) = @_;
|
||||
$self->DELETE($key) if exists $self->{h}->{$key};
|
||||
$self->{h}->{$key} = $val;
|
||||
push @{$self->{o}}, $key;
|
||||
}
|
||||
|
||||
sub FETCH { $_[0]->{h}->{$_[1]} }
|
||||
|
||||
sub FIRSTKEY {
|
||||
my $self = shift;
|
||||
$self->{p} = 0;
|
||||
$self->{o}->[$self->{p}++]
|
||||
}
|
||||
|
||||
sub NEXTKEY { $_[0]->{o}->[$_[0]->{p}++] }
|
||||
|
||||
sub EXISTS { exists $_[0]->{h}->{$_[1]} }
|
||||
|
||||
sub DELETE {
|
||||
my ($self, $key) = @_;
|
||||
for (0 .. $#{$self->{o}}) {
|
||||
if ($self->{o}->[$_] eq $key) {
|
||||
splice @{$self->{o}}, $_, 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
delete $self->{h}->{$key};
|
||||
}
|
||||
sub CLEAR { $_[0] = { o => [], h => {}, p => 0 }; () }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Editor - E-mail template editor
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Generally used from templates:
|
||||
|
||||
<%GT::Mail::Editor::tpl_load(
|
||||
dir => $template_root,
|
||||
template => $template_set,
|
||||
file => $filename,
|
||||
header => From,
|
||||
header => To,
|
||||
header => Subject
|
||||
)%>
|
||||
|
||||
<%if error%>
|
||||
Unable to load e-mail template: <%error%>
|
||||
<%else%>
|
||||
From: <input type=text name=header_From value="<%header_From%>">
|
||||
To: <input type=text name=header_To value="<%header_To%>">
|
||||
Subject: <input type=text name=header_Subject value="<%header_Subject%>">
|
||||
Other headers:<br>
|
||||
<textarea name=extra_headers>
|
||||
<%loop extra_headers%><%name%>: <%value%>
|
||||
<%endloop%>
|
||||
<%endif%>
|
||||
|
||||
|
||||
- or -
|
||||
|
||||
|
||||
<%GT::Mail::Editor::save(
|
||||
dir => $template_root,
|
||||
template => $template_set,
|
||||
file => $filename,
|
||||
header => To => $header_To,
|
||||
header => From => $header_From,
|
||||
header => Subject => $header_Subject,
|
||||
extra_headers => $extra_headers
|
||||
)%>
|
||||
<%if error%>Unable to save e-mail template: <%error%>
|
||||
... Display the above form in here ...
|
||||
<%endif%>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Editor is designed to provide a template interface to creating and
|
||||
editing a wide variety of e-mail templates. Although not currently supported,
|
||||
eventually attachments, HTML, etc. will be supported.
|
||||
|
||||
=head2 tpl_load - Loads a template (from the templates)
|
||||
|
||||
Calling GT::Mail::Editor::tpl_load from a template returns variables required to
|
||||
display a form to edit the template passed in.
|
||||
|
||||
=over 4
|
||||
|
||||
=item dir
|
||||
|
||||
Defines the base directory of templates.
|
||||
|
||||
=item template
|
||||
|
||||
This defines a template set. This is optional. If present, this directory will
|
||||
be tacked onto the end of 'dir'. This is simply to provide a more flexible way
|
||||
to specify the template directory. For example, if you have 'dir' set to '/a/b'
|
||||
and template set to 'c', then the directory '/a/b/c' will be used to save and
|
||||
load e-mail templates.
|
||||
|
||||
=item file
|
||||
|
||||
Specify the filename of the template inside the directory already specified with
|
||||
'dir' and 'template'
|
||||
|
||||
=item header
|
||||
|
||||
Multiple "special" headers can be requested with this. The argument following
|
||||
each 'header' should be the name of a header, such as "To". Then, in the
|
||||
variables returned from tpl_load(), you will have a variable such as 'header_To'
|
||||
available, containing the value of the To: field.
|
||||
|
||||
=back
|
||||
|
||||
=head2 tpl_save - Save a template
|
||||
|
||||
=over 4
|
||||
|
||||
=item dir template file
|
||||
|
||||
See the entries in L<"tpl_load">
|
||||
|
||||
=item header
|
||||
|
||||
Specifies that the two following arguments are the field and value of a header
|
||||
field. For example, header => To => "abc@example.com" would specify that the To
|
||||
field should be "abc@example.com" (To: abc@example.com).
|
||||
|
||||
=item extra_headers
|
||||
|
||||
The value to extra_headers should be a newline-delimited list of headers other
|
||||
than those specified with header. These will be parsed, and blank lines skipped.
|
||||
|
||||
=item body
|
||||
|
||||
The body of the message. Need I say more? MIME messages are possible by
|
||||
inserting them directly into the body, however currently MIME messages cannot
|
||||
be created using this editor.
|
||||
|
||||
=back
|
||||
|
||||
=head2 load
|
||||
|
||||
Attempts to load a GT::Mail::Editor object with data passed in. This can take
|
||||
either a file handle or a filename. If passing a filename, dir and template
|
||||
will be used (if available). You should construct an object with new() prior
|
||||
to calling this method.
|
||||
|
||||
=head2 new
|
||||
|
||||
Constructs a new GT::Mail::Editor object. This will be done automatically when
|
||||
using the template methods L<"tpl_load"> and L<"tpl_save">. Takes the following
|
||||
arguments:
|
||||
|
||||
=over 4
|
||||
|
||||
=item dir
|
||||
|
||||
Defines the base directory of templates.
|
||||
|
||||
=item template
|
||||
|
||||
This defines a template set. This is optional. If present, this directory will
|
||||
be tacked onto the end of 'dir'. This is simply to provide a more flexible way
|
||||
to specify the template directory. For example, if you have 'dir' set to '/a/b'
|
||||
and template set to 'c', then the directory '/a/b/c' will be used to save and
|
||||
load e-mail templates.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Editor.pm,v 1.25 2008/09/23 23:55:26 brewt Exp $
|
||||
|
||||
267
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor/HTML.pm
Normal file
267
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor/HTML.pm
Normal file
@ -0,0 +1,267 @@
|
||||
|
||||
package GT::Mail::Editor::HTML;
|
||||
|
||||
use vars qw/$ERROR_MESSAGE/;
|
||||
use strict;
|
||||
use bases 'GT::Mail::Editor' => '';
|
||||
|
||||
$ERROR_MESSAGE = 'GT::Mail::Editor';
|
||||
|
||||
|
||||
sub display {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $tags ) = @_;
|
||||
my $page = $self->{html_tpl_name};
|
||||
|
||||
if ( $self->{fields}{page} and $self->{fields}{page} =~ /^(?:editor|email)_/ ) {
|
||||
$page = $self->{fields}{page};
|
||||
}
|
||||
my $ret = $self->print_page( $page, $tags );
|
||||
$self->{displayed} = 1;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub message_from_input {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
$self->set_headers;
|
||||
|
||||
# If we have a part ID, this isn't a new text part
|
||||
my ( $part, $id );
|
||||
$part = $self->{part};
|
||||
$part->set( 'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"' );
|
||||
if ( exists( $self->{fields}{msg} ) ) {
|
||||
my $msg = $self->{fields}{msg};
|
||||
$self->urls_to_inlines( $self->{part}, \$msg );
|
||||
$part->body_data( $msg );
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_message {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
|
||||
|
||||
my $root_part = $self->{message}->root_part;
|
||||
|
||||
# Simple case if the message is not multipart
|
||||
if ( !$root_part->is_multipart ) {
|
||||
$self->munge_non_multipart( $root_part );
|
||||
}
|
||||
|
||||
# We have a multipart. First thing we do is look for an alternative part
|
||||
# to use.
|
||||
elsif ( my ( $alt ) = $self->{message}->find_multipart( 'alternative' ) ) {
|
||||
$self->munge_alternative( $alt );
|
||||
}
|
||||
else {
|
||||
$self->munge_other;
|
||||
}
|
||||
$self->fix_alt_parts;
|
||||
$self->fix_related_parts;
|
||||
$self->delete_empty_multiparts;
|
||||
my ( $alt_part ) = $self->{message}->find_multipart( 'alternative' );
|
||||
my @skip = $alt_part->parts;
|
||||
$self->find_attachments( @skip );
|
||||
$self->{alt_part} = $alt_part;
|
||||
$self->{part} = $skip[1];
|
||||
}
|
||||
|
||||
sub html_part {
|
||||
# ----------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{alt_part}->parts->[1];
|
||||
}
|
||||
|
||||
sub text_part {
|
||||
# ----------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{alt_part}->parts->[0];
|
||||
}
|
||||
|
||||
sub munge_non_multipart {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $root_part ) = @_;
|
||||
|
||||
# We need to munge the message into a multipart
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $root_part,
|
||||
charset => $root_part->mime_attr( 'content-type.charset' ),
|
||||
headers_part => $root_part
|
||||
);
|
||||
$root_part->set( 'content-type' => 'multipart/mixed' );
|
||||
$root_part->parts( $new_alt );
|
||||
}
|
||||
|
||||
sub munge_alternative {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $alt_part ) = @_;
|
||||
my $root_part = $self->{message}->root_part;
|
||||
|
||||
# Make anything we can not view an attachment
|
||||
$self->{message}->move_parts_last(
|
||||
$root_part,
|
||||
grep {
|
||||
$_->content_type ne 'text/plain' and $_->content_type ne 'text/html'
|
||||
} $alt_part->parts
|
||||
);
|
||||
|
||||
# Anything left is either text or html
|
||||
my ( $html_part, $text_part );
|
||||
for ( $alt_part->parts ) {
|
||||
if ( $_->content_type eq 'text/html' ) {
|
||||
$html_part = $_;
|
||||
}
|
||||
else {
|
||||
$text_part = $_;
|
||||
}
|
||||
}
|
||||
# If we do not have an editble part we need to make an empty html one
|
||||
if ( !defined( $text_part ) and !defined( $html_part ) ) {
|
||||
$html_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"',
|
||||
-body_data => '<html><body></body></html>'
|
||||
);
|
||||
}
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $html_part,
|
||||
text => $text_part,
|
||||
charset => $self->{fields}{charset}
|
||||
);
|
||||
if ( $alt_part == $root_part ) {
|
||||
$root_part->set( 'content-type' => 'multipart/mixed' );
|
||||
$self->{message}->delete_parts( $root_part->parts );
|
||||
$root_part->parts( $new_alt );
|
||||
}
|
||||
else {
|
||||
$self->{message}->replace_part( $alt_part, $new_alt );
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_other {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
|
||||
# Else we need to search through the parts to find the displayable parts
|
||||
my ( $html_part, $text_part );
|
||||
for my $part ( $self->{message}->all_parts ) {
|
||||
if ( !$html_part and $part->content_type eq 'text/html' and $part->mime_attr( 'content-disposition' ) ne 'attachment' ) {
|
||||
$html_part = $part;
|
||||
}
|
||||
elsif ( !$text_part and $part->content_type eq 'text/plain' and $part->mime_attr( 'content-disposition' ) ne 'attachment' ) {
|
||||
$text_part = $part;
|
||||
}
|
||||
last if $html_part and $text_part;
|
||||
}
|
||||
# If we do not have an editble part we need to make an empty html one
|
||||
if ( !defined( $text_part ) and !defined( $html_part ) ) {
|
||||
$html_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"',
|
||||
-body_data => '<html><body></body></html>'
|
||||
);
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $html_part,
|
||||
text => $text_part,
|
||||
charset => $self->{fields}{charset}
|
||||
);
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $new_alt );
|
||||
my $parent = $self->{message}->parent_part( $new_alt );
|
||||
if ( $parent and $parent->content_type eq 'multipart/related' ) {
|
||||
$parent->set( 'content-type' => 'multipart/mixed' );
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $new_alt = $self->alt_part(
|
||||
html => $html_part,
|
||||
text => $text_part,
|
||||
charset => $self->{fields}{charset}
|
||||
);
|
||||
my $parent_part = $self->{message}->parent_part( $html_part );
|
||||
if ( !$parent_part ) { $parent_part = $self->{message}->parent_part( $text_part ) }
|
||||
if ( $parent_part and $parent_part->content_type eq 'multipart/related' ) {
|
||||
if ( !$html_part ) {
|
||||
$parent_part->set( 'content-type' => 'multipart/mixed' );
|
||||
$self->{message}->add_parts_start( $parent_part, $new_alt );
|
||||
if ( $text_part ) {
|
||||
$self->{message}->delete_part( $text_part );
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{message}->replace_part( $parent_part->parts->[0], $new_alt );
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ( $text_part ) {
|
||||
$self->{message}->delete_part( $text_part );
|
||||
}
|
||||
if ( $html_part ) {
|
||||
$self->{message}->delete_part( $html_part );
|
||||
}
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $new_alt );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub alt_part {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, %opts ) = @_;
|
||||
my ( $text, $html, $header_from, $charset ) = @opts{qw/text html headers_part charset/};
|
||||
|
||||
my $text_type = 'text/plain; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"';
|
||||
my $html_type = 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"';
|
||||
|
||||
if ( defined( $text ) ) {
|
||||
$text = $self->new_part_from( $text, $text_type );
|
||||
}
|
||||
elsif ( defined( $html ) ) {
|
||||
$text = $self->{message}->new_part(
|
||||
'content-type' => $text_type,
|
||||
-body_data => $self->html_to_text( ref( $html ) ? $html->body_data : $html )
|
||||
);
|
||||
}
|
||||
else {
|
||||
$self->fatal( BADARGS => "Either text or html must be defined" );
|
||||
}
|
||||
if ( defined( $html ) ) {
|
||||
$html = $self->new_part_from( $html, $html_type );
|
||||
}
|
||||
elsif ( defined( $text ) ) {
|
||||
$html = $self->{message}->new_part(
|
||||
'content-type' => $html_type,
|
||||
-body_data => $self->text_to_html( $text->body_data )
|
||||
);
|
||||
}
|
||||
# logic error, one must be defined
|
||||
else {
|
||||
$self->fatal( BADARGS => "Either text or html must be defined" );
|
||||
}
|
||||
my @header = ();
|
||||
if ( $header_from ) {
|
||||
@header = map { $_ => [$header_from->get( $_ )] } $header_from->get;
|
||||
}
|
||||
return $self->{message}->new_part(
|
||||
@header,
|
||||
'content-type' => 'multipart/alternative',
|
||||
-parts => [$text, $html]
|
||||
);
|
||||
}
|
||||
|
||||
sub new_part_from {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $from, $type ) = @_;
|
||||
if ( !ref( $from ) ) {
|
||||
return $self->{message}->new_part(
|
||||
'content-type' => $type,
|
||||
-body_data => $from
|
||||
);
|
||||
}
|
||||
elsif ( ref( $from ) ) {
|
||||
return $self->{message}->new_part(
|
||||
'content-type' => $type,
|
||||
-body_data => $from->body_data
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
147
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor/Text.pm
Normal file
147
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor/Text.pm
Normal file
@ -0,0 +1,147 @@
|
||||
|
||||
package GT::Mail::Editor::Text;
|
||||
|
||||
use vars qw/$ERROR_MESSAGE/;
|
||||
use strict;
|
||||
use bases 'GT::Mail::Editor' => '';
|
||||
|
||||
$ERROR_MESSAGE = 'GT::Mail::Editor';
|
||||
|
||||
sub display {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self, $tags ) = @_;
|
||||
my $page = $self->{text_tpl_name};
|
||||
|
||||
if ( $self->{fields}{page} and $self->{fields}{page} =~ /^(?:editor|email)_/ ) {
|
||||
$page = $self->{fields}{page};
|
||||
}
|
||||
my $ret = $self->print_page( $page, $tags );
|
||||
$self->{displayed} = 1;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub message_from_input {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
$self->set_headers;
|
||||
|
||||
# If we have a part ID, this isn't a new text part
|
||||
my ( $part, $id );
|
||||
$part = $self->{part};
|
||||
$part->set( 'content-type' => 'text/plain; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"' );
|
||||
if ( exists( $self->{fields}{msg} ) ) {
|
||||
$part->body_data( $self->{fields}{msg} );
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_message {
|
||||
# ----------------------------------------------------------------
|
||||
my ( $self ) = @_;
|
||||
|
||||
my $root_part = $self->{message}->root_part;
|
||||
|
||||
# Simple case if the message is not multipart
|
||||
my ( $text_part, $html_part, $related_part, $alt_part );
|
||||
if ( !$root_part->is_multipart ) {
|
||||
$text_part = $root_part;
|
||||
}
|
||||
|
||||
# We have a multipart. First thing we do is look for an alternative part
|
||||
# to use.
|
||||
else {
|
||||
|
||||
# First we look for the proper alternative mime parts
|
||||
$alt_part = ($self->{message}->find_multipart( 'alternative' ))[0];
|
||||
if ( $alt_part ) {
|
||||
my @alt_parts = $alt_part->parts;
|
||||
for ( @alt_parts ) {
|
||||
if ( $_->content_type eq 'text/plain' ) {
|
||||
$text_part = $self->{message}->delete_part( $_ );
|
||||
}
|
||||
elsif ( $_->content_type eq 'text/html' ) {
|
||||
$html_part = $self->{message}->delete_part( $_ );
|
||||
}
|
||||
}
|
||||
if ( !$text_part and $html_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => $self->html_to_text( $html_part->body_data )
|
||||
);
|
||||
}
|
||||
elsif ( !$text_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => ''
|
||||
);
|
||||
}
|
||||
|
||||
# Make anything we can not view an attachment
|
||||
$self->{message}->move_parts_last(
|
||||
$root_part,
|
||||
map {
|
||||
unless ( $_->is_multipart ) {
|
||||
$_->set( 'content-disposition' => 'attachment' );
|
||||
}
|
||||
$_;
|
||||
} $alt_part->parts
|
||||
);
|
||||
|
||||
if ( $alt_part == $root_part ) {
|
||||
$alt_part->set( 'content-type' => 'multipart/mixed' );
|
||||
}
|
||||
else {
|
||||
$self->{message}->delete_part( $alt_part );
|
||||
}
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $text_part );
|
||||
}
|
||||
else {
|
||||
|
||||
# Else we can just stick the text part at the beginning
|
||||
for my $part ( $self->{message}->all_parts ) {
|
||||
my $disp = $part->mime_attr( 'content-disposition' );
|
||||
next if $disp and $disp eq 'attachment';
|
||||
if ( $part->content_type eq 'text/plain' ) {
|
||||
$text_part = $self->{message}->delete_part( $part );
|
||||
}
|
||||
elsif ( $part->content_type eq 'text/html' ) {
|
||||
$html_part = $self->{message}->delete_part( $part );
|
||||
}
|
||||
}
|
||||
if ( !$text_part and $html_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => $self->html_to_text( $html_part->body_data )
|
||||
);
|
||||
}
|
||||
elsif ( !$text_part ) {
|
||||
$text_part = $self->{message}->new_part(
|
||||
'content-type' => 'text/plain',
|
||||
-body_data => ''
|
||||
);
|
||||
}
|
||||
$self->{message}->add_parts_start( $self->{message}->root_part, $text_part );
|
||||
}
|
||||
}
|
||||
my $parent = $self->{message}->parent_part( $text_part );
|
||||
if ( $parent and $parent->content_type eq 'multipart/related' ) {
|
||||
$parent->set( 'content-type' => 'multipart/mixed' );
|
||||
}
|
||||
$self->fix_alt_parts;
|
||||
$self->fix_related_parts;
|
||||
$self->delete_empty_multiparts;
|
||||
$self->find_attachments( $text_part );
|
||||
|
||||
if ( @{[$self->{message}->all_parts]} == 1 and $self->{message}->root_part->is_multipart ) {
|
||||
$self->{message}->delete_part( $text_part );
|
||||
my $root_part = $self->{message}->root_part;
|
||||
$root_part->set( 'content-type' => 'text/plain' );
|
||||
$root_part->body_data( $text_part->body_data );
|
||||
}
|
||||
$self->{part} = $text_part;
|
||||
}
|
||||
|
||||
sub html_part { return }
|
||||
sub text_part { return shift()->{part} }
|
||||
|
||||
1;
|
||||
|
||||
429
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Encoder.pm
Normal file
429
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Encoder.pm
Normal file
@ -0,0 +1,429 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Encoder
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Encoder.pm,v 1.44 2008/10/29 23:31:51 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface for encoding data.
|
||||
#
|
||||
|
||||
package GT::Mail::Encoder;
|
||||
# ==================================================================
|
||||
# If MIME::Base64 is installed use it - must eval before hand or 5.004_04
|
||||
# wipes our ISA.
|
||||
my $have_b64 = eval {
|
||||
local $SIG{__DIE__};
|
||||
require MIME::Base64;
|
||||
import MIME::Base64;
|
||||
if ($] < 5.005) { local $^W; encode_base64('brok'); }
|
||||
1;
|
||||
};
|
||||
$have_b64 or *encode_base64 = \>_old_encode_base64;
|
||||
my $use_encode_qp;
|
||||
if ($have_b64 and
|
||||
$MIME::Base64::VERSION ge 2.16 and
|
||||
defined &MIME::QuotedPrint::encode_qp and (
|
||||
not defined &MIME::QuotedPrint::old_encode_qp or
|
||||
\&MIME::QuotedPrint::encode_qp != \&MIME::QuotedPrint::old_encode_qp
|
||||
)
|
||||
) {
|
||||
$use_encode_qp = 1;
|
||||
}
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG @ISA %EncodeFor $CRLF);
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.44 $ =~ /(\d+)\.(\d+)/;
|
||||
$CRLF = "\015\012";
|
||||
$DEBUG = 0;
|
||||
@ISA = qw(GT::Base);
|
||||
|
||||
my %EncoderFor = (
|
||||
# Standard...
|
||||
'7bit' => sub { NBit('7bit', @_) },
|
||||
'8bit' => sub { NBit('8bit', @_) },
|
||||
'base64' => \&Base64,
|
||||
'binary' => \&Binary,
|
||||
'none' => \&Binary,
|
||||
'quoted-printable' => \&QuotedPrint,
|
||||
|
||||
# Non-standard...
|
||||
'x-uu' => \&UU,
|
||||
'x-uuencode' => \&UU,
|
||||
);
|
||||
|
||||
sub new {
|
||||
# --------------------------------------------------------------------------
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {}, $class;
|
||||
$self->init(@_);
|
||||
my $encoding = lc($self->{encoding} || '');
|
||||
defined $EncoderFor{$encoding} or return or return $self->error("NOENCODING", "FATAL");
|
||||
$self->debug("Set encoding to $encoding") if ($self->{_debug});
|
||||
$self->{encoding} = $EncoderFor{$encoding};
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->init (%opts);
|
||||
# -------------------
|
||||
# Sets the options for the current object.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift }
|
||||
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
else { return $self->error("BADARGS", "FATAL", "init") }
|
||||
|
||||
$self->{_debug} = exists($opt->{debug}) ? $opt->{debug} : $DEBUG;
|
||||
for my $m (qw(encoding in out)) {
|
||||
$self->{$m} = $opt->{$m} if defined $opt->{$m};
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub gt_encode {
|
||||
# --------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (!ref $self or ref $self ne 'GT::Mail::Encoder') {
|
||||
$self = GT::Mail::Encoder->new(@_) or return;
|
||||
}
|
||||
$self->{encoding} or return $self->error("NOENCODING", "FATAL");;
|
||||
return $self->{encoding}->($self->{in}, $self->{out});
|
||||
}
|
||||
|
||||
sub supported { return exists $EncoderFor{pop()} }
|
||||
|
||||
|
||||
sub Base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out) = @_;
|
||||
my $encoded;
|
||||
|
||||
my $nread;
|
||||
my $buf = '';
|
||||
|
||||
# Reading multiples of 57 bytes is recommended by MIME::Base64 as it comes out
|
||||
# to a line of exactly 76 characters (the max). We use 2299*57 (131043 bytes)
|
||||
# because it comes out to about 128KB (131072 bytes). Admittedly, this number
|
||||
# is fairly arbitrary, but should work well for both large and small files, and
|
||||
# shouldn't be too memory intensive.
|
||||
my $read_size = 2299 * 57;
|
||||
|
||||
if (not ref $in) {
|
||||
while (1) {
|
||||
last unless length $in;
|
||||
$buf = substr($in, 0, $read_size);
|
||||
substr($in, 0, $read_size) = '';
|
||||
|
||||
$encoded = encode_base64($buf, $CRLF);
|
||||
|
||||
# Encoding to send over SMTP
|
||||
$encoded .= $CRLF unless $encoded =~ /$CRLF\Z/; # ensure newline!
|
||||
$out->($encoded);
|
||||
}
|
||||
}
|
||||
elsif (defined fileno $in) {
|
||||
while ($nread = read($in, $buf, $read_size)) {
|
||||
$encoded = encode_base64($buf, $CRLF);
|
||||
|
||||
$encoded .= $CRLF unless $encoded =~ /$CRLF\Z/; # ensure newline!
|
||||
$out->($encoded);
|
||||
}
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to Base64, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub Binary {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out) = @_;
|
||||
|
||||
if (not ref $in) {
|
||||
$in =~ s/\015?\012/$CRLF/g;
|
||||
$out->($in);
|
||||
}
|
||||
elsif (defined fileno $in) {
|
||||
my ($buf, $nread) = ('', 0);
|
||||
while ($nread = read($in, $buf, 4096)) {
|
||||
$buf =~ s/\015?\012/$CRLF/g;
|
||||
$out->($buf);
|
||||
}
|
||||
defined ($nread) or return; # check for error
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to Binary, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub UU {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out, $file) = @_;
|
||||
|
||||
my $buf = '';
|
||||
my $fname = ($file || '');
|
||||
$out->("begin 644 $fname\n");
|
||||
if (not ref $in) {
|
||||
while (1) {
|
||||
last unless length $in;
|
||||
$buf = substr($in, 0, 45);
|
||||
substr($in, 0, 45) = '';
|
||||
$out->(pack('u', $buf));
|
||||
}
|
||||
}
|
||||
elsif (defined fileno $in) {
|
||||
while (read($in, $buf, 45)) {
|
||||
$buf =~ s/\015?\012/$CRLF/g;
|
||||
$out->(pack('u', $buf))
|
||||
}
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to UU, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
$out->("end\n");
|
||||
1;
|
||||
}
|
||||
|
||||
sub NBit {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($enc, $in, $out) = @_;
|
||||
|
||||
if (not ref $in) {
|
||||
$in =~ s/\015?\012/$CRLF/g;
|
||||
$out->($in);
|
||||
}
|
||||
elsif (defined fileno $in) {
|
||||
while (<$in>) {
|
||||
s/\015?\012/$CRLF/g;
|
||||
$out->($_);
|
||||
}
|
||||
}
|
||||
elsif (ref $in eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to NBit, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
sub QuotedPrint {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($in, $out) = @_;
|
||||
|
||||
local $_;
|
||||
my $ref = ref $in;
|
||||
if ($ref and not defined fileno($in)) {
|
||||
if ($ref eq 'GLOB') {
|
||||
die "Glob reference passed in is not an open filehandle";
|
||||
}
|
||||
else {
|
||||
die "Bad arguments passed to QuotedPrint, first argument must be a scalar or a filehandle";
|
||||
}
|
||||
}
|
||||
$in =~ s/\015?\012/\n/g unless $ref;
|
||||
|
||||
while () {
|
||||
local $_;
|
||||
if ($ref) {
|
||||
# Try to get around 32KB at once. This could end up being much larger than
|
||||
# 32KB if there is a very very long line - up to the length of the line + 32700
|
||||
# bytes.
|
||||
$_ = <$in>;
|
||||
while (my $line = <$in>) {
|
||||
$_ .= $line;
|
||||
last if length > 32_700; # Not exactly 32KB, but close enough.
|
||||
}
|
||||
last unless defined;
|
||||
}
|
||||
else {
|
||||
# Grab up to just shy of 32KB of the string, plus the following line. As
|
||||
# above, this could be much longer than 32KB if there is one or more very long
|
||||
# lines involved.
|
||||
$in =~ s/^(.{0,32700}.*?(?:\n|\Z))//ms; # Encode somewhere around 32KB at a time
|
||||
$_ = $1;
|
||||
last unless defined and length;
|
||||
}
|
||||
|
||||
if ($use_encode_qp) {
|
||||
$_ = MIME::QuotedPrint::encode_qp($_, $CRLF);
|
||||
}
|
||||
else {
|
||||
s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3
|
||||
s/([ \t]+)$/
|
||||
join('', map { sprintf("=%02X", ord($_)) }
|
||||
split('', $1)
|
||||
)/egm; # rule #3 (encode whitespace at eol)
|
||||
|
||||
# rule #5 (lines must be shorter than 76 chars, but we are not allowed
|
||||
# to break =XX escapes. This makes things complicated :-( )
|
||||
my $brokenlines = "";
|
||||
$brokenlines .= "$1=\n"
|
||||
while s/(.*?^[^\n]{73} (?:
|
||||
[^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
|
||||
|[^=\n] (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
|
||||
| (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
|
||||
))//xsm;
|
||||
|
||||
$_ = "$brokenlines$_";
|
||||
|
||||
s/\015?\012/$CRLF/g;
|
||||
}
|
||||
|
||||
# Escape 'From ' at the beginning of the line. This is fairly easy - if the
|
||||
# line is currently 73 or fewer characters, we simply change the F to =46,
|
||||
# making the line 75 characters long (the max). If the line is longer than 73,
|
||||
# we escape the F, follow it with "=$CRLF", and put the 'rom ' and the rest of
|
||||
# the line on the next line - meaning one line of 4 characters, and one of 73
|
||||
# or 74.
|
||||
s/^From (.*)/
|
||||
length($1) <= 68 ? "=46rom $1" : "=46=${CRLF}rom $1"
|
||||
/emg; # Escape 'From' at the beginning of a line
|
||||
# The '.' at the beginning of the line is more difficult. The easy case is
|
||||
# when the line is 73 or fewer characters - just escape the initial . and we're
|
||||
# done. If the line is longer, the fun starts. First, we escape the initial .
|
||||
# to =2E. Then we look for the first = in the line; if it is found within the
|
||||
# first 3 characters, we split two characters after it (to catch the "12" in
|
||||
# "=12") otherwise we split after the third character. We then add "=$CRLF" to
|
||||
# the current line, and look at the next line; if it starts with 'From ' or a
|
||||
# ., we escape it - and since the second line will always be less than 73
|
||||
# characters long (since we remove at least three for the first line), we can
|
||||
# just escape it without worrying about splitting the line up again.
|
||||
s/^\.([^$CRLF]*)/
|
||||
if (length($1) <= 72) {
|
||||
"=2E$1"
|
||||
}
|
||||
else {
|
||||
my $ret = "=2E";
|
||||
my $match = $1;
|
||||
my $index = index($match, '=');
|
||||
my $len = $index >= 2 ? 2 : $index + 3;
|
||||
$ret .= substr($match, 0, $len);
|
||||
substr($match, 0, $len) = '';
|
||||
$ret .= "=$CRLF";
|
||||
substr($match, 0, 1) = "=46" if substr($match, 0, 5) eq 'From ';
|
||||
substr($match, 0, 1) = "=2E" if substr($match, 0, 1) eq '.';
|
||||
$ret .= $match;
|
||||
$ret
|
||||
}
|
||||
/emg;
|
||||
|
||||
$out->($_);
|
||||
|
||||
last unless $ref or length $in;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub gt_old_encode_base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my $eol = $_[1];
|
||||
$eol = "\n" unless defined $eol;
|
||||
|
||||
my $res = pack("u", $_[0]);
|
||||
$res =~ s/^.//mg; # Remove first character of each line
|
||||
$res =~ tr/\n//d; # Remove newlines
|
||||
|
||||
$res =~ tr|` -_|AA-Za-z0-9+/|;
|
||||
|
||||
# Fix padding at the end
|
||||
my $padding = (3 - length($_[0]) % 3) % 3;
|
||||
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
|
||||
|
||||
# Break encoded string into lines of no more than 76 characters each
|
||||
if (length $eol) {
|
||||
$res =~ s/(.{1,76})/$1$eol/g;
|
||||
}
|
||||
$res;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Encoder - MIME Encoder
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
open IN, 'decoded.txt' or die $!;
|
||||
open OUT, '>encoded.txt' or die $!;
|
||||
if (GT::Mail::Encoder->supported ('7bit')) {
|
||||
GT::Mail::Encoder->decode (
|
||||
debug => 1,
|
||||
encoding => '7bit',
|
||||
in => \*IN,
|
||||
out => sub { print OUT $_[0] }
|
||||
) or die $GT::Mail::Encoder::error;
|
||||
}
|
||||
else {
|
||||
die "Unsupported encoding";
|
||||
}
|
||||
close IN;
|
||||
close OUT;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Encoder is a MIME Encoder implemented in perl. It will try to use
|
||||
the C extension for encoding Base64. If the extension is not there
|
||||
it will do it in perl (slow!).
|
||||
|
||||
=head2 Encoding a stream
|
||||
|
||||
The new() constructor and the supported() class method are the only methods that
|
||||
are public in the interface. The new() constructor takes a hash of params.
|
||||
The supported() method takes a single string, the name of the encoding you want
|
||||
to encode and returns true if the encoding is supported and false otherwise.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Set debugging level. 1 or 0.
|
||||
|
||||
=item encoding
|
||||
|
||||
Sets the encoding used to encode.
|
||||
|
||||
=item in
|
||||
|
||||
Set to a file handle or IO handle.
|
||||
|
||||
=item out
|
||||
|
||||
Set to a code reference, the decoded stream will be passed in at the first
|
||||
argument for each chunk encoded.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Encoder.pm,v 1.44 2008/10/29 23:31:51 brewt Exp $
|
||||
|
||||
|
||||
672
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Message.pm
Normal file
672
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Message.pm
Normal file
@ -0,0 +1,672 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Message
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,068,085,094,083
|
||||
# $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::Mail::Message;
|
||||
|
||||
use strict;
|
||||
use vars qw/$ATTRIBS $CRLF/;
|
||||
use bases 'GT::Base' => '';
|
||||
|
||||
$ATTRIBS = {
|
||||
root_part => undef,
|
||||
debug => 0
|
||||
};
|
||||
|
||||
$CRLF = "\012";
|
||||
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------------
|
||||
# Init called from GT::Base
|
||||
my $self = shift;
|
||||
|
||||
$self->set( @_ );
|
||||
|
||||
if ( !defined( $self->{root_part} ) ) {
|
||||
$self->{root_part} = new GT::Mail::Parts;
|
||||
}
|
||||
$self->{parts} = _get_parts( $self->{root_part} );
|
||||
}
|
||||
|
||||
|
||||
sub delete_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Deletes the given part from the email
|
||||
#
|
||||
my ( $self, $part ) = @_;
|
||||
|
||||
die "Can't delete top level part" if $part == $self->{root_part};
|
||||
$self->_link;
|
||||
|
||||
|
||||
# We must remove it from the flat list of parts
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Now we must relink our list
|
||||
$self->_link;
|
||||
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub move_part_before {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part before another part. The first argument is the part to move
|
||||
# before, the second is the part to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $before_part, $part ) = @_;
|
||||
die "Can't move part before the top part" if $before_part == $self->{root_part};
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $before_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Now we add
|
||||
$self->add_part_before( $before_part, $part );
|
||||
}
|
||||
|
||||
sub move_part_after {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part after another part. The first argument is the part to move
|
||||
# after, the second is the part to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $after_part, $part ) = @_;
|
||||
die "Can't move part after the top part" if $after_part == $self->{root_part};
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $after_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Now we add
|
||||
$self->add_part_after( $after_part, $part );
|
||||
}
|
||||
|
||||
sub move_part_end {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part to the end of a multipart part. The first part is the
|
||||
# multipart part to move it to the end of. The second argument is the part
|
||||
# to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part to be moved
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Then we add it back in
|
||||
$self->add_part_end( $parent_part, $part );
|
||||
}
|
||||
|
||||
sub move_part_beginning {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part to the beginning of a multipart part. The first part is the
|
||||
# multipart part to move it to the beginning of. The second argument is the
|
||||
# part to move. No moving the top level part.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
|
||||
# First remove the part to be moved
|
||||
$self->_delete_part( $part );
|
||||
|
||||
# Then we add it back in
|
||||
$self->add_part_beginning( $parent_part, $part );
|
||||
}
|
||||
|
||||
sub replace_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Replace a part with another part
|
||||
#
|
||||
my ( $self, $old_part, $new_part ) = @_;
|
||||
$self->_link;
|
||||
splice( @{$self->{parts}}, $old_part->{id}, 1, $new_part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_before {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part before the given part. The first argument is the part object
|
||||
# to add the part before. the second argument is the part to add.
|
||||
#
|
||||
my ( $self, $before_part, $part ) = @_;
|
||||
$self->_link;
|
||||
die "Can't add part before the top level part" if $before_part == $self->{root_part};
|
||||
my $parent_id = $before_part->{parent_id};
|
||||
|
||||
if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The part's parent must exist and must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $before_part->{id}, 0, $part );
|
||||
my $parent_part = $self->{parts}[$parent_id];
|
||||
$parent_part->add_parts_before( $before_part->{id}, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_after {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part after the given part. The first argument is the part object
|
||||
# to add the part after. the second argument is the part to add.
|
||||
#
|
||||
my ( $self, $after_part, $part ) = @_;
|
||||
$self->_link;
|
||||
die "Can't add part after the top level part" if $after_part == $self->{root_part};
|
||||
my $parent_id = $after_part->{parent_id};
|
||||
|
||||
if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The part's parent must exist and must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $after_part->{id} + 1, 0, $part );
|
||||
my $parent_part = $self->{parts}[$parent_id];
|
||||
$parent_part->add_parts_after( $after_part->{id}, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_beginning {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part at the beginning of the given multipart part. The first
|
||||
# argument is the part object to add the part before. the second argument is
|
||||
# the part to add.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
$self->_link;
|
||||
my $parent_id = $parent_part->{id};
|
||||
|
||||
if ( !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The parent part must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $parent_id + 1, 0, $part );
|
||||
$parent_part->add_part_before( $part->{parts}[0]{id}, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub add_part_end {
|
||||
# --------------------------------------------------------------------------
|
||||
# Adds a part at the end of the given multipart part. The first argument is
|
||||
# the part object to add the part at the end of. the second argument is the
|
||||
# part to add. The first argument must be a multipart part or a fatal error
|
||||
# occurs.
|
||||
#
|
||||
my ( $self, $parent_part, $part ) = @_;
|
||||
$self->_link;
|
||||
my $parent_id = $parent_part->{id};
|
||||
|
||||
if ( !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The parent part must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $parent_id + @parts, 0, $part );
|
||||
$parent_part->parts( $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub move_part_to_position {
|
||||
# --------------------------------------------------------------------------
|
||||
# Move a part to a position within another multipart part. The first
|
||||
# argument is the part to move within, the second argument is the part to
|
||||
# move and the final argument is the position within those parts to move it
|
||||
# in.
|
||||
#
|
||||
my ( $self, $parent_part, $part, $pos ) = @_;
|
||||
die "Can't move top part" if $part == $self->{root_part};
|
||||
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
|
||||
die "All parts specified must be in the MIME message";
|
||||
}
|
||||
$self->_link;
|
||||
my $parent_id = $parent_part->{id};
|
||||
|
||||
if ( !$self->{parts}[$parent_id]->is_multipart ) {
|
||||
die "The parent part must be a multipart";
|
||||
}
|
||||
splice( @{$self->{parts}}, $parent_id + $pos, $part );
|
||||
$self->_link;
|
||||
}
|
||||
|
||||
sub get_part_by_id {
|
||||
# --------------------------------------------------------------------------
|
||||
# Method to retrieve a part object by it's id
|
||||
#
|
||||
my ( $self, $id ) = @_;
|
||||
|
||||
return $self->{parts}[$id];
|
||||
}
|
||||
|
||||
sub new_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Method to easily create a part object. All the header fields can be passed
|
||||
# in as a hash. If the key "body_data" the value will be set as the parts
|
||||
# body rather than a header field.
|
||||
#
|
||||
my ( $self, @opts ) = @_;
|
||||
my $part = new GT::Mail::Parts;
|
||||
while ( my ( $key, $val ) = ( shift( @opts ), shift( @opts ) ) ) {
|
||||
if ( $key eq 'body_data' ) {
|
||||
$part->body_data( $val );
|
||||
}
|
||||
elsif ( $key eq 'body_handle' ) {
|
||||
$part->body_handle( $val );
|
||||
}
|
||||
elsif ( $key eq 'body_path' ) {
|
||||
$part->body_path( $val );
|
||||
}
|
||||
else {
|
||||
$part->set( $key => $val );
|
||||
}
|
||||
}
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub all_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# my @parts = $obj->all_parts;
|
||||
# ----------------------------
|
||||
# Returns a list of all the part object for the current parsed email.
|
||||
# If the email is not multipart this will be just the header part.
|
||||
#
|
||||
return @{shift()->{parts}}
|
||||
}
|
||||
|
||||
sub size {
|
||||
# --------------------------------------------------------------------------
|
||||
# Returns the total size of an email. Call this method after the email has
|
||||
# been parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
(@{$self->{parts}} > 0) or return;
|
||||
my $size = 0;
|
||||
foreach (@{$self->{parts}}) {
|
||||
$size += $_->size;
|
||||
}
|
||||
return $size;
|
||||
}
|
||||
|
||||
sub as_string {
|
||||
# --------------------------------------------------------------------------
|
||||
# Returns the entire email as a sting.
|
||||
#
|
||||
my ( $self ) = @_;
|
||||
$GT::Mail::Encoder::CRLF = $CRLF;
|
||||
|
||||
my $out;
|
||||
$$out = ' ' x 50*1024;
|
||||
$self->debug ("\n\t--------------> Creating email") if $self->{_debug};
|
||||
|
||||
# Need the head to contiue
|
||||
$self->{root_part} or die "No root part!";
|
||||
$self->{root_part}->set( 'MIME-Version' => '1.0' ) unless $self->{root_part}->get( 'MIME-Version' );
|
||||
|
||||
my $bound = $self->{root_part}->multipart_boundary;
|
||||
|
||||
# If the message has parts
|
||||
|
||||
if ( @{$self->{root_part}->{parts}} > 0 ) {
|
||||
$self->debug( "Creating multipart email." ) if $self->{_debug};
|
||||
$self->_build_multipart_head( $out );
|
||||
}
|
||||
|
||||
# Else we are single part and have either a body IO handle or the body is in memory
|
||||
else {
|
||||
$self->debug( "Creating singlepart email." ) if $self->{_debug};
|
||||
$self->_build_singlepart_head( $out );
|
||||
}
|
||||
|
||||
# If we have parts go through all of them and add them.
|
||||
if ( @{$self->{root_part}->{parts}} > 0 ) {
|
||||
my $num_parts = $#{$self->{root_part}->{parts}};
|
||||
for my $num ( 0 .. $num_parts ) {
|
||||
next unless $self->{root_part}->{parts}->[$num];
|
||||
$self->debug( "Creating part ($num)." ) if $self->{_debug};
|
||||
$self->_build_parts( $out, $self->{root_part}->{parts}->[$num] );
|
||||
if ( $num_parts == $num ) {
|
||||
$self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . '--' . $CRLF;
|
||||
}
|
||||
else {
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . $CRLF;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Add the epilogue if we are multipart
|
||||
if ( @{$self->{root_part}->{parts}} > 0 ) {
|
||||
my $epilogue = join( '', @{$self->{root_part}->epilogue || []} ) || '';
|
||||
$epilogue =~ s/\015?\012//g;
|
||||
$self->debug( "Setting epilogue to ($epilogue)" ) if $self->{_debug};
|
||||
$$out .= $epilogue . $CRLF . $CRLF if $epilogue;
|
||||
}
|
||||
$self->debug( "\n\t<-------------- Email created." ) if $self->{_debug};
|
||||
return $$out;
|
||||
}
|
||||
|
||||
sub _build_multipart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a multipart header.
|
||||
#
|
||||
my ( $self, $out ) = @_;
|
||||
my $bound = $self->{root_part}->multipart_boundary;
|
||||
my $encoding = $self->{root_part}->suggest_encoding;
|
||||
$self->debug( "Setting encoding to ($encoding)." ) if ( $self->{debug} );
|
||||
$self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
|
||||
$bound or $bound = "---------=_" . scalar (time) . "-$$-" . int(rand(time)/2);
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $self->{root_part}->get( 'Content-Type' );
|
||||
if ( $c !~ /\Q$bound/i ) {
|
||||
if ( $c and lc( $c ) !~ /boundary=/ ) {
|
||||
$c =~ /multipart/ or $c = 'multipart/mixed';
|
||||
$self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{debug};
|
||||
$self->{root_part}->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
|
||||
}
|
||||
else {
|
||||
$self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
|
||||
$self->{root_part}->set( 'Content-Type' => qq!multipart/mixed; boundary="$bound"! )
|
||||
}
|
||||
}
|
||||
|
||||
my $preamble = join( '', @{$self->{root_part}->preamble || []} ) || "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug( "Setting preamble to ($preamble)." ) if ( $self->{_debug} );
|
||||
( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $head . $CRLF . $preamble . $CRLF . $CRLF . '--' . $bound . $CRLF;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_singlepart_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method to build a single part header.
|
||||
#
|
||||
my ( $self, $out ) = @_;
|
||||
my $encoding = $self->{root_part}->suggest_encoding;
|
||||
$self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
|
||||
$self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
|
||||
( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$$out .= $head . $CRLF;
|
||||
$self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode (
|
||||
debug => $self->{_debug},
|
||||
encoding => $encoding,
|
||||
in => $self->{root_part}->body_as_string,
|
||||
out => $out
|
||||
) or return;
|
||||
|
||||
# Must seek to the beginning for additional calles
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _build_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# Private method that builds the parts for the email.
|
||||
#
|
||||
my ($self, $out, $part) = @_;
|
||||
|
||||
# Need the head to contiue
|
||||
$self->{root_part} or die "No root part!";
|
||||
|
||||
my ( $body, $encoding, $bound );
|
||||
$bound = $part->multipart_boundary;
|
||||
|
||||
|
||||
# Find the encoding for the part and set it.
|
||||
$encoding = $part->suggest_encoding;
|
||||
$self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
|
||||
$part->set( 'Content-Transfer-Encoding' => $encoding );
|
||||
|
||||
# If the message has parts and has a multipart boundary
|
||||
if ( @{$part->{parts}} > 0 and $bound ) {
|
||||
$self->debug( "Part is multpart." ) if $self->{_debug};
|
||||
|
||||
# Set the multipart boundary
|
||||
$self->debug( "Setting boundary to ($bound)." ) if $self->{_debug};
|
||||
|
||||
# Set the content boundary unless it has already been set
|
||||
my $c = $part->get( 'Content-Type' );
|
||||
if ( $c ) {
|
||||
$self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{_debug};
|
||||
$part->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
|
||||
}
|
||||
else {
|
||||
$self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
|
||||
$part->set( 'Content-Type' => qq!multipart/mixed; boundary="$bound"! );
|
||||
}
|
||||
|
||||
my $preamble = join( '' => @{ $part->preamble || [] } ) || "This is a multi-part message in MIME format.";
|
||||
$preamble =~ s/\015?\012//g;
|
||||
$self->debug( "Setting preamble to ($preamble)." ) if $self->{_debug};
|
||||
( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $head . $CRLF . $preamble . $CRLF . '--' . $bound . $CRLF;
|
||||
}
|
||||
else {
|
||||
$self->debug( "Part is single part." ) if $self->{_debug};
|
||||
( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
|
||||
$$out .= $head . $CRLF;
|
||||
|
||||
# Set the body only if we have one. We would not have one on the head an multipart
|
||||
$self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
|
||||
GT::Mail::Encoder->gt_encode(
|
||||
encoding => $encoding,
|
||||
debug => $self->{_debug},
|
||||
in => $part->body_as_string,
|
||||
out => $out
|
||||
) or return;
|
||||
|
||||
}
|
||||
|
||||
# Add the rest of the parts
|
||||
if ( @{$part->{parts}} > 0 ) {
|
||||
$self->debug( "Part has parts." ) if $self->{_debug};
|
||||
my $num_parts = $#{$part->{parts}};
|
||||
for my $num ( 0 .. $num_parts ) {
|
||||
next unless $part->{parts}->[$num];
|
||||
$self->debug( "Creating part ($num)." ) if $self->{_debug};
|
||||
$self->_build_parts( $out, $part->{parts}->[$num] ) or return;
|
||||
if ( $bound ) {
|
||||
if ( $num_parts == $num ) {
|
||||
$self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . '--' . $CRLF;
|
||||
}
|
||||
else {
|
||||
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
|
||||
$$out .= $CRLF . '--' . $bound . $CRLF;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Maybe done!
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _delete_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal method to delete a part
|
||||
my ( $self, $part ) = @_;
|
||||
|
||||
# We must remove it from it's parent
|
||||
my $parent = $self->{parts}[$part->{parent_id}];
|
||||
for ( 0 .. $#{$parent->{parts}} ) {
|
||||
if ( $parent->{parts}[$_]{id} == $part->{id} ) {
|
||||
splice( @{$parent->{parts}}, $_, 1 );
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
# We must remove it from the flat list of parts
|
||||
return splice( @{$self->{parts}}, $part->{id}, 1 );
|
||||
}
|
||||
|
||||
sub _part_in_message {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal method to find out weather a part is in the current message
|
||||
my ( $self, $part ) = @_;
|
||||
for ( @{$self->{parts}} ) {
|
||||
return 1 if $_ == $part;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub _link {
|
||||
# --------------------------------------------------------------------------
|
||||
# Creats part ids and links the children to the parrents. Called
|
||||
# When parts arer modified
|
||||
#
|
||||
my ( $self ) = @_;
|
||||
|
||||
# Creates ids to keep track of parts with.
|
||||
for ( 0 .. $#{$self->{parts}} ) {
|
||||
$self->{parts}[$_]{id} = $_;
|
||||
}
|
||||
_link_ids( $self->{root_part} );
|
||||
}
|
||||
|
||||
sub _links_ids {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal function to link all children to their parents with the parent id.
|
||||
# RECURSIVE
|
||||
#
|
||||
my ( $part, $parent_id ) = @_;
|
||||
for ( @{$part->{parts}} ) {
|
||||
_link_ids( $_, $part->{id} );
|
||||
}
|
||||
$part->{parent_id} = $parent_id;
|
||||
}
|
||||
|
||||
sub _get_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# Recursive function to get a flat list of all the parts in a part structure
|
||||
#
|
||||
my ( $part, $parts ) = @_;
|
||||
$parts ||= [];
|
||||
|
||||
for ( @{$part->{parts}} ) {
|
||||
push @$parts, @{_get_parts( $_, $parts )};
|
||||
}
|
||||
return $parts;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Message - Encapsolates an email message.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::Message;
|
||||
|
||||
# Get a GT::Mail::Message object from the parser
|
||||
use GT::Mail::Parse;
|
||||
|
||||
my $parser = new GT::Mail::Parse( in_file => "myemail.eml" );
|
||||
my $message = $parser->parse;
|
||||
|
||||
# Get the top level part
|
||||
my $root_part = $message->root_part;
|
||||
|
||||
# Replace the first part with a new part
|
||||
$message->replace_part( $root_part, $message->new_part(
|
||||
to => 'scott@gossamer-threads.com',
|
||||
from => 'alex@gossamer-threads.com',
|
||||
'content-type' => 'text/plain',
|
||||
body_data => 'Hi Scott, how are you?!'
|
||||
);
|
||||
|
||||
# Add a part at the end
|
||||
my $end_part = $message->new_part(
|
||||
'content-type' => 'image/gif',
|
||||
body_path => 'myimage.jpg'
|
||||
);
|
||||
$message->add_part_end( $root_part, $end_part );
|
||||
|
||||
# Move the first part in the top part to after the end part
|
||||
$message->move_part_after( $root_part->parts->[0], $end_part );
|
||||
|
||||
# Print the mime message
|
||||
print $message->to_string;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Message encapsolates a mime message which consists of
|
||||
L<GT::Mail::Parts> object. This module provides methods to change,
|
||||
move, remove, and access these parts.
|
||||
|
||||
=head2 Creating a new GT::Mail::Message object
|
||||
|
||||
Usually you will get a GT::Mail::Message object by call the parse method
|
||||
in L<GT::Mail::Parse>.
|
||||
|
||||
my $message = $parser->parse;
|
||||
|
||||
You may also call new on this class specifying the top level part and or
|
||||
a debug level.
|
||||
|
||||
my $message = new GT::Mail::Message(
|
||||
root_part => $part,
|
||||
debug => 1
|
||||
);
|
||||
|
||||
=head2 Creating a new Part
|
||||
|
||||
You can create a part by calling new on L<GT::Mail::Parts> directly
|
||||
|
||||
my $part = new GT::Mail::Parts;
|
||||
$part->set( 'content-type' => 'image/gif' );
|
||||
$part->body_path( 'myimage.gif' );
|
||||
|
||||
or you can call a method in this module to get a new part
|
||||
|
||||
my $part = $message->new_part(
|
||||
'content-type' => 'image/gif',
|
||||
body_path => 'myimage.gif'
|
||||
);
|
||||
|
||||
This method is a wraper on a combination of new() and some other
|
||||
supporting methods in L<GT::Mail::Parts> such as body_path(). Anything
|
||||
that is not B<body_path>, B<body_data>, or B<body_handle> is treated
|
||||
as header values.
|
||||
|
||||
=head2 Manipulating Parts
|
||||
|
||||
A MIME message is just a format for storing a tree structure. We provide
|
||||
tree-like methods to manipulate parts. All the method for manipulating
|
||||
parts take the part object(s) as arguments. We do this so you do not need
|
||||
to know how the tree is tracked internally.
|
||||
|
||||
=head2 Accessing Parts
|
||||
|
||||
|
||||
More to come!
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $
|
||||
|
||||
|
||||
|
||||
829
site/slowtwitch.com/cgi-bin/articles/GT/Mail/POP3.pm
Normal file
829
site/slowtwitch.com/cgi-bin/articles/GT/Mail/POP3.pm
Normal file
@ -0,0 +1,829 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::POP3
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: POP3.pm,v 1.57 2008/09/23 23:55:26 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface to a POP3 server.
|
||||
#
|
||||
|
||||
package GT::Mail::POP3;
|
||||
# ==================================================================
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw!$VERSION $DEBUG $ERROR $CRLF @ISA $ERRORS $ATTRIBS!;
|
||||
|
||||
# Constants
|
||||
use constants TIMEOUT => 0.01; # The timeout used on selects.
|
||||
|
||||
# Internal modules
|
||||
use GT::Base;
|
||||
use GT::Socket::Client;
|
||||
use GT::Mail::Parts;
|
||||
use GT::Mail::Parse;
|
||||
|
||||
# System modules
|
||||
use Fcntl qw/O_NONBLOCK F_SETFL F_GETFL/;
|
||||
use POSIX qw/EAGAIN EINTR/;
|
||||
|
||||
# Silence warnings
|
||||
$GT::Mail::Parse::error = '';
|
||||
|
||||
@ISA = qw(GT::Base);
|
||||
$DEBUG = 0;
|
||||
$CRLF = "\r\n";
|
||||
$| = 1;
|
||||
|
||||
$ATTRIBS = {
|
||||
host => undef,
|
||||
port => undef,
|
||||
user => undef,
|
||||
pass => undef,
|
||||
auth_mode => 'PASS',
|
||||
debug => 0,
|
||||
blocking => 0,
|
||||
ssl => 0,
|
||||
timeout => 30, # The connection timeout (passed to GT::Socket::Client)
|
||||
data_timeout => 5, # The timeout to read/write data from/to the connected socket
|
||||
};
|
||||
|
||||
$ERRORS = {
|
||||
NOTCONNECTED => "You are calling %s and you have not connected yet!",
|
||||
CANTCONNECT => "Could not connect to POP3 server: %s",
|
||||
READ => "Unble to read from socket, reason (%s). Read: (%s)",
|
||||
WRITE => "Unable to write %s length to socket. Wrote %s, Error(%s)",
|
||||
NOEOF => "No EOF or EOL found. Socket locked.",
|
||||
ACTION => "Could not %s. Server said: %s",
|
||||
NOMD5 => "Unable to load GT::MD5 (required for APOP authentication): %s",
|
||||
PARSE => "An error occurred while parsing an email: %s",
|
||||
LOGIN => "An error occurred while logging in: %s",
|
||||
OPEN => "Could not open (%s) for read and write. Reason: %s",
|
||||
};
|
||||
|
||||
sub head_part {
|
||||
# --------------------------------------------------------
|
||||
# my $head = $obj->head_part($num);
|
||||
# ---------------------------------
|
||||
# This method takes one argument, the number message to
|
||||
# parse. It returns a GT::Mail::Parts object that has
|
||||
# only the top level head part parsed.
|
||||
#
|
||||
my ($self, $num) = @_;
|
||||
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->head_part ($msg_num)');
|
||||
my $io = '';
|
||||
$self->top($num, sub { $io .= $_[0] }) or return;
|
||||
return GT::Mail::Parse->new(debug => $self->{_debug}, crlf => $CRLF)->parse_head(\$io);
|
||||
}
|
||||
|
||||
sub all_head_parts {
|
||||
# --------------------------------------------------------
|
||||
# my @heads = $obj->all_head_parts;
|
||||
# ---------------------------------
|
||||
# This does much the same as head_part() but returns an
|
||||
# array of GT::Mail::Parts objects, each one only having
|
||||
# the head of the message parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
my @head_parts;
|
||||
for (1 .. $self->stat) {
|
||||
my $part = $self->head_part($_) or return;
|
||||
push(@head_parts, $part);
|
||||
}
|
||||
return wantarray ? @head_parts : \@head_parts;
|
||||
}
|
||||
|
||||
sub parse_message {
|
||||
# --------------------------------------------------------
|
||||
# my $mail = $obj->parse_message($num);
|
||||
# -------------------------------------
|
||||
# This method returns a GT::Mail object. It calles parse
|
||||
# for the message number specified before returning the
|
||||
# object. You can retrieve the different parts of the
|
||||
# message through the GT::Mail object. If this method
|
||||
# fails you should check $GT::Mail::error.
|
||||
#
|
||||
my ($self, $num) = @_;
|
||||
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->parse_message($msg_num)');
|
||||
my $io = $self->retr($num) or return;
|
||||
my $parser = new GT::Mail::Parse(debug => $self->{_debug}, in_string => $io, crlf => $CRLF);
|
||||
$parser->parse or return $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
|
||||
return $parser;
|
||||
}
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------
|
||||
# Initilize the POP box object.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
$self->set(@_);
|
||||
|
||||
for (qw/user pass host/) {
|
||||
(defined($self->{$_})) or return $self->error('BADARGS', 'FATAL', "CLASS->new(%ARGS); The '$_' key in the hash must exists");
|
||||
}
|
||||
$self->{_debug} = exists($self->{debug}) ? delete($self->{debug}) : $DEBUG;
|
||||
|
||||
# Can be either PASS or APOP depending on login type.
|
||||
$self->{auth_mode} ||= 'PASS';
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub send {
|
||||
# --------------------------------------------------------
|
||||
# Send a message to the server.
|
||||
#
|
||||
my ($self, $msg) = @_;
|
||||
|
||||
unless (defined $msg and length $msg) {
|
||||
$self->debug("Sending blank message!") if $self->{_debug};
|
||||
return;
|
||||
}
|
||||
|
||||
# Get the socket and end of line.
|
||||
my $s = $self->{sock};
|
||||
defined($s) and defined fileno($s) or return $self->error("NOTCONNECTED", "WARN", "send()");
|
||||
|
||||
# Print the message.
|
||||
$self->debug("--> $msg") if $self->{_debug};
|
||||
|
||||
$s->write($msg . $CRLF);
|
||||
|
||||
$self->getline(my $line) or return;
|
||||
|
||||
$line =~ s/$CRLF//o if $line;
|
||||
$line ||= 'Nothing sent back';
|
||||
$self->{message} = $line;
|
||||
$self->debug("<-- $line") if $self->{_debug};
|
||||
|
||||
return $line;
|
||||
}
|
||||
|
||||
sub getline {
|
||||
# --------------------------------------------------------
|
||||
# Read a line of input from the server.
|
||||
#
|
||||
my ($self) = @_;
|
||||
my $got_cr;
|
||||
my $safety;
|
||||
my $s = $self->{sock};
|
||||
$s->readline($_[1]);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub getall {
|
||||
# --------------------------------------------------------
|
||||
# Get all pending output from the server.
|
||||
#
|
||||
my ($self) = @_;
|
||||
$_[1] = '';
|
||||
my $l = 0;
|
||||
my $safety;
|
||||
my $s = $self->{sock};
|
||||
if ($self->{blocking}) {
|
||||
while (<$s>) {
|
||||
last if /^\.$CRLF/o;
|
||||
s/^\.//; # Lines starting with a . are doubled up in POP3
|
||||
$_[1] .= $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $save = $s->read_size;
|
||||
$s->read_size(1048576);
|
||||
$s->readalluntil("\n.$CRLF", $_[1], ".$CRLF");
|
||||
$s->read_size($save);
|
||||
|
||||
$_[1] =~ s/\n\.\r?\n$/\n/; # Remove the final . at the end of the e-mail
|
||||
$_[1] =~ s/^\.//mg; # Remove the initial '.' from any lines beginning with .
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub connect {
|
||||
# --------------------------------------------------------
|
||||
# Connect to the server.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($s, $iaddr, $msg, $paddr, $proto);
|
||||
|
||||
$self->debug("Attempting to connect .. ") if ($self->{_debug});
|
||||
|
||||
$self->{blocking} = 1 if $self->{ssl};
|
||||
$self->{port} ||= $self->{ssl} ? 995 : 110;
|
||||
|
||||
# If there was an existing connection, it'll be closed here when we reassign
|
||||
$self->{sock} = GT::Socket::Client->open(
|
||||
port => $self->{port},
|
||||
host => $self->{host},
|
||||
max_down => 0,
|
||||
timeout => $self->{timeout},
|
||||
non_blocking => !$self->{blocking},
|
||||
select_time => TIMEOUT,
|
||||
read_wait => $self->{data_timeout},
|
||||
ssl => $self->{ssl},
|
||||
debug => $self->{_debug}
|
||||
) or return $self->error("CANTCONNECT", "WARN", GT::Socket::Client->error);
|
||||
|
||||
$self->debug('Connected to ' . $self->{host} . ' on port ' . $self->{port} . ($self->{ssl} ? ' via SSL' : '')) if $self->{_debug};
|
||||
|
||||
# Get server welcoming.
|
||||
$self->getline($msg) or return;
|
||||
|
||||
# Store this - it's needed for APOP authentication
|
||||
$self->{msg_id}= $1 if ($msg =~ /(<[\w\d\-\.]+\@[\w\d\-\.]+>)/);
|
||||
|
||||
$self->debug("Going to login") if $self->{_debug};
|
||||
return $self->login();
|
||||
}
|
||||
|
||||
sub login {
|
||||
# --------------------------------------------------------
|
||||
# Login either using APOP or regular.
|
||||
#
|
||||
my $self = shift;
|
||||
($self->{auth_mode} eq 'APOP' && $self->{msg_id}) ? $self->login_apop : $self->login_pass;
|
||||
}
|
||||
|
||||
sub login_apop {
|
||||
# --------------------------------------------------------
|
||||
# Login using APOP.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($hash, $count, $line);
|
||||
{
|
||||
local $SIG{__DIE__};
|
||||
eval { require GT::MD5; 1 } or return $self->error('NOMD5', 'WARN', $@);
|
||||
}
|
||||
$self->debug("Attempting to log in via APOP ... ") if $self->{_debug};
|
||||
$hash = GT::MD5::md5_hex($self->{msg_id} . $self->{pass});
|
||||
|
||||
local ($_) = $self->send('APOP ' . $self->{user} . ' ' . $hash) or return;
|
||||
substr($_, 0, 1) eq '+' or return $self->error("LOGIN", "WARN", "APOP Login failed: $_");
|
||||
if (/^\+OK \S+ has (\d+) /i) {
|
||||
$self->{count} = $1;
|
||||
}
|
||||
elsif (uc substr($_, 0, 3) ne '+OK') {
|
||||
return $self->error('LOGIN', 'WARN', $_);
|
||||
}
|
||||
$self->{state} = 'TRANSACTION';
|
||||
$self->stat() or return;
|
||||
|
||||
$self->debug("APOP Login successful.") if $self->{_debug};
|
||||
return (($self->{count} == 0) ? '0E0' : $self->{count});
|
||||
}
|
||||
|
||||
sub login_pass {
|
||||
# --------------------------------------------------------
|
||||
# Login using clear text authentication.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($line);
|
||||
|
||||
$self->debug("Attempting to log in via clear text ... ") if $self->{_debug};
|
||||
|
||||
# Enter username.
|
||||
local($_) = $self->send('USER ' . $self->{user}) or return;
|
||||
substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "USER POP Login failed: $_");
|
||||
|
||||
# Enter password.
|
||||
$_ = $self->send('PASS ' . $self->{pass}) or return;
|
||||
substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "PASS POP Login failed: $_");
|
||||
|
||||
# Ok, get total number of message, and pop box status.
|
||||
if (/^\+OK \S+ has (\d+) /i) {
|
||||
$self->{count} = $1;
|
||||
}
|
||||
elsif (uc substr($_, 0, 3) ne '+OK') {
|
||||
return $self->error('LOGIN', 'WARN', $_);
|
||||
}
|
||||
$self->stat() or return;
|
||||
|
||||
$self->debug("Login successful.") if $self->{_debug};
|
||||
return $self->{count} == 0 ? '0E0' : $self->{count};
|
||||
}
|
||||
|
||||
sub top {
|
||||
# --------------------------------------------------------
|
||||
# Get the header of a message and the next x lines (optional).
|
||||
#
|
||||
my ($self, $num, $code) = @_;
|
||||
defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->head($msg_num);. No message number passed to head.');
|
||||
$self->debug("Getting head of message $num ... ") if $self->{_debug};
|
||||
|
||||
local($_) = $self->send("TOP $num 0") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "TOP $num 0", "($_)");
|
||||
|
||||
my ($tp, $header);
|
||||
$self->getall($header);
|
||||
if (substr($header, 0, 1) eq '>') {
|
||||
substr($header, 0, index($header, $CRLF) + 2) = '';
|
||||
}
|
||||
|
||||
# Support broken headers which given unix linefeeds.
|
||||
if ($header =~ /[^\r]\n/) {
|
||||
$header =~ s/\r?\n/$CRLF/g;
|
||||
}
|
||||
$self->debug("Top of message $num retrieved.") if $self->{_debug};
|
||||
if ($code and ref $code eq 'CODE') {
|
||||
$code->($header);
|
||||
}
|
||||
else {
|
||||
return wantarray ? split(/$CRLF/o, $header) : $header;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub retr {
|
||||
# --------------------------------------------------------
|
||||
# Get the entire message.
|
||||
#
|
||||
my ($self, $num, $code) = @_;
|
||||
defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->retr ($msg_numm, $code);');
|
||||
|
||||
$self->debug("Getting message $num ... ") if ($self->{_debug});
|
||||
|
||||
# Get the size of the message
|
||||
local ($_) = $self->send("RETR $num") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', "RETR $num", $_);
|
||||
|
||||
# Retrieve the entire email
|
||||
my $body = '';
|
||||
$self->getall($body);
|
||||
|
||||
# Qmail puts this wierd header as the first line
|
||||
if (substr($body, 0, 1) eq '>') {
|
||||
substr($body, 0, index($body, $CRLF) + 2) = '';
|
||||
}
|
||||
|
||||
# Support broken pop servers that send us unix linefeeds.
|
||||
if ($body =~ /[^\r]\n/) {
|
||||
$body =~ s/\r?\n/$CRLF/g;
|
||||
}
|
||||
$self->debug("Message $num retrieved.") if $self->{_debug};
|
||||
if ($code and ref $code eq 'CODE') {
|
||||
$code->($body);
|
||||
}
|
||||
else {
|
||||
return \$body;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub last {
|
||||
my ($self) = @_;
|
||||
|
||||
local($_) = $self->send("LAST") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LAST", $_);
|
||||
s/^\+OK\s*//i;
|
||||
return $_;
|
||||
}
|
||||
|
||||
sub message_save {
|
||||
# --------------------------------------------------------
|
||||
# Get a message and save it to a file rather then returning.
|
||||
#
|
||||
my ($self, $num, $file) = @_;
|
||||
|
||||
# Check arguments.
|
||||
$num or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');
|
||||
$file or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');
|
||||
|
||||
my $io;
|
||||
if (ref $file) {
|
||||
$io = $file;
|
||||
}
|
||||
else {
|
||||
$file =~ /^\s*(.+?)\s*$/ and $file = $1;
|
||||
$io = \do { local *FH; *FH };
|
||||
open $io, ">$file" or return $self->error("OPENWRITE", "FATAL", $file, "$!");
|
||||
}
|
||||
|
||||
# Get the entire message body.
|
||||
$self->retr($num, sub { print $io $_[0] });
|
||||
$self->debug("Message $num saved to '$file'.") if $self->{_debug};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub stat {
|
||||
# --------------------------------------------------------
|
||||
# Handle a stat command, get the number of messages and size.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
local($_) = $self->send("STAT") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', 'STAT', $_);
|
||||
if (/^\+OK (\d+) (\d+)/i) {
|
||||
$self->{count} = $1;
|
||||
$self->{size} = $2;
|
||||
$self->debug("STAT successful - count: $1 size: $2") if $self->{_debug};
|
||||
}
|
||||
else {
|
||||
$self->debug("STAT failed, can't determine count.") if $self->{_debug};
|
||||
}
|
||||
return $self->{count} || "0E0";
|
||||
}
|
||||
|
||||
sub list {
|
||||
# --------------------------------------------------------
|
||||
# Return a list of messages available.
|
||||
#
|
||||
my $self = shift;
|
||||
my $num = shift || '';
|
||||
my @messages;
|
||||
|
||||
# Broken pop servers that don't like 'LIST '.
|
||||
my $cmd = ($num eq '') ? 'LIST' : "LIST $num";
|
||||
|
||||
local($_) = $self->send($cmd) or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LIST $num", $_);
|
||||
if ($num) {
|
||||
s/^\+OK\s*//i;
|
||||
return $_;
|
||||
}
|
||||
my $msg = '';
|
||||
$self->getall($msg);
|
||||
@messages = split /$CRLF/o => $msg;
|
||||
$self->debug(@messages . " messages listed.") if ($self->{_debug});
|
||||
if (@messages) {
|
||||
return wantarray ? @messages : join("", @messages);
|
||||
}
|
||||
}
|
||||
|
||||
sub rset {
|
||||
# --------------------------------------------------------
|
||||
# Reset deletion stat.
|
||||
#
|
||||
my $self = shift;
|
||||
local($_) = $self->send("RSET") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "RSET", $_);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub dele {
|
||||
# --------------------------------------------------------
|
||||
# Delete a given message.
|
||||
#
|
||||
my ($self, $num) = @_;
|
||||
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->dele ($msg_num)');
|
||||
local($_) = $self->send("DELE $num") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "DELE $num", $_);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub quit {
|
||||
# --------------------------------------------------------
|
||||
# Close the socket.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->send("QUIT") or return;
|
||||
close $self->{sock};
|
||||
$self->{sock} = undef;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uidl {
|
||||
# --------------------------------------------------------
|
||||
# Returns a list of uidls from the remote server
|
||||
#
|
||||
my $self = shift;
|
||||
my $num = shift;
|
||||
local $_;
|
||||
if ($num and !ref $num) {
|
||||
$_ = $self->send("UIDL $num") or return;
|
||||
/^\+OK \d+ (.+)$/i or return $self->error("ACTION", "WARN", "UIDL $num", $_);
|
||||
return $1;
|
||||
}
|
||||
my $ret = {};
|
||||
$_ = $self->send("UIDL") or return;
|
||||
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "UIDL $num", $_);
|
||||
my $list = '';
|
||||
$self->getall($list);
|
||||
for (split /$CRLF/o => $list) {
|
||||
if ($num and ref($num) eq 'CODE') {
|
||||
$num->($_);
|
||||
}
|
||||
else {
|
||||
/^(\d+) (.+)/ and $ret->{$1} = $2;
|
||||
}
|
||||
}
|
||||
return wantarray ? %{$ret} : $ret;
|
||||
}
|
||||
|
||||
sub count {
|
||||
# --------------------------------------------------------
|
||||
# Accessor for number of messages waiting.
|
||||
#
|
||||
return $_[0]->{count};
|
||||
}
|
||||
|
||||
sub size {
|
||||
# --------------------------------------------------------
|
||||
# Accessor for size of messages waiting.
|
||||
#
|
||||
return $_[0]->{count};
|
||||
}
|
||||
|
||||
sub last_message {
|
||||
# --------------------------------------------------------
|
||||
# Accessor for last server message.
|
||||
|
||||
@_ == 2 and $_[0]->{message} = $_[1];
|
||||
return $_[0]->{message};
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# --------------------------------------------------------
|
||||
# Auto close the socket.
|
||||
#
|
||||
my $self = shift;
|
||||
if ($self->{sock} and defined fileno($self->{sock})) {
|
||||
$self->send("QUIT");
|
||||
close $self->{sock};
|
||||
$self->{sock} = undef;
|
||||
}
|
||||
$self->debug("POP Object destroyed.") if ($self->{_debug} > 1);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::POP3 - Receieve email through POP3 protocal
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::POP3;
|
||||
|
||||
my $pop = GT::Mail::POP3->new(
|
||||
host => 'mail.gossamer-threads.com',
|
||||
port => 110,
|
||||
user => 'someusername',
|
||||
pass => 'somepassword',
|
||||
auth_mode => 'PASS',
|
||||
timeout => 30,
|
||||
debug => 1
|
||||
);
|
||||
|
||||
my $count = $pop->connect or die $GT::Mail::POP3::error;
|
||||
|
||||
for my $num (1 .. $count) {
|
||||
my $top = $pop->parse_head($num);
|
||||
|
||||
my @to = $top->split_field;
|
||||
|
||||
if (grep /myfriend\@gossamer-threads\.com/, @to) {
|
||||
$pop->message_save($num, '/keep/email.txt');
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::POP3 is a module to check an email account using the POP3 protocol.
|
||||
Many of the methods are integrated with L<GT::Mail::Parse>.
|
||||
|
||||
=head2 new - constructor method
|
||||
|
||||
This method is inherited from L<GT::Base>. The argument to this method can be
|
||||
in the form of a hash or hash ref. As a minimum 'user', 'pass', and 'host' must
|
||||
be specified.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debugging level for this instance of GT::Mail::POP3.
|
||||
|
||||
=item host
|
||||
|
||||
Sets the host to connect to for checking a POP account. This argument must be
|
||||
provided.
|
||||
|
||||
=item port
|
||||
|
||||
Sets the port on the POP server to attempt to connect to. This defaults to 110,
|
||||
unless using SSL, for which the default is 995.
|
||||
|
||||
=item ssl
|
||||
|
||||
Establishes the connection using SSL. Note that this requires Net::SSLeay of
|
||||
at least version 1.06.
|
||||
|
||||
=item user
|
||||
|
||||
Sets the user name to login with when connecting to the POP server. This must
|
||||
be specified.
|
||||
|
||||
=item pass
|
||||
|
||||
Sets the password to login with when connection to the POP server. This must be
|
||||
specified.
|
||||
|
||||
=item auth_mode
|
||||
|
||||
Sets the authentication type for this connection. This can be one of two
|
||||
values. PASS (the default) or APOP. If set to APOP, GT::Mail::POP3 will use
|
||||
APOP to login to the remote server.
|
||||
|
||||
=item timeout
|
||||
|
||||
Sets the connection timeout. This isn't entirely reliable as it uses alarm(),
|
||||
which isn't supported on all systems. That aside, this normally isn't needed
|
||||
if you want a timeout - it defaults to 30 on alarm()-supporting systems. The
|
||||
main purpose is to provide a value of 0 to disable the alarm() timeout.
|
||||
|
||||
=back
|
||||
|
||||
=head2 connect - Connect to the POP account
|
||||
|
||||
$obj->connect or die $GT::Mail::POP3::error;
|
||||
|
||||
This method performs the connection to the POP server. Returns the count of
|
||||
messages on the server on success, and undefined on failure. Takes no arguments
|
||||
and called before you can perform any actions on the POP server.
|
||||
|
||||
=head2 head_part - Access the email header
|
||||
|
||||
# Get a parsed header part object for the first email in the list.
|
||||
my $top_part = $obj->head_part(1);
|
||||
|
||||
Instance method. The only argument to this method is the message number to get.
|
||||
Returns a L<GT::Mail::Parts> object containing only the parsed header of the
|
||||
specified message.
|
||||
|
||||
=head2 all_head_parts - Access all email headers
|
||||
|
||||
# Get all the head parts from all messages
|
||||
my @headers = $obj->all_head_parts;
|
||||
|
||||
Instance method. Gets all the headers of all the email's on the remote server.
|
||||
Returns an array of the L<GT::Mail::Parts> object. One object for each
|
||||
email. None of the email's bodies are retrieved, only the head.
|
||||
|
||||
=head2 parse_message - Access an email
|
||||
|
||||
# Parse an email and get the GT::Mail object
|
||||
my $mail = $obj->parse_message (1);
|
||||
|
||||
Instance method. Pass in the number of the email to retrieve. This method
|
||||
retrieves the specified email and returns the parsed GT::Mail object. If this
|
||||
method fails you should check $GT::Mail::error for the error message.
|
||||
|
||||
=head2 message_save - Save an email
|
||||
|
||||
open FH, '/path/to/email.txt' or die $!;
|
||||
|
||||
# Save message 2 to file
|
||||
$obj->message_save (2, \*FH);
|
||||
close FH;
|
||||
|
||||
- or -
|
||||
|
||||
$obj->message_save (2, '/path/to/email.txt') or die $GT::Mail::POP3::error;
|
||||
|
||||
Instance method. This method takes the message number as it's first argument,
|
||||
and either a file path or a file handle ref as it's second argument. If a file
|
||||
path is provided the file will be opened to truncate. The email is then
|
||||
retrieved from the server and written to the file.
|
||||
|
||||
=head2 stat - Do a STAT command
|
||||
|
||||
# Get the number of messages on the server
|
||||
my $count = $obj->stat;
|
||||
|
||||
Instance method. Does a STAT command on the remote server. It stores the total
|
||||
size and returns the count of messages on the server, if successful. Otherwise
|
||||
returns undef.
|
||||
|
||||
=head2 list - Do a LIST command
|
||||
|
||||
# At a list of messages on the server
|
||||
my @messages = $obj->list;
|
||||
|
||||
Instance method. Does a LIST command on the remote server. Returns an array of
|
||||
the lines in list context and a single scalar that contains all the lines in
|
||||
scalar context.
|
||||
|
||||
=head2 rset - Do an RSET command
|
||||
|
||||
# Tell the server to ignore any dele commands we have issued in this
|
||||
# session
|
||||
$obj->rset;
|
||||
|
||||
Instance method. Does an RSET command. This command resets the servers
|
||||
knowledge of what should be deleted when QUIT is called. Returns 1 on success.
|
||||
|
||||
=head2 dele - Do a DELE command
|
||||
|
||||
# Delete message 4
|
||||
$obj->dele (4);
|
||||
|
||||
Instance method. Does a DELE command. The only argument is the message number
|
||||
to delete. Returns 1 on success.
|
||||
|
||||
=head2 quit - Quit the connection
|
||||
|
||||
# Close our connection
|
||||
$obj->quit;
|
||||
|
||||
Instance method. Sends the QUIT command to the server. The should should
|
||||
disconnect soon after this. No more actions can be taken on this connection
|
||||
until connect is called again.
|
||||
|
||||
=head2 uidl - Do a UIDL command
|
||||
|
||||
# Get the uidl for message 1
|
||||
my $uidl = $obj->uidl (1);
|
||||
|
||||
# Get a list of all the uidl's and print them
|
||||
$obj->uidl (sub { print @_ });
|
||||
|
||||
# Get an array of all the uidl's
|
||||
my @uidl = $obj->uidl;
|
||||
|
||||
Instance method. Attempts to do a UIDL command on the remote server. Please be
|
||||
aware support for the UIDL command is not very wide spread. This method can
|
||||
take the message number as it's first argument. If the message number is given,
|
||||
the UIDL for that message is returned. If the first argument is a code
|
||||
reference, a UIDL command is done with no message specified and the code
|
||||
reference is called for each line returned from the remote server. If no second
|
||||
argument is given, a UIDL command is done, and the results are returned in a
|
||||
has of message number to UIDL.
|
||||
|
||||
=head2 count - Get the number of messages
|
||||
|
||||
# Get the count from the last STAT
|
||||
my $count = $obj->count;
|
||||
|
||||
This method returns the number of messages on the server from the last STAT
|
||||
command. A STAT is done on connect.
|
||||
|
||||
=head2 size - Get the size of all messages
|
||||
|
||||
# Get the total size of all messages on the server
|
||||
my $size = $obj->size;
|
||||
|
||||
This method returns the size of all messages in the server as returned by the
|
||||
last STAT command sent to the server.
|
||||
|
||||
=head2 send - Send a raw command
|
||||
|
||||
# Send a raw command to the server
|
||||
my $ret = $obj->send ("HELO");
|
||||
|
||||
This method sends the specified raw command to the POP server. The one line
|
||||
return from the server is returned. Do not call this method if you are
|
||||
expecting more than a one line response.
|
||||
|
||||
=head2 top - Retrieve the header
|
||||
|
||||
# Get the header of message 2 in an array. New lines are stripped
|
||||
my @header = $obj->top (2);
|
||||
|
||||
# Get the header as a string
|
||||
my $header = $obj->top (2);
|
||||
|
||||
Instance method to retrieve the top of an email on the POP server. The only
|
||||
argument should be the message number to retrieve. Returns a scalar containing
|
||||
the header in scalar context and an array, which is the scalar split on
|
||||
\015?\012, in list context.
|
||||
|
||||
=head2 retr - Retrieve an email
|
||||
|
||||
# Get message 3 from the remote server in an array. New lines are stripped
|
||||
my @email = $obj->retr (3);
|
||||
|
||||
# Get it as a string
|
||||
my $email = $obj->retr (3);
|
||||
|
||||
Instance method to retrieve an email from the POP server. The first argument to
|
||||
this method should be the message number to retrieve. The second argument is an
|
||||
optional code ref to call for each line of the message that is retrieved. If no
|
||||
code ref is specified, this method will put the email in a scalar and return
|
||||
the scalar in scalar context and return the scalar split on \015?\012 in list
|
||||
context.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
L<GT::Socket::Client>
|
||||
L<GT::Base>
|
||||
L<GT::MD5> (for APOP authentication)
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: POP3.pm,v 1.57 2008/09/23 23:55:26 brewt Exp $
|
||||
|
||||
831
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Parse.pm
Normal file
831
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Parse.pm
Normal file
@ -0,0 +1,831 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Parse
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Parse.pm,v 1.90 2008/10/29 23:32:07 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::Mail::Parse;
|
||||
# =============================================================================
|
||||
# If MIME::Base64 is installed use it - must eval before hand or 5.004_04 wipes
|
||||
# our ISA.
|
||||
my $have_b64 = eval {
|
||||
local $SIG{__DIE__};
|
||||
require MIME::Base64;
|
||||
import MIME::Base64;
|
||||
if ($] < 5.005) { local $^W; decode_base64('brok'); }
|
||||
1;
|
||||
};
|
||||
$have_b64 or *decode_base64 = \>_old_decode_base64;
|
||||
my $use_decode_qp;
|
||||
if ($have_b64 and
|
||||
$MIME::Base64::VERSION ge 2.16 and # Prior versions had decoding bugs
|
||||
defined &MIME::QuotedPrint::decode_qp and (
|
||||
not defined &MIME::QuotedPrint::old_decode_qp or
|
||||
\&MIME::QuotedPrint::decode_qp != \&MIME::QuotedPrint::old_decode_qp
|
||||
)
|
||||
) {
|
||||
$use_decode_qp = 1;
|
||||
}
|
||||
|
||||
# Pragmas
|
||||
use strict;
|
||||
use vars qw($VERSION $DEBUG $ERRORS @ISA);
|
||||
|
||||
# System modules
|
||||
use Fcntl;
|
||||
|
||||
# Internal modules
|
||||
use GT::Mail::Parts;
|
||||
use GT::Base;
|
||||
|
||||
# Inherent from GT::Base for errors and debug
|
||||
@ISA = qw(GT::Base);
|
||||
|
||||
# Debugging mode
|
||||
$DEBUG = 0;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.90 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
# Error messages
|
||||
$ERRORS = {
|
||||
PARSE => "An error occurred while parsing: %s",
|
||||
DECODE => "An error occurred while decoding: %s",
|
||||
NOPARTS => "Email has no parts!",
|
||||
DEEPPARTS => "Deep recursion dected, email appears to have more than 50 parts!",
|
||||
MALFORMED => "Found (%s) before finding the start of the boundary. Message malformed"
|
||||
};
|
||||
|
||||
my %DecoderFor = (
|
||||
# Standard...
|
||||
'7bit' => 'NBit',
|
||||
'8bit' => 'NBit',
|
||||
'base64' => 'Base64',
|
||||
'binary' => 'Binary',
|
||||
'none' => 'Binary',
|
||||
'quoted-printable' => 'QuotedPrint',
|
||||
|
||||
# Non-standard...
|
||||
'x-uu' => 'UU',
|
||||
'x-uuencode' => 'UU',
|
||||
);
|
||||
|
||||
sub new {
|
||||
# --------------------------------------------------------------------------
|
||||
# CLASS->new (
|
||||
# naming => \&naming,
|
||||
# in_file => '/path/to/file/to/parse',
|
||||
# handle => \*FH
|
||||
# );
|
||||
# ----------------------------------------------
|
||||
# Class method to get a new object. Calles init if there are any additional
|
||||
# argument. To set the arguments that are passed to naming call naming
|
||||
# directly.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {
|
||||
file_handle => undef,
|
||||
parts => [],
|
||||
head_part => undef,
|
||||
headers_intact => 1,
|
||||
_debug => $DEBUG,
|
||||
eol => "\012"
|
||||
}, $class;
|
||||
$self->init(@_) if @_;
|
||||
$self->debug("Created new object ($self).") if $self->{_debug} > 1;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub init {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->init (%opts);
|
||||
# -------------------
|
||||
# Sets the options for the current object.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift }
|
||||
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
|
||||
else { return $self->error("BADARGS", "FATAL", "init") }
|
||||
|
||||
$self->{_debug} = exists($opt->{debug}) ? $opt->{debug} : $DEBUG;
|
||||
$self->{headers_intact} = exists($opt->{headers_intact}) ? $opt->{headers_intact} : 1;
|
||||
for my $m (qw(crlf in_file in_handle in_string attach_rfc822)) {
|
||||
$self->$m($opt->{$m}) if defined $opt->{$m};
|
||||
}
|
||||
}
|
||||
|
||||
sub attach_rfc822 {
|
||||
# --------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{attach_rfc822} = shift;
|
||||
}
|
||||
return $self->{attach_rfc822};
|
||||
}
|
||||
|
||||
sub crlf {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Sets the end-of-line character sequence to use when parsing. This defaults
|
||||
# to \012 (\n); you'll likely want to use \015\012 at times (for example, when
|
||||
# parsing mail downloaded from a POP3 server). This is set on a per-parser
|
||||
# basis (it used to be global, but that was significantly broken).
|
||||
#
|
||||
my ($self, $eol) = @_;
|
||||
$self->{eol} = $eol;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
# --------------------------------------------------------------------------
|
||||
# my $top = $obj->parse;
|
||||
# ----------------------
|
||||
# Parses the email set in new or init. Also calls init if there are any
|
||||
# arguments passed in.
|
||||
# Returns the top level part object.
|
||||
#
|
||||
my ($self, @opts) = @_;
|
||||
|
||||
# Any additional arguments goto init
|
||||
$self->init(@opts) if @opts;
|
||||
|
||||
($self->{string} and ref($self->{string}) eq 'SCALAR')
|
||||
or return $self->error('BADARGS', 'FATAL', "No input was given to parse before parse() was called");
|
||||
|
||||
# Recursive function to parse
|
||||
$self->_parse_part(undef, $self->{string}); # parse!
|
||||
|
||||
# Return top part
|
||||
return $self->{head_part};
|
||||
}
|
||||
|
||||
sub parse_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# my $head = $obj->parse_head;
|
||||
# ----------------------------
|
||||
# Passes any additional arguments to init. Parses only the top level header.
|
||||
# This saves some overhead if for example all you need to do it find out who
|
||||
# an email is to on a POP3 server.
|
||||
#
|
||||
my ($self, $in, @opts) = @_;
|
||||
|
||||
unless (ref $self) {
|
||||
$self = $self->new(@opts);
|
||||
}
|
||||
|
||||
$in ||= $self->{string};
|
||||
$in || return $self->error("BADARGS", "FATAL", "No string to parse set!");
|
||||
|
||||
# Parse the head
|
||||
return $self->_parse_head($in);
|
||||
}
|
||||
|
||||
#--------------------------------------------
|
||||
# Access
|
||||
#--------------------------------------------
|
||||
|
||||
|
||||
sub in_handle {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->in_handle (\*FH);
|
||||
# --------------------
|
||||
# Pass in a file handle to parse from when parse is called.
|
||||
#
|
||||
my ($self, $value) = @_;
|
||||
if (@_ > 1 and ref $value and defined fileno $value) {
|
||||
read $value, ${$self->{string}}, -s $value;
|
||||
}
|
||||
return $self->{string};
|
||||
}
|
||||
|
||||
sub in_file {
|
||||
# --------------------------------------------------------------------------
|
||||
# $obj->in_file ('/path/to/file');
|
||||
# --------------------------------
|
||||
# Pass in the path to a file to parse when parse is called
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = shift;
|
||||
my $io = \do { local *FH; *FH };
|
||||
open $io, "<$file" or return $self->error("READOPEN", "FATAL", $file, $!);
|
||||
return $self->in_handle($io);
|
||||
}
|
||||
|
||||
sub in_string {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $string) = @_;
|
||||
return $self->{string} unless (@_ > 1);
|
||||
if (ref($string) eq 'SCALAR') {
|
||||
$self->{string} = $string;
|
||||
}
|
||||
else {
|
||||
$self->{string} = \$string;
|
||||
}
|
||||
return $self->{string};
|
||||
}
|
||||
|
||||
sub size {
|
||||
# --------------------------------------------------------------------------
|
||||
# my $email_size = $obj->size;
|
||||
# ----------------------------
|
||||
# Returns the total size of an email. Call this method after the email has
|
||||
# been parsed.
|
||||
#
|
||||
my $self = shift;
|
||||
(@{$self->{parts}} > 0) or return $self->error("NOPARTS", "WARN");
|
||||
my $size = 0;
|
||||
foreach (@{$self->{parts}}) {
|
||||
$size += $_->size;
|
||||
}
|
||||
return $size;
|
||||
}
|
||||
|
||||
sub all_parts {
|
||||
# --------------------------------------------------------------------------
|
||||
# my @parts = $obj->all_parts;
|
||||
# ----------------------------
|
||||
# Returns a list of all the part object for the current parsed email. If the
|
||||
# email is not multipart this will be just the header part.
|
||||
#
|
||||
return @{shift()->{parts}}
|
||||
}
|
||||
|
||||
sub top_part {
|
||||
# --------------------------------------------------------------------------
|
||||
return ${shift()->{parts}}[0];
|
||||
}
|
||||
|
||||
#---------------------------------------------
|
||||
# Internal Methods
|
||||
#---------------------------------------------
|
||||
|
||||
sub _parse_head {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parse just the head. Returns the part object.
|
||||
#
|
||||
my ($self, $in) = @_;
|
||||
|
||||
# Get a new part object
|
||||
my $part = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
|
||||
|
||||
if (ref $in eq 'ARRAY') {
|
||||
$part->extract($in) or return $self->error("PARSE", "WARN", "Couldn't parse head!");
|
||||
return $part;
|
||||
}
|
||||
$part->extract([map "$_$self->{eol}", split /\Q$self->{eol}/, $$in]) or return $self->error($GT::Mail::Parts::error, 'WARN');
|
||||
return $part;
|
||||
}
|
||||
|
||||
sub _parse_part {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses all the parts of an email and stores them in there parts object.
|
||||
# This function is recursive.
|
||||
#
|
||||
my ($self, $outer_bound, $in, $part) = @_;
|
||||
my $state = 'OK';
|
||||
|
||||
# First part is going to be the top level part
|
||||
if (!$part) {
|
||||
$part = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
|
||||
$self->{head_part} = $part;
|
||||
}
|
||||
push @{$self->{parts}}, $part;
|
||||
|
||||
# Get the header for this part
|
||||
=for comment
|
||||
According to rfc2045 and rfc2046, the MIME part headers are optional, so for
|
||||
parsing out the headers, we have the following cases:
|
||||
|
||||
1) no headers, no body
|
||||
EOL--boundary
|
||||
|
||||
2) no headers, body
|
||||
EOLbodyEOL--boundary
|
||||
|
||||
3) headers, no body
|
||||
headers[EOL]EOL--boundary
|
||||
|
||||
4) headers, body
|
||||
headersEOLbodyEOL--boundary
|
||||
|
||||
_parse_to_bound parses everything after the header to EOL--boundary, so this
|
||||
header parsing must be careful not to remove the EOL before the --boundary
|
||||
(cases 1 and 3), or _parse_to_bound will parse more than it should.
|
||||
=cut
|
||||
my $eol_len = length $self->{eol};
|
||||
if (defined $outer_bound and substr($$in, 0, length "$self->{eol}--$outer_bound") eq "$self->{eol}--$outer_bound") {
|
||||
# do nothing
|
||||
}
|
||||
elsif (substr($$in, 0, $eol_len) eq $self->{eol}) {
|
||||
substr($$in, 0, $eol_len) = '';
|
||||
}
|
||||
else {
|
||||
my $indx = index($$in, $self->{eol} x 2);
|
||||
if ($indx == -1) {
|
||||
$self->debug('Message has no body.') if $self->{_debug};
|
||||
$indx = length($$in);
|
||||
}
|
||||
$part->extract([map "$_$self->{eol}", split /\Q$self->{eol}/, substr $$in, 0, $indx]) or return $self->warn($GT::Mail::Parts::error);
|
||||
|
||||
my $trim_len = $eol_len * 2;
|
||||
if (defined $outer_bound) {
|
||||
my $next_bound = "$self->{eol}$self->{eol}--$outer_bound";
|
||||
if (substr($$in, $indx, length $next_bound) eq $next_bound) {
|
||||
$trim_len = $eol_len;
|
||||
}
|
||||
}
|
||||
substr($$in, 0, $indx + $trim_len) = '';
|
||||
}
|
||||
|
||||
# Get the mime type
|
||||
my ($type, $subtype) = split m{/}, $part->mime_type;
|
||||
$type ||= 'text';
|
||||
$subtype ||= 'plain';
|
||||
if ($self->{_debug}) {
|
||||
my $name = $part->recommended_filename || '[unnamed]';
|
||||
$self->debug("Type is '$type/$subtype' ($name)");
|
||||
}
|
||||
|
||||
# Deal with the multipart type with some recursion
|
||||
if ($type eq 'multipart') {
|
||||
my $retype = (($subtype eq 'digest') ? 'message/rfc822' : '');
|
||||
|
||||
# Find the multipart boundary
|
||||
my $inner_bound = $part->multipart_boundary;
|
||||
$self->debug("Boundary is $inner_bound") if $self->{_debug} > 1;
|
||||
defined $inner_bound or return $self->error("PARSE", "WARN", "No multipart boundary in multipart message.");
|
||||
index($inner_bound, $self->{eol}) == -1 or return $self->error("PARSE", "WARN", "End-of-line character in multipart boundary.");
|
||||
|
||||
# Parse the Preamble
|
||||
$self->debug("Parsing preamble.") if $self->{_debug} > 1;
|
||||
$state = $self->_parse_preamble($inner_bound, $in, $part) or return;
|
||||
chomp($part->preamble->[-1]) if @{$part->preamble};
|
||||
|
||||
# Get all the parts of the multipart message
|
||||
my $partno = 0;
|
||||
my $parts;
|
||||
while (1) {
|
||||
++$partno < 200 or return $self->error('DEEPPARTS', 'WARN');
|
||||
$self->debug("Parsing part $partno.") if $self->{_debug};
|
||||
|
||||
($parts, $state) = $self->_parse_part($inner_bound, $in, GT::Mail::Parts->new(headers_intact => $self->{headers_intact})) or return;
|
||||
|
||||
$parts->mime_type($retype) if $retype;
|
||||
push(@{$part->{parts}}, $parts);
|
||||
|
||||
if ($state eq 'EOF') {
|
||||
$self->warn(PARSE => 'Unexpected EOF before close.');
|
||||
return ($part, 'EOF');
|
||||
}
|
||||
|
||||
last if $state eq 'CLOSE';
|
||||
}
|
||||
|
||||
# Parse the epilogue
|
||||
$self->debug("Parsing epilogue.") if $self->{_debug} > 1;
|
||||
$state = $self->_parse_epilogue($outer_bound, $in, $part) or return;
|
||||
chomp($part->epilogue->[-1]) if @{$part->epilogue} and $state ne 'EOF';
|
||||
}
|
||||
|
||||
# We are on a single part
|
||||
else {
|
||||
$self->debug("Decoding single part.") if $self->{_debug} > 1;
|
||||
|
||||
# Find the encoding for the body of the part
|
||||
my $encoding = $part->mime_encoding || 'binary';
|
||||
if (!exists($DecoderFor{lc($encoding)})) {
|
||||
$self->debug("Unsupported encoding '$encoding': using 'binary'... \n" .
|
||||
"The entity will have an effective MIME type of \n" .
|
||||
"application/octet-stream, as per RFC-2045.")
|
||||
if $self->{_debug};
|
||||
$part->effective_type('application/octet-stream');
|
||||
$encoding = 'binary';
|
||||
}
|
||||
my $reparse;
|
||||
$reparse = ("$type/$subtype" eq "message/rfc822") unless $self->{attach_rfc822};
|
||||
my $encoded = "";
|
||||
|
||||
# If we have boundaries we parse the body to the boundary
|
||||
if (defined $outer_bound) {
|
||||
$self->debug("Parsing to boundary.") if $self->{_debug} > 1;
|
||||
$state = $self->_parse_to_bound($outer_bound, $in, \$encoded) or return;
|
||||
}
|
||||
# Else we would parse the rest of the input stream as the rest of the message
|
||||
else {
|
||||
$self->debug("No Boundries.") if $self->{_debug} > 1;
|
||||
$encoded = $$in;
|
||||
$state = 'EOF';
|
||||
}
|
||||
|
||||
# Normal part so we get the body and decode it.
|
||||
if (!$reparse) {
|
||||
$self->debug("Not reparsing.") if $self->{_debug} > 1;
|
||||
$part->{body_in} = 'MEMORY';
|
||||
|
||||
my $decoder = $DecoderFor{lc($encoding)};
|
||||
$self->debug("Decoding part using: " . lc($encoding)) if $self->{_debug};
|
||||
$part->{data} = '';
|
||||
my $out = '';
|
||||
my $res = $self->$decoder(\$encoded, \$out);
|
||||
undef $encoded;
|
||||
$res or return;
|
||||
$part->{data} = $out;
|
||||
undef $out;
|
||||
}
|
||||
else {
|
||||
# If have an embeded email we reparse it.
|
||||
$self->debug("Reparsing enclosed message.") if $self->{_debug};
|
||||
my $out = '';
|
||||
|
||||
my $decoder = $DecoderFor{lc($encoding)};
|
||||
$self->debug("Decoding " . lc($encoding)) if $self->{_debug};
|
||||
my $res = $self->$decoder(\$encoded, \$out);
|
||||
undef $encoded;
|
||||
$res or return;
|
||||
my $p = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
|
||||
push @{$part->{parts}}, $p;
|
||||
$self->_parse_part(undef, \$out, $p) or return;
|
||||
}
|
||||
}
|
||||
return ($part, $state);
|
||||
}
|
||||
|
||||
sub _parse_to_bound {
|
||||
# --------------------------------------------------------------------------
|
||||
# This method takes a boundary ($bound), an input string ref ($in), and an
|
||||
# output string ref ($out). It will place into $$out the data contained by
|
||||
# $bound, and remove the entire region (including boundary) from $$in.
|
||||
#
|
||||
my ($self, $bound, $in, $out) = @_;
|
||||
|
||||
# Set up strings for faster checking:
|
||||
$self->debug("Parsing bounds. Skip until\n\tdelim (--$bound)\n\tclose (--$bound--)") if $self->{_debug} > 1;
|
||||
my $ret;
|
||||
|
||||
# Various shortcut variables - 'e' is eol, 'd' is delimiter, 'c' is closing delimiter:
|
||||
my ($ede, $de, $ece, $ec, $ce) = (
|
||||
"$self->{eol}--$bound$self->{eol}",
|
||||
"--$bound$self->{eol}",
|
||||
"$self->{eol}--$bound--$self->{eol}",
|
||||
"$self->{eol}--$bound--",
|
||||
"--$bound--$self->{eol}"
|
||||
);
|
||||
|
||||
# Place our part in $$out.
|
||||
$$out = undef;
|
||||
# eoldelimeol found anywhere:
|
||||
if ((my $pos = index $$in, $ede) >= 0) {
|
||||
$$out = substr($$in, 0, $pos);
|
||||
substr($$in, 0, $pos + length $ede) = '';
|
||||
$ret = 'DELIM';
|
||||
}
|
||||
# delimeol at beginning of string:
|
||||
elsif (substr($$in, 0, length $de) eq $de) {
|
||||
substr($$in, 0, length $de) = '';
|
||||
$$out = '';
|
||||
$ret = 'DELIM';
|
||||
}
|
||||
# eolcloseeol found anywhere:
|
||||
elsif (($pos = index($$in, $ece)) >= 0) {
|
||||
# This code could be much more clearly written as:
|
||||
#
|
||||
#$$out = substr($$in, 0, $pos);
|
||||
#substr($$in, 0, $pos + length $ece) = '';
|
||||
#
|
||||
# However, that can cause excessive memory usage in some cases (changed in revision 1.59).
|
||||
|
||||
$$out = $$in;
|
||||
substr($$out, -(length($$out) - $pos)) = '';
|
||||
my $len = $pos + length($ece) - length($$in);
|
||||
$$in = $len == 0 ? '' : substr($$in, $len);
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
# The first eolclose occurs at the end of the string:
|
||||
elsif (index($$in, $ec) == (length($$in) - length($ec))) {
|
||||
$$out = substr($$in, 0, -length($ec));
|
||||
$$in = '';
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
# closeeol at beginning of string:
|
||||
elsif (substr($$in, 0, length $ce) eq $ce) {
|
||||
$$out = '';
|
||||
substr($$in, 0, length $ce) = '';
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
# The only thing in the string is the closing boundary:
|
||||
elsif ($$in eq "--$bound--") {
|
||||
$$out = '';
|
||||
$$in = '';
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
|
||||
if (defined $$out) {
|
||||
return $ret;
|
||||
}
|
||||
else {
|
||||
# Broken e-mail - we hit the end of the message without finding a boundary.
|
||||
# Assume that everything left is the part body.
|
||||
$$out = $$in;
|
||||
$$in = '';
|
||||
return 'EOF';
|
||||
}
|
||||
}
|
||||
|
||||
sub _parse_preamble {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses preamble and sets it in part.
|
||||
#
|
||||
my ($self, $inner_bound, $in, $part) = @_;
|
||||
|
||||
my $delim = "--$inner_bound";
|
||||
|
||||
$self->debug("Parsing preamble. Skip until delim ($delim)") if $self->{_debug} > 1;
|
||||
my @saved;
|
||||
$part->preamble(\@saved);
|
||||
|
||||
my $data;
|
||||
if (substr($$in, 0, length "$delim$self->{eol}") eq "$delim$self->{eol}") {
|
||||
$data = '';
|
||||
substr($$in, 0, length "$delim$self->{eol}") = '';
|
||||
}
|
||||
else {
|
||||
if ((my $pos = index($$in, "$self->{eol}$delim$self->{eol}")) >= 0) {
|
||||
$data = substr($$in, 0, $pos);
|
||||
substr($$in, 0, $pos + length("$self->{eol}$delim$self->{eol}")) = '';
|
||||
}
|
||||
else {
|
||||
return $self->warn(PARSE => "Unable to find opening boundary: $delim\nMessage is probably corrupt.");
|
||||
}
|
||||
}
|
||||
push @saved, split /\Q$self->{eol}/, $data;
|
||||
undef $data;
|
||||
return 'DELIM';
|
||||
}
|
||||
|
||||
sub _parse_epilogue {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses epilogue and sets it in part.
|
||||
#
|
||||
my ($self, $outer_bound, $in, $part) = @_;
|
||||
|
||||
$self->debug("Parsing epilogue.") if $self->{_debug} > 1;
|
||||
$part->epilogue(\my @saved);
|
||||
|
||||
if (defined $outer_bound) {
|
||||
my ($delim, $close) = ("--$outer_bound", "--$outer_bound--");
|
||||
|
||||
$self->debug("Skip until\n\tdelim ($delim)\n\tclose($close)") if $self->{_debug} > 1;
|
||||
|
||||
if ($$in =~ s/(.*?)(?:\A|\Q$self->{eol}\E)\Q$delim$self->{eol}//s) {
|
||||
push @saved, split /\Q$self->{eol}/, $1;
|
||||
$self->debug("Found delim($delim)") if $self->{_debug};
|
||||
return 'DELIM'
|
||||
}
|
||||
elsif ($$in =~ s/(.*?)(?:\A|\Q$self->{eol}\E)\Q$close\E(?:\Z|\Q$self->{eol}\E)//s) {
|
||||
push @saved, split /\Q$self->{eol}/, $1;
|
||||
$self->debug("Found close($close)") if $self->{_debug};
|
||||
return 'CLOSE'
|
||||
}
|
||||
}
|
||||
push @saved, split /\Q$self->{eol}/, $$in;
|
||||
$$in = '';
|
||||
$self->debug("EOF: epilogue is " . length(join '', @saved) . " bytes") if $self->{_debug};
|
||||
return 'EOF';
|
||||
}
|
||||
|
||||
|
||||
sub Base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
|
||||
# Remove any non base64 characters.
|
||||
$$in =~ tr{A-Za-z0-9+/}{}cd;
|
||||
|
||||
# Must pass multiple of 4 to decode_base64. Store any remainder in $rem_str and
|
||||
# pad it with trailing equal signs.
|
||||
my $rem = length($$in) % 4;
|
||||
my ($rem_str);
|
||||
if ($rem) {
|
||||
my $pad = '=' x (4 - $rem);
|
||||
$rem_str = substr($$in, length($$in) - $rem);
|
||||
$rem_str .= $pad;
|
||||
substr($$in, $rem * -1) = '';
|
||||
}
|
||||
|
||||
$$out = decode_base64($$in);
|
||||
if ($rem) {
|
||||
$$out .= decode_base64($rem_str);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub Binary {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
$$out = $$in;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub NBit {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
$$out = $$in;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub QuotedPrint {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
if ($use_decode_qp) {
|
||||
$$out = MIME::QuotedPrint::decode_qp($$in);
|
||||
}
|
||||
else {
|
||||
$$out = $$in;
|
||||
$$out =~ s/\r\n/\n/g; # normalize newlines
|
||||
$$out =~ s/[ \t]+\n/\n/g; # rule #3 (trailing whitespace must be deleted)
|
||||
$$out =~ s/=\n//g; # rule #5 (soft line breaks)
|
||||
$$out =~ s/=([\da-fA-F]{2})/chr hex $1/ge;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub UU {
|
||||
# --------------------------------------------------------------------------
|
||||
my ($self, $in, $out) = @_;
|
||||
my ($mode, $file);
|
||||
|
||||
# Find beginning...
|
||||
while ($$in =~ s/^(.+\Q$self->{eol}\E)//) {
|
||||
local $_ = $1;
|
||||
last if ($mode, $file) = /^begin\s*(\d*)\s*(\S*)/;
|
||||
}
|
||||
return $self->warn("uu decoding: no begin found") if not defined $file;
|
||||
|
||||
# Decode:
|
||||
while ($$in =~ s/^(.+\Q$self->{eol}\E)//) {
|
||||
local $_ = $1;
|
||||
last if /^end/;
|
||||
next if /[a-z]/;
|
||||
next unless int((((ord() - 32) & 077) + 2) / 3) == int(length($_) / 4);
|
||||
$$out .= unpack('u', $_);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub gt_old_decode_base64 {
|
||||
# --------------------------------------------------------------------------
|
||||
my $str = shift;
|
||||
my $res = "";
|
||||
|
||||
$str =~ tr|A-Za-z0-9+=/||cd;
|
||||
|
||||
$str =~ s/=+$//;
|
||||
$str =~ tr|A-Za-z0-9+/| -_|;
|
||||
return "" unless length $str;
|
||||
|
||||
my $uustr = '';
|
||||
my ($i, $l);
|
||||
$l = length($str) - 60;
|
||||
for ($i = 0; $i <= $l; $i += 60) {
|
||||
$uustr .= "M" . substr($str, $i, 60);
|
||||
}
|
||||
$str = substr($str, $i);
|
||||
# and any leftover chars
|
||||
if ($str ne "") {
|
||||
$uustr .= chr(32 + length($str)*3/4) . $str;
|
||||
}
|
||||
return unpack("u", $uustr);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Parse - MIME Parse
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::Parse
|
||||
|
||||
my $parser = new GT::Mail::Parse (
|
||||
naming => \&name_files,
|
||||
in_file => '/path/to/file.eml',
|
||||
debug => 1
|
||||
);
|
||||
|
||||
my $top = $parser->parse or die $GT::Mail::Parse::error;
|
||||
|
||||
- or -
|
||||
|
||||
my $parser = new GT::Mail::Parse;
|
||||
|
||||
open FH, '/path/to/file.eml' or die $!;
|
||||
my $top = $parser->parse (
|
||||
naming => \&name_files,
|
||||
handle => \*FH,
|
||||
debug => 1
|
||||
) or die $GT::Mail::Parse::error;
|
||||
close FH;
|
||||
|
||||
- or -
|
||||
|
||||
my $parser = new GT::Mail::Parse;
|
||||
|
||||
my $top_head = $parser->parse_head (
|
||||
naming => \&name_files,
|
||||
in_file => '/path/to/file.eml',
|
||||
debug => 1
|
||||
) or die $GT::Mail::Parse::error;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Parse is a 100% rfc822 email MIME parser that supports unlimited
|
||||
nested levels of MIME. Emails are parsed into L<GT::Mail::Parts> objects. Each
|
||||
part knows where it's body is and each part contains it's sub parts. See
|
||||
L<GT::Mail::Parts> for details on parts methods.
|
||||
|
||||
=head2 new - Constructor method
|
||||
|
||||
This is the constructor method to get a GT::Mail::Parse object, which you
|
||||
need to access all the methods (there are no Class methods). new() takes
|
||||
a hash or hash ref as it's arguments. Each key has an accessor method by the
|
||||
same name except debug, which can only be set by passing debug to new(), parse()
|
||||
or parse_head().
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debug level for this insance of the class.
|
||||
|
||||
=item naming
|
||||
|
||||
Specify a code reference to use as a naming convention for each part of the
|
||||
email being parsed. This is useful to keep file IO down when you want the emails
|
||||
seperated into each part as a file. If this is not specified GT::Mail::Parse
|
||||
uses a default naming, which is to start at one and incriment that number for each
|
||||
attachment. The attachments would go in the current working directory.
|
||||
|
||||
=item in_file
|
||||
|
||||
Specify the path to the file that contains the email to be parsed. One of in_file
|
||||
and handle must be specified.
|
||||
|
||||
=item handle
|
||||
|
||||
Specify the file handle or IO stream that contains the email to be parsed.
|
||||
|
||||
=item attach_rfc822
|
||||
|
||||
By default, the parser will decode any embeded emails, and flatten out all the
|
||||
parts. If you prefer to leave embeded emails unparsed, pass in 1 to this option
|
||||
and the parser will treat it as an attachment.
|
||||
|
||||
=back
|
||||
|
||||
=head2 parse - Parse an email
|
||||
|
||||
Instance method. Parses the email specified by either in_file or handle. Returns
|
||||
the top level L<GT::Mail::Parts> object. Any additional parameters passed in are
|
||||
treated the same as if they were passed to the constuctor.
|
||||
|
||||
=head2 parse_head - Parse just the header of the email
|
||||
|
||||
Instance method. This method is exactly the same as parse except only the top
|
||||
level header is parsed and it's part object returned. This is useful to keep
|
||||
overhead down if you only need to know about the header of the email.
|
||||
|
||||
=head2 size - Get the size
|
||||
|
||||
Instance method. Returns the total size in bytes of the parsed unencoded email. This
|
||||
method will return undef if no email has been parsed.
|
||||
|
||||
=head2 all_parts - Get all parts
|
||||
|
||||
Instance method. Returns all the parts in the parsed email. This is a flatened
|
||||
list of the objects. Somewhat similar to what MIME::Tools does. All the parts
|
||||
still contain their sub parts.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Parse.pm,v 1.90 2008/10/29 23:32:07 brewt Exp $
|
||||
|
||||
1274
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Parts.pm
Normal file
1274
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Parts.pm
Normal file
File diff suppressed because it is too large
Load Diff
496
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Send.pm
Normal file
496
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Send.pm
Normal file
@ -0,0 +1,496 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Send
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Send.pm,v 1.54 2007/08/01 23:35:16 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
|
||||
package GT::Mail::Send;
|
||||
|
||||
use strict;
|
||||
use GT::Base;
|
||||
use GT::Socket::Client;
|
||||
use GT::Mail::POP3;
|
||||
use GT::MD5;
|
||||
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS $CRLF %SENDMAIL_ERRORS $HAVE_SSL);
|
||||
|
||||
%SENDMAIL_ERRORS = (
|
||||
64 => 'EX_USAGE',
|
||||
65 => 'EX_DATAERR',
|
||||
66 => 'EX_NOINPUT',
|
||||
67 => 'EX_NOUSER',
|
||||
68 => 'EX_NOHOST',
|
||||
69 => 'EX_UNAVAILABLE',
|
||||
70 => 'EX_SOFTWARE',
|
||||
71 => 'EX_OSERR',
|
||||
72 => 'EX_OSFILE',
|
||||
73 => 'EX_CANTCREAT',
|
||||
74 => 'EX_IOERR',
|
||||
75 => 'EX_TEMPFAIL',
|
||||
76 => 'EX_PROTOCOL',
|
||||
77 => 'EX_NOPERM',
|
||||
78 => 'EX_CONFIG',
|
||||
|
||||
# This is for qmail-inject's version of sendmail
|
||||
# Nice that they are different..
|
||||
111 => 'EX_TEMPFAIL',
|
||||
100 => 'EX_USAGE',
|
||||
);
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.54 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ATTRIBS = {
|
||||
mail => undef,
|
||||
host => undef,
|
||||
port => undef,
|
||||
ssl => undef,
|
||||
from => undef,
|
||||
path => undef,
|
||||
flags => undef,
|
||||
rcpt => undef,
|
||||
user => undef,
|
||||
pass => undef,
|
||||
helo => undef,
|
||||
pbs_user => undef,
|
||||
pbs_pass => undef,
|
||||
pbs_host => undef,
|
||||
pbs_port => undef,
|
||||
pbs_auth_mode => undef,
|
||||
pbs_ssl => undef,
|
||||
debug => 0,
|
||||
};
|
||||
$ERRORS = {
|
||||
HOSTNOTFOUND => "SMTP: server '%s' was not found.",
|
||||
CONNFAILED => "SMTP: connect() failed. reason: %s",
|
||||
SERVNOTAVAIL => "SMTP: Service not available: %s",
|
||||
SSLNOTAVAIL => "SMTP: SSL connections are not available: Net::SSLeay 1.06 or greater not installed.",
|
||||
COMMERROR => "SMTP: Unspecified communications error: '%s'.",
|
||||
USERUNKNOWN => "SMTP: Local user '%s' unknown on host '%s'. Server said: %s",
|
||||
TRANSFAILED => "SMTP: Transmission of message failed: %s",
|
||||
AUTHFAILED => "SMTP: Authentication failed: %s",
|
||||
TOEMPTY => "No To: field specified.",
|
||||
NOMSG => "No message body specified",
|
||||
SENDMAILNOTFOUND => "Sendmail was not defined or not found: %s",
|
||||
NOOPTIONS => "No options were specified. Be sure to pass a hash ref to send()",
|
||||
NOTRANSPORT => "Neither sendmail nor SMTP were specified!",
|
||||
SENDMAIL => "There was a problem sending to Sendmail: (%s)",
|
||||
NOMAILOBJ => "No mail object was specified.",
|
||||
EX_USAGE => "Command line usage error",
|
||||
EX_DATAERR => "Data format error",
|
||||
EX_NOINPUT => "Cannot open input",
|
||||
EX_NOUSER => "Addressee unknown",
|
||||
EX_NOHOST => "Host name unknown",
|
||||
EX_UNAVAILABLE => "Service unavailable",
|
||||
EX_SOFTWARE => "Internal software error",
|
||||
EX_OSERR => "System error (e.g., can't fork)",
|
||||
EX_OSFILE => "Critical OS file missing",
|
||||
EX_CANTCREAT => "Can't create (user) output file",
|
||||
EX_IOERR => "Input/output error",
|
||||
EX_TEMPFAIL => "Temp failure; user is invited to retry",
|
||||
EX_PROTOCOL => "Remote error in protocol",
|
||||
EX_NOPERM => "Permission denied",
|
||||
EX_CONFIG => "Configuration error",
|
||||
EX_UNKNOWN => "Sendmail exited with an unknown exit status: %s"
|
||||
};
|
||||
$CRLF = "\015\012";
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->set(@_);
|
||||
|
||||
# We need either a host or a path to sendmail and an email object
|
||||
$self->{host} or $self->{path} or return $self->error("NOTRANSPORT", "FATAL");
|
||||
exists $self->{mail} or return $self->error("NOMAILOBJ", "FATAL");
|
||||
|
||||
# Set debugging
|
||||
$self->{_debug} = defined($self->{debug}) ? $self->{debug} : $DEBUG;
|
||||
|
||||
# Default port for smtp
|
||||
if ($self->{host} and !$self->{port}) {
|
||||
$self->{port} = $self->{ssl} ? 465 : 25;
|
||||
}
|
||||
|
||||
# Default flags for sendmail
|
||||
elsif ($self->{path}) {
|
||||
($self->{flags}) or $self->{flags} = '-t -oi -oeq';
|
||||
$self->{path} =~ /^\s*(.+?)\s*$/ and $self->{path} = $1; # Untaint
|
||||
(-e $self->{path}) or return $self->error('SENDMAILNOTFOUND', 'FATAL', $1);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub smtp_send {
|
||||
# ---------------------------------------------------------------
|
||||
#
|
||||
my ($self, $sock, $cmd) = @_;
|
||||
|
||||
if (defined $cmd) {
|
||||
print $sock "$cmd$CRLF";
|
||||
$self->debug("SMTP Log: >> $cmd\n") if $self->{debug} > 1;
|
||||
}
|
||||
|
||||
$_ = <$sock>;
|
||||
return if !$_;
|
||||
|
||||
my $resp = $_;
|
||||
if (/^\d{3}-/) {
|
||||
while (defined($_ = <$sock>) and /^\d{3}-/) {
|
||||
$resp .= $_;
|
||||
}
|
||||
$resp .= $_;
|
||||
}
|
||||
$resp =~ s/$CRLF/\n/g;
|
||||
$self->debug("SMTP Log: << $resp") if $self->{debug} > 1;
|
||||
return $resp;
|
||||
}
|
||||
|
||||
sub smtp {
|
||||
# ---------------------------------------------------------------
|
||||
# Opens a smtp port and sends the message headers.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
ref $self or $self = $self->new(@_);
|
||||
|
||||
if ($self->{ssl}) {
|
||||
$HAVE_SSL ||= eval { require Net::SSLeay; Net::SSLeay->require_version(1.06); 1 };
|
||||
$HAVE_SSL or return $self->error('SSLNOTAVAIL', 'FATAL');
|
||||
}
|
||||
|
||||
if ($self->{pbs_host}) {
|
||||
my $pop = GT::Mail::POP3->new(
|
||||
host => $self->{pbs_host},
|
||||
port => $self->{pbs_port},
|
||||
user => $self->{pbs_user},
|
||||
pass => $self->{pbs_pass},
|
||||
auth_mode => $self->{pbs_auth_mode},
|
||||
ssl => $self->{pbs_ssl},
|
||||
debug => $self->{debug}
|
||||
);
|
||||
my $count = $pop->connect();
|
||||
if (!defined($count)) {
|
||||
$self->debug("Couldn't connect to server for POP3 before SMTP authentication: $GT::Mail::POP3::error") if $self->{debug};
|
||||
}
|
||||
else {
|
||||
$pop->quit();
|
||||
}
|
||||
}
|
||||
|
||||
my $sock = GT::Socket::Client->open(
|
||||
host => $self->{host},
|
||||
port => $self->{port},
|
||||
ssl => $self->{ssl}
|
||||
) or return $self->error("CONNFAILED", "WARN", GT::Socket::Client->error);
|
||||
|
||||
local $SIG{PIPE} = 'IGNORE';
|
||||
local $_;
|
||||
|
||||
# Get the server's greeting message
|
||||
my $resp = $self->smtp_send($sock) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
# Decide what hostname to use on the HELO/EHLO line
|
||||
my $helo = $self->{helo};
|
||||
$helo ||= $ENV{SERVER_NAME};
|
||||
eval {
|
||||
require Sys::Hostname;
|
||||
$helo = Sys::Hostname::hostname();
|
||||
} unless $helo;
|
||||
$helo ||= $self->{host};
|
||||
|
||||
$resp = $self->smtp_send($sock, "EHLO $helo") or return $self->error('COMMERROR', 'WARN');
|
||||
if ($resp =~ /^[45]/) {
|
||||
$resp = $self->smtp_send($sock, "HELO $helo") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
|
||||
# Authenticate if needed
|
||||
if ($resp =~ /AUTH[ =](.*)/ and $self->{user}) {
|
||||
my $server = uc $1;
|
||||
my $method = '';
|
||||
# These are the authentication types that are supported, ordered by preference
|
||||
for my $m (qw/CRAM-MD5 PLAIN LOGIN/) {
|
||||
if ($server =~ /$m/) {
|
||||
$method = $m;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ($method eq 'CRAM-MD5') {
|
||||
$resp = $self->smtp_send($sock, "AUTH CRAM-MD5") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
my ($challenge) = $resp =~ /\d{3}\s+(.*)/;
|
||||
$challenge = decode_base64($challenge);
|
||||
my $auth = encode_base64("$self->{user} " . hmac_md5_hex($challenge, $self->{pass}));
|
||||
|
||||
$resp = $self->smtp_send($sock, $auth) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
elsif ($method eq 'PLAIN') {
|
||||
my $auth = encode_base64("$self->{user}\0$self->{user}\0$self->{pass}");
|
||||
$resp = $self->smtp_send($sock, "AUTH PLAIN $auth") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
elsif ($method eq 'LOGIN') {
|
||||
$resp = $self->smtp_send($sock, "AUTH LOGIN") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
$resp = $self->smtp_send($sock, encode_base64($self->{user})) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
$resp = $self->smtp_send($sock, encode_base64($self->{pass})) or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
}
|
||||
|
||||
# We use return-path so the email will bounce to who it's from, not the user
|
||||
# doing the sending.
|
||||
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
|
||||
$from = $self->extract_email($from) || '';
|
||||
|
||||
$self->debug("Sending from: <$from>") if $self->{debug} == 1;
|
||||
$resp = $self->smtp_send($sock, "MAIL FROM: <$from>") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
my $found_valid = 0;
|
||||
my @tos = ($self->{mail}->{head}->split_field('to'), $self->{mail}->{head}->split_field('bcc'), $self->{mail}->{head}->split_field('cc'));
|
||||
for my $to (@tos) {
|
||||
next unless $to and my $email = $self->extract_email($to);
|
||||
|
||||
$found_valid++;
|
||||
$self->debug("Sending RCPT TO: <$email>.") if $self->{debug} == 1;
|
||||
$resp = $self->smtp_send($sock, "RCPT TO: <$email>") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('USERUNKNOWN', 'WARN', $email, $self->{host}, $resp) if $resp =~ /^[45]/;
|
||||
}
|
||||
$found_valid or return $self->error('TOEMPTY', 'FATAL');
|
||||
|
||||
$resp = $self->smtp_send($sock, "DATA") or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
# Remove Bcc from the headers.
|
||||
my @bcc = $self->{mail}->{head}->delete('bcc');
|
||||
|
||||
my $mail = $self->{mail}->to_string;
|
||||
|
||||
# SMTP needs any leading .'s to be doubled up.
|
||||
$mail =~ s/^\./../gm;
|
||||
|
||||
# Print the mail body.
|
||||
$resp = $self->smtp_send($sock, $mail . $CRLF . '.') or return $self->error('COMMERROR', 'WARN');
|
||||
return $self->error('TRANSFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
|
||||
|
||||
# Add them back in.
|
||||
foreach my $bcc (@bcc) {
|
||||
$self->{mail}->{head}->set('bcc', $bcc);
|
||||
}
|
||||
|
||||
# Close the connection.
|
||||
$resp = $self->smtp_send($sock, "QUIT") or return $self->error('COMMERROR', 'WARN');
|
||||
close $sock;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub sendmail {
|
||||
# ---------------------------------------------------------------
|
||||
# Sends a message using sendmail.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
ref $self or $self = $self->new(@_);
|
||||
|
||||
# Get a filehandle, and open pipe to sendmail.
|
||||
my $s = \do{ local *FH; *FH };
|
||||
|
||||
# If the email address is safe, we set the envelope via -f so bounces are handled properly.
|
||||
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
|
||||
my $envelope = '';
|
||||
if ($from =~ /<?([\w\-\.]+\@[\w\-\.]+)>?/) {
|
||||
$envelope = "-f $1";
|
||||
}
|
||||
elsif ($from eq '<>' or $from eq '') {
|
||||
$envelope = "-f ''";
|
||||
}
|
||||
open($s, "|$self->{path} $self->{flags} $envelope 1>&2") or return $self->error("SENDMAIL", "WARN", "$!");
|
||||
$self->{mail}->write($s);
|
||||
return 1 if close $s;
|
||||
my $exit_value = $? >> 8;
|
||||
|
||||
my $code;
|
||||
if (exists $SENDMAIL_ERRORS{$exit_value}) {
|
||||
$code = $SENDMAIL_ERRORS{$exit_value};
|
||||
}
|
||||
else {
|
||||
$code = 'EX_UNKNOWN';
|
||||
}
|
||||
if ($code eq 'EX_TEMPFAIL') {
|
||||
return 1;
|
||||
}
|
||||
return $self->error($code, "WARN", $exit_value);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub extract_email {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes a field, returns the e-mail address contained in that field, or undef
|
||||
# if no e-mail address could be found.
|
||||
#
|
||||
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
|
||||
my $to = shift;
|
||||
|
||||
# We're trying to get down to the actual e-mail address. To do so, we have to
|
||||
# remove quoted strings and comments, then extract the e-mail from whatever is
|
||||
# left over.
|
||||
$to =~ s/"(?:[^"\\]|\\.)*"//g;
|
||||
1 while $to =~ s/\((?:[^()\\]|\\.)*\)//sg;
|
||||
|
||||
my ($email) = $to =~ /([^<>\s]+\@[\w.-]+)/;
|
||||
|
||||
return $email;
|
||||
}
|
||||
|
||||
sub encode_base64 {
|
||||
my $res = '';
|
||||
pos($_[0]) = 0; # In case something has previously adjusted pos
|
||||
while ($_[0] =~ /(.{1,45})/gs) {
|
||||
$res .= substr(pack(u => $1), 1, -1);
|
||||
}
|
||||
$res =~ tr|` -_|AA-Za-z0-9+/|;
|
||||
|
||||
my $padding = (3 - length($_[0]) % 3) % 3;
|
||||
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
|
||||
$res;
|
||||
}
|
||||
|
||||
sub decode_base64 {
|
||||
my $str = shift;
|
||||
my $res = '';
|
||||
|
||||
$str =~ tr|A-Za-z0-9+=/||cd;
|
||||
|
||||
$str =~ s/=+$//;
|
||||
$str =~ tr|A-Za-z0-9+/| -_|;
|
||||
return '' unless length $str;
|
||||
|
||||
my $uustr = '';
|
||||
my ($i, $l);
|
||||
$l = length($str) - 60;
|
||||
for ($i = 0; $i <= $l; $i += 60) {
|
||||
$uustr .= "M" . substr($str, $i, 60);
|
||||
}
|
||||
$str = substr($str, $i);
|
||||
# and any leftover chars
|
||||
if ($str ne "") {
|
||||
$uustr .= chr(32 + length($str) * 3 / 4) . $str;
|
||||
}
|
||||
return unpack("u", $uustr);
|
||||
}
|
||||
|
||||
sub hmac_md5_hex {
|
||||
my ($challenge, $data) = @_;
|
||||
|
||||
GT::MD5::md5($challenge) if length $challenge > 64;
|
||||
|
||||
my $ipad = $data ^ (chr(0x36) x 64);
|
||||
my $opad = $data ^ (chr(0x5c) x 64);
|
||||
|
||||
return GT::MD5::md5_hex($opad, GT::MD5::md5($ipad, $challenge));
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Mail::Send - Module to send emails
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Mail::Send;
|
||||
|
||||
# $mail_object must be a GT::Mail object
|
||||
my $send = new GT::Mail::Send (
|
||||
mail => $mail_object,
|
||||
host => 'smtp.gossamer-threads.com',
|
||||
debug => 1
|
||||
);
|
||||
|
||||
$send->smtp or die $GT::Mail::Send::error;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::Mail::Send is an object interface to sending email over either
|
||||
SMTP or Sendmail. This module is used internally to GT::Mail.
|
||||
|
||||
=head2 new - Constructor method
|
||||
|
||||
Returns a new GT::Mail::Send object. You must specify either the smtp host
|
||||
or a path to sendmail. This method is inherented from GT::Base. The arguments
|
||||
can be in the form of a hash or hash ref.
|
||||
|
||||
=over 4
|
||||
|
||||
=item debug
|
||||
|
||||
Sets the debug level for this instance of GT::Mail::Send.
|
||||
|
||||
=item mail
|
||||
|
||||
Specify the mail object to use. This must be a GT::Mail object and must contain
|
||||
an email, either passed in or parsed in.
|
||||
|
||||
=item host
|
||||
|
||||
Specify the host to use when sending by SMTP.
|
||||
|
||||
=item port
|
||||
|
||||
Specify the port to use when sending over SMTP. Defaults to 25.
|
||||
|
||||
=item helo
|
||||
|
||||
The hostname to output on the HELO/EHLO line on an SMTP connection. Defaults to
|
||||
$ENV{SERVER_NAME} or the system hostname (if Sys::Hostname is available).
|
||||
|
||||
=item path
|
||||
|
||||
Specify the path to sendmail when sending over sendmail. If the binary passed in
|
||||
does not exist, undef will be returned and the error set in GT::Mail::Send::error.
|
||||
|
||||
=item flags
|
||||
|
||||
Specify the flags used to call sendmail. Defaults to -t -oi -oeq, see the Sendmail
|
||||
guilde for sendmail for more info on the parameters to sendmail.
|
||||
|
||||
=back
|
||||
|
||||
=head2 smtp
|
||||
|
||||
Class or instance method. Sends the passed in email over SMTP. If called as a class
|
||||
method, the parameters passed in will be used to call new(). Returns true on error,
|
||||
false otherwise.
|
||||
|
||||
=head2 sendmail
|
||||
|
||||
Class or instance method. Send the passed in email to sendmail using the specified
|
||||
path and flags. If called as a class method all additional arguments are passed to the
|
||||
new() method. Returns true on success and false otherwise.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Send.pm,v 1.54 2007/08/01 23:35:16 brewt Exp $
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
282
site/slowtwitch.com/cgi-bin/articles/GT/Maildir.pm
Normal file
282
site/slowtwitch.com/cgi-bin/articles/GT/Maildir.pm
Normal file
@ -0,0 +1,282 @@
|
||||
package GT::Maildir;
|
||||
|
||||
use vars qw/$error $ERRORS @EXPORT @EXPORT_OK %EXPORT_TAGS/;
|
||||
use strict;
|
||||
use warnings;
|
||||
use base 'GT::Base';
|
||||
|
||||
sub ST_DEV() { 0 }
|
||||
sub ST_INO() { 1 }
|
||||
sub ST_MODE() { 2 }
|
||||
sub ST_NLINK() { 3 }
|
||||
sub ST_UID() { 4 }
|
||||
sub ST_GID() { 5 }
|
||||
sub ST_RDEV() { 6 }
|
||||
sub ST_SIZE() { 7 }
|
||||
sub ST_ATIME() { 8 }
|
||||
sub ST_MTIME() { 9 }
|
||||
sub ST_CTIME() { 10 }
|
||||
sub ST_BLKSIZE() { 11 }
|
||||
sub ST_BLOCKS() { 12 }
|
||||
|
||||
sub ST_NEW () { 1 }
|
||||
sub ST_CUR () { 2 }
|
||||
|
||||
eval {
|
||||
require Time::HiRes;
|
||||
Time::HiRes->import;
|
||||
};
|
||||
use Cwd;
|
||||
use Sys::Hostname;
|
||||
use Carp qw/croak/;
|
||||
use Exporter();
|
||||
|
||||
sub MAILDIR_DELIVERY_TIMEOUT() { 60 * 30 } # 30 minutes
|
||||
|
||||
$ERRORS = {
|
||||
CHDIR => 'Could not chdir to %s: %s',
|
||||
MKTMPFILE => 'Race condition creating tmp file for delivery to %s',
|
||||
FILE_MISSING => "Wrote maildir tmp file but now it's gone; Possible file system troubles",
|
||||
LINK => "Failed to link %s to %s: %s",
|
||||
OVERQUOTA => "User is over thier maildir quota",
|
||||
TIMEOUT => "Timed out on maildir delivery"
|
||||
};
|
||||
|
||||
*import = \&Exporter::import;
|
||||
$error = '';
|
||||
|
||||
@EXPORT = ();
|
||||
@EXPORT_OK = qw(
|
||||
ST_NEW
|
||||
ST_CUR
|
||||
st_to_string
|
||||
|
||||
ST_DEV
|
||||
ST_INO
|
||||
ST_MODE
|
||||
ST_NLINK
|
||||
ST_UID
|
||||
ST_GID
|
||||
ST_RDEV
|
||||
ST_SIZE
|
||||
ST_ATIME
|
||||
ST_MTIME
|
||||
ST_CTIME
|
||||
ST_BLKSIZE
|
||||
ST_BLOCKS
|
||||
);
|
||||
%EXPORT_TAGS = (
|
||||
all => [@EXPORT_OK, @EXPORT],
|
||||
stat => [qw/
|
||||
ST_DEV
|
||||
ST_INO
|
||||
ST_MODE
|
||||
ST_NLINK
|
||||
ST_UID
|
||||
ST_GID
|
||||
ST_RDEV
|
||||
ST_SIZE
|
||||
ST_ATIME
|
||||
ST_MTIME
|
||||
ST_CTIME
|
||||
ST_BLKSIZE
|
||||
ST_BLOCKS
|
||||
/],
|
||||
status => [qw(ST_NEW ST_CUR st_to_string)]
|
||||
);
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
|
||||
croak "Invalid arguments to $class->new. Arguments must be key/value pairs" if @_ & 1;
|
||||
my %opts = @_;
|
||||
$opts{ lc $_ } = delete $opts{$_} for keys %opts;
|
||||
|
||||
croak "No Path specified to $class->new" unless exists $opts{path};
|
||||
my $path = delete $opts{path};
|
||||
croak "Invalid maildir path specified to $class->new" unless defined $path and length $path;
|
||||
my $locker = delete $opts{locker};
|
||||
unless ($locker) {
|
||||
require GT::Maildir::Lock::NFSLock;
|
||||
$locker = GT::Maildir::Lock::NFSLock->new;
|
||||
}
|
||||
my $subdir = delete $opts{subdir};
|
||||
my $maildir_subdir = delete $opts{maildirsubdir};
|
||||
|
||||
$self->{_debug} = exists $opts{debug} ? delete $opts{debug} : $GT::Maildir::DEBUG;
|
||||
|
||||
croak "Unknown arguments to $class->new: ", join(", ", keys %opts) if keys %opts;
|
||||
|
||||
$self->{path} = $path;
|
||||
$self->{maildir_subdir} = $maildir_subdir || 'Maildir';
|
||||
$self->{subdir} = $subdir || 'gt';
|
||||
$self->{locker} = $locker;
|
||||
}
|
||||
|
||||
sub st_to_string {
|
||||
my $st = shift;
|
||||
return $st == ST_NEW ? "new" : "cur";
|
||||
}
|
||||
|
||||
sub make_maildir_root {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->make_maildir: ", join(", ", @_) if @_;
|
||||
my $path = $self->get_maildir_path;
|
||||
my $config_path = $self->get_config_path;
|
||||
$self->get_locker->ex_lock($path, 60*5, 60*20);
|
||||
unless (-d $path) {
|
||||
unlink $path;
|
||||
mkdir $path, 0700 or return $self->error("MKDIR", "WARN", $path, "$!");
|
||||
}
|
||||
for (qw(cur new tmp)) {
|
||||
unless (-d "$path/$_") {
|
||||
unlink "$path/$_";
|
||||
mkdir "$path/$_", 0700 or return $self->error("MKDIR", "WARN", "$path/$_", "$!");
|
||||
}
|
||||
}
|
||||
unless (-d $config_path) {
|
||||
unlink $config_path;
|
||||
mkdir $config_path, 0700 or return $self->error("MKDIR", "WARN", $path, "$!");
|
||||
}
|
||||
$self->get_locker->unlock($path);
|
||||
return 1;
|
||||
}
|
||||
|
||||
my $Maildir_Message_Number = 0;
|
||||
sub deliver_message {
|
||||
my $self = shift;
|
||||
my $folder = shift;
|
||||
my $folder_name = UNIVERSAL::isa($folder, "GT::Maildir::Folder")
|
||||
? $folder->get_name
|
||||
: $folder;
|
||||
croak "Invalid folder $folder_name"
|
||||
unless !ref($folder_name)
|
||||
and defined $folder_name
|
||||
and length $folder_name;
|
||||
my $mail_thingy = shift;
|
||||
my $mail_writer = UNIVERSAL::isa($mail_thingy, "GT::Mail")
|
||||
? sub { $mail_thingy->write(shift) or die "$GT::Mail::error" }
|
||||
: (!ref($mail_thingy) and -e $mail_thingy)
|
||||
? sub { require GT::File::Tools; GT::File::Tools::copy($mail_thingy, shift) or die "$GT::File::Tools::error" }
|
||||
: undef;
|
||||
croak "Unknown email input $mail_thingy" unless defined $mail_writer;
|
||||
my $quotastr = shift;
|
||||
|
||||
my $flags = join '', map { uc substr($_, 0, 1) } grep { defined and /^[DFRST]/i } @_;
|
||||
|
||||
my $path = $self->get_maildir_path;
|
||||
my $folder_path = "$path/$folder_name";
|
||||
my $cwd = getcwd || cwd || die "Could not get cwd";
|
||||
unless (ref $mail_thingy) {
|
||||
if ($mail_thingy !~ m{^/}) {
|
||||
$mail_thingy = "$cwd/$mail_thingy";
|
||||
}
|
||||
}
|
||||
chdir $folder_path or return $self->error("CHDIR", "WARN", $folder_path, "$!");
|
||||
local $@;
|
||||
eval {
|
||||
local $SIG{__DIE__};
|
||||
alarm 0;
|
||||
};
|
||||
my $can_alarm = $@ ? 0 : 1;
|
||||
local $SIG{ALRM} = sub { die "TIMEOUT\n" };
|
||||
my $pid = $$;
|
||||
my $host = hostname;
|
||||
$Maildir_Message_Number++;
|
||||
|
||||
my $tmpfile;
|
||||
for (my $i = 0; ; $i++) {
|
||||
my $t = time;
|
||||
$tmpfile = "tmp/$t.$pid.$Maildir_Message_Number.$host";
|
||||
if (!stat($tmpfile) and $! == 2) { # ENOENT
|
||||
last;
|
||||
}
|
||||
if ($i == 2) {
|
||||
return $self->error("MKTMPFILE", "WARN", "$folder_path/$tmpfile");
|
||||
}
|
||||
sleep 2;
|
||||
}
|
||||
if ($can_alarm) {
|
||||
alarm(MAILDIR_DELIVERY_TIMEOUT);
|
||||
}
|
||||
my $newfile;
|
||||
eval {
|
||||
$mail_writer->($tmpfile);
|
||||
undef $mail_thingy;
|
||||
undef $mail_writer;
|
||||
my @st = stat $tmpfile;
|
||||
die "FILE_MISSING\n" unless @st;
|
||||
if ($st[ST_SIZE] != 0 and $quotastr and $quotastr ne "NOQUOTA") {
|
||||
require GT::Maildir::Quota;
|
||||
my $q = GT::Maildir::Quota->open(".", $quotastr) or die "$GT::Maildir::Quota::error\n";
|
||||
if (!$q->test($st[ST_SIZE], 1)) {
|
||||
die "$GT::Maildir::Quota::error\n" if $GT::Maildir::Quota::error;
|
||||
die "OVERQUOTA\n";
|
||||
}
|
||||
$q->add($st[ST_SIZE], 1);
|
||||
$q->close();
|
||||
}
|
||||
my $new_tmp = "$tmpfile,S=$st[ST_SIZE]:2,$flags";
|
||||
if (!rename($tmpfile, $new_tmp)) {
|
||||
$self->error("RENAME", "FATAL", $tmpfile, $new_tmp, "$!");
|
||||
}
|
||||
$newfile = $new_tmp;
|
||||
$newfile =~ s/tmp/new/;
|
||||
|
||||
if (!link($new_tmp, $newfile)) {
|
||||
$self->error("LINK", "FATAL", $new_tmp, $newfile, "$!");
|
||||
}
|
||||
unlink $new_tmp;
|
||||
};
|
||||
if ($can_alarm) {
|
||||
alarm 0;
|
||||
}
|
||||
if ($@) {
|
||||
my $err = $@;
|
||||
$err =~ s/\n//g;
|
||||
chdir $cwd;
|
||||
return $self->error($err, "WARN");
|
||||
}
|
||||
chdir $cwd;
|
||||
return $newfile;
|
||||
}
|
||||
|
||||
sub get_locker {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_locker: ", join(", ", @_) if @_;
|
||||
return $self->{locker};
|
||||
}
|
||||
|
||||
sub get_path {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_path: ", join(", ", @_) if @_;
|
||||
return $self->{path};
|
||||
}
|
||||
|
||||
sub get_subdir {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_subdir: ", join(", ", @_) if @_;
|
||||
return $self->{subdir};
|
||||
}
|
||||
|
||||
sub get_maildir_subdir {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_maildir_subdir: ", join(", ", @_) if @_;
|
||||
return $self->{maildir_subdir};
|
||||
}
|
||||
|
||||
sub get_maildir_path {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_subdir: ", join(", ", @_) if @_;
|
||||
return $self->{path} . "/" . $self->{maildir_subdir};
|
||||
}
|
||||
|
||||
sub get_config_path {
|
||||
my $self = shift;
|
||||
croak "Unknown arguments to $self->get_subdir: ", join(", ", @_) if @_;
|
||||
return $self->{path} . "/" . $self->{subdir};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@ -0,0 +1,787 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Payment::AuthorizeDotNet
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: AuthorizeDotNet.pm,v 1.8 2008/09/23 23:55:26 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Enter description here.
|
||||
#
|
||||
|
||||
package GT::Payment::Direct::AuthorizeDotNet;
|
||||
use strict;
|
||||
use vars qw/%REQUIRED %ERRORS %PARAM $AUTOLOAD %VALID %CURRENCY/;
|
||||
|
||||
use Carp;
|
||||
use Net::SSLeay; # Just to make sure it's available, since GT::WWW doesn't load
|
||||
use GT::WWW; # Net::SSLeay until attempting to establish the connection.
|
||||
use Net::hostent;
|
||||
|
||||
%ERRORS = (
|
||||
INVALID => "Invalid value entered for %s: '%s'",
|
||||
INVALID_PIPE => "Invalid value entered for %s: '%s' ('|' is not permitted)",
|
||||
INVALID_CURRENCY => "Invalid currency specified for %s: '%s'",
|
||||
MISSING_FIELDS => 'The following must be set before calling %s: %s',
|
||||
|
||||
CHECK_INVALID => 'Invalid type to check: %s',
|
||||
AUTHORIZE_FIRST => 'You must authorize before capturing',
|
||||
CAPTURE_REF_NONE => 'No capture reference ID entered',
|
||||
CAPTURE_REF_INVALID => "Invalid capture reference ID '%s': %s",
|
||||
|
||||
HTTP_CONNECTING => 'An error occurred while connecting to the Authorize.net gateway: %s',
|
||||
HTTP_COMMUNICATING => 'An error occurred while communicating with the Authorize.net gateway: %s',
|
||||
|
||||
TEST_CONN_RESOLVE => 'Unable to resolve gateway host: %s',
|
||||
TEST_CONNECTION => 'Unable to establish a SSL test connection: %s',
|
||||
|
||||
DECLINED => 'Credit card declined: %s',
|
||||
);
|
||||
|
||||
# Also required in addition to this list that is set automatically:
|
||||
# x_Version (3.1), x_Delim_Data (TRUE), x_Type (AUTH_CAPTURE, AUTH_ONLY, etc.),
|
||||
# x_Method (CC)
|
||||
%REQUIRED = (
|
||||
AUTHORIZE => [
|
||||
'account_username', # x_Login
|
||||
'account_key', # x_Trans_Key
|
||||
|
||||
'credit_card_number', # x_Card_Num
|
||||
'credit_card_expiry_month', # x_Exp_Date (part 1, month)
|
||||
'credit_card_expiry_year', # x_Exp_Date (part 2, year)
|
||||
'charge_total', # x_Amount
|
||||
|
||||
'billing_fname',
|
||||
'billing_lname',
|
||||
'billing_address_1',
|
||||
'billing_city',
|
||||
'billing_state',
|
||||
'billing_postal_code',
|
||||
'billing_country',
|
||||
'billing_phone',
|
||||
|
||||
'order_id'
|
||||
],
|
||||
CAPTURE => [qw(
|
||||
account_username
|
||||
charge_total
|
||||
capture_reference_id
|
||||
)],
|
||||
# Can be used to refund an already settled payment partially or completely
|
||||
CREDIT => [qw(
|
||||
account_username
|
||||
charge_total
|
||||
capture_reference_id
|
||||
)],
|
||||
# Can be used to cancel a previously made payment. This can apply to an authorization,
|
||||
# capture, or sale - provided, with the latter two, that the payment has not already
|
||||
# been settled.
|
||||
VOID => [qw(
|
||||
account_username
|
||||
charge_total
|
||||
capture_reference_id
|
||||
)]
|
||||
);
|
||||
|
||||
# Scalar ref = use this value,
|
||||
# Scalar = call this method, use the return value
|
||||
# undef = the method (auth, capture, etc.) will set it
|
||||
%PARAM = (
|
||||
x_Delim_Char => \'|',
|
||||
x_Delim_Data => \'TRUE',
|
||||
x_Encap_Char => \'',
|
||||
# x_ADC_URL => \'FALSE',
|
||||
|
||||
x_Test_Request => 'test_mode', # this means nothing real actually happens. Values are 'TRUE' or 'FALSE'.
|
||||
|
||||
x_Login => 'account_username', # required
|
||||
x_Tran_Key => 'account_key', # supposedly required
|
||||
x_Password => 'account_password', # Optional under AIM (a merchant option)
|
||||
|
||||
x_Version => \'3.1', # Authorize.net protocol and response version.
|
||||
|
||||
x_Method => \'CC', # Authorize.Net also supports 'ECHECK', but it has different requirements and so should probably be a subclass
|
||||
# x_Auth_Code => ???, # ???
|
||||
x_Trans_ID => 'capture_reference_id', # Required for CREDIT, VOID, and PRIOR_AUTH_CAPTURE
|
||||
x_Card_Num => 'credit_card_number', # required
|
||||
x_Card_Code => 'credit_card_code', # optional
|
||||
x_Exp_Date => 'credit_card_expiry', # required - mmyy, mm/yy, or mm/yyyy
|
||||
x_Amount => 'charge_total', # required
|
||||
x_Currency_Code => 'currency', # optional - default is 'USD'
|
||||
|
||||
x_Invoice_Num => 'order_id', # not strictly required by Authorize.Net, but we require it anyway
|
||||
|
||||
x_Description => 'charge_description', # optional
|
||||
x_Freight => 'charge_freight', # optional
|
||||
x_Tax => 'charge_tax', # optional
|
||||
x_Tax_Exempt => 'charge_tax_exempt', # optional - 'TRUE' or 'FALSE' (default)
|
||||
x_Description => 'charge_description', # optional
|
||||
x_Duty => 'charge_duty', # optional - valid is "any valid amount"
|
||||
|
||||
x_First_Name => 'billing_fname', # required
|
||||
x_Last_Name => 'billing_lname', # required
|
||||
x_Company => 'billing_company', # optional
|
||||
x_Address => 'billing_address', # required - equivelant to a combination of Moneris' billing_address_1 and ..._2
|
||||
x_City => 'billing_city', # required
|
||||
x_State => 'billing_state', # required
|
||||
x_Country => 'billing_country', # required
|
||||
x_Zip => 'billing_postal_code', # required
|
||||
x_Phone => 'billing_phone', # required
|
||||
x_Fax => 'billing_fax', # optional
|
||||
|
||||
x_Customer_IP => 'billing_ip', # required; Moneris doesn't have this. It is the IP of whoever placed the order
|
||||
|
||||
x_Email => 'confirmation_email', # optional
|
||||
x_Email_Customer => 'confirmation_confirm', # optional - Whether a confirmation e-mail should be sent to the customer. 'TRUE' or 'FALSE'. Default is configurable through Merchant interface
|
||||
x_Merchant_Email => 'confirmation_merchant', # optional - if set, an e-mail will be sent here in addition to the normal merchant e-mail address
|
||||
|
||||
# x_Recurring_Billing => ???, # optional - TRUE or FALSE (FALSE is default)
|
||||
|
||||
# All optional:
|
||||
x_Ship_To_First_Name => 'shipping_fname',
|
||||
x_Ship_To_Last_Name => 'shipping_lname',
|
||||
x_Ship_To_Company => 'shipping_company',
|
||||
x_Ship_To_Address => 'shipping_address',
|
||||
x_Ship_To_City => 'shipping_city',
|
||||
x_Ship_To_State => 'shipping_state',
|
||||
x_Ship_To_Country => 'shipping_country',
|
||||
x_Ship_To_Zip => 'shipping_postal_code',
|
||||
|
||||
x_Type => undef, # This has to be set by auth(), or capture() to one of:
|
||||
#
|
||||
# AUTH_CAPTURE: Auth-Capture is the normal transaction method; a transaction is
|
||||
# sent to the system for approval, the transaction is approved, the merchant is
|
||||
# notified of the approval, and the transaction automatically settles at the
|
||||
# end of the business day without any further action by the merchant.
|
||||
#
|
||||
# AUTH_ONLY: Auth-Only stands for Authorization-Only and means obtaining an
|
||||
# authorization for a certain amount on a customer's credit card without
|
||||
# actually charging the card. If the money is not captured within 30 days, the
|
||||
# transaction will expire.
|
||||
#
|
||||
# PRIOR_AUTH_CAPTURE: A Prior-Auth-Capture transaction is used to capture funds
|
||||
# authorized previously using an Auth-Only transaction. Prior-Auth-Capture is
|
||||
# really just an operation on an already existing transaction.
|
||||
# Prior-Auth-Capture should only be used on Auth-Only transactions processed
|
||||
# using the system.
|
||||
#
|
||||
# CAPTURE_ONLY: Capture-Only transactions are used when an authorization-only is
|
||||
# obtained through any means other than the system.
|
||||
#
|
||||
# CREDIT: Credits are not processed in real time, but are submitted at
|
||||
# settlement time with other transactions.
|
||||
#
|
||||
# VOID: Voiding a transaction prevents a charge to a credit card/bank account
|
||||
# from occurring. Voids are performed on existing transactions that have yet to
|
||||
# be settled.
|
||||
#
|
||||
#x_Use_Fraudscreen => ???, # "Not yet supported"
|
||||
);
|
||||
|
||||
my $monetary = '^(?:\d+\.?\d*|\.\d+)$';
|
||||
# A series of regex for field assignment. References are special values, as follows:
|
||||
# BOOL => accept a boolean (1 or undef)
|
||||
# CURRENCY => accept a key of the %CURRENCY hash
|
||||
#
|
||||
# undef means any string can be assigned. Note that anything NOT in here CANNOT
|
||||
# be called as a method.
|
||||
%VALID = (
|
||||
account_username => undef,
|
||||
account_key => undef,
|
||||
account_password => undef,
|
||||
|
||||
capture_reference_id => undef,
|
||||
credit_card_number => '^\d{13,19}$',
|
||||
credit_card_expiry_month => '^(?:0?[1-9]|1[012])$',
|
||||
credit_card_expiry_year => '^\d\d(?:\d\d)?$',
|
||||
#credit_card_expiry => '^(?:0?[1-9]|1[12])(?:[-/]?\d\d(?:\d\d)?)$', # mmyy, mm/yy, mm-yy, mmyyyy, mm/yyyy, or mm-yyyy
|
||||
credit_card_code => '^\d{3,4}$', # The 3 or 4 digit code on the back of the credit card (or front of Amer. Exp.)
|
||||
currency => \'CURRENCY',
|
||||
charge_total => $monetary,
|
||||
charge_freight => $monetary,
|
||||
charge_tax => $monetary,
|
||||
charge_tax_exempt => \'BOOL',
|
||||
charge_duty => $monetary,
|
||||
charge_description => undef,
|
||||
charge_duty => $monetary,
|
||||
|
||||
billing_fname => undef,
|
||||
billing_lname => undef,
|
||||
billing_company => undef,
|
||||
billing_address_1 => undef,
|
||||
billing_address_2 => undef,
|
||||
billing_city => undef,
|
||||
billing_state => undef,
|
||||
billing_country => undef,
|
||||
billing_postal_code => undef,
|
||||
billing_phone => undef,
|
||||
billing_fax => undef,
|
||||
billing_ip => '^(?:(?:1?\d?\d|2(?:[0-4]\d|5[0-5]))\.){3}(?:1?\d?\d|2(?:[0-4]\d|5[0-5]))$',
|
||||
|
||||
confirmation_email => '^\S+@([a-zA-Z0-9-]+\.)+[a-zA-Z0-9-]+$',
|
||||
confirmation_confirm => \'BOOL',
|
||||
confirmation_merchant => '^\S+@([a-zA-Z0-9-]+\.)+[a-zA-Z0-9-]+$',
|
||||
|
||||
shipping_fname => undef,
|
||||
shipping_lname => undef,
|
||||
shipping_company => undef,
|
||||
shipping_address => undef,
|
||||
shipping_city => undef,
|
||||
shipping_state => undef,
|
||||
shipping_country => undef,
|
||||
shipping_postal_code => undef,
|
||||
|
||||
order_id => '^.{1,20}$',
|
||||
|
||||
test_mode => \'BOOL'
|
||||
);
|
||||
|
||||
# The official list of supported currencies:
|
||||
%CURRENCY = (
|
||||
AFA => 'Afghani (Afghanistan)',
|
||||
DZD => 'Algerian Dinar (Algeria)',
|
||||
ADP => 'Andorran Peseta (Andorra)',
|
||||
ARS => 'Argentine Peso (Argentina)',
|
||||
AMD => 'Armenian Dram (Armenia)',
|
||||
AWG => 'Aruban Guilder (Aruba)',
|
||||
AUD => 'Australian Dollar (Australia)',
|
||||
AZM => 'Azerbaijanian Manat (Azerbaijan)',
|
||||
BSD => 'Bahamian Dollar (Bahamas)',
|
||||
BHD => 'Bahraini Dinar (Bahrain)',
|
||||
THB => 'Baht (Thailand)',
|
||||
PAB => 'Balboa (Panama)',
|
||||
BBD => 'Barbados Dollar (Barbados)',
|
||||
BYB => 'Belarussian Ruble (Belarus)',
|
||||
BEF => 'Belgian Franc (Belgium)',
|
||||
BZD => 'Belize Dollar (Belize)',
|
||||
BMD => 'Bermudian Dollar (Bermuda)',
|
||||
VEB => 'Bolivar (Venezuela)',
|
||||
BOB => 'Boliviano (Bolivia)',
|
||||
BRL => 'Brazilian Real (Brazil)',
|
||||
BND => 'Brunei Dollar (Brunei Darussalam)',
|
||||
BGN => 'Bulgarian Lev (Bulgaria)',
|
||||
BIF => 'Burundi Franc (Burundi)',
|
||||
CAD => 'Canadian Dollar (Canada)',
|
||||
CVE => 'Cape Verde Escudo (Cape Verde)',
|
||||
KYD => 'Cayman Islands Dollar (Cayman Islands)',
|
||||
GHC => 'Cedi (Ghana)',
|
||||
XOF => 'CFA Franc BCEAO (Guinea-Bissau)',
|
||||
XAF => 'CFA Franc BEAC (Central African Republic)',
|
||||
XPF => 'CFP Franc (New Caledonia)',
|
||||
CLP => 'Chilean Peso (Chile)',
|
||||
COP => 'Colombian Peso (Colombia)',
|
||||
KMF => 'Comoro Franc (Comoros)',
|
||||
BAM => 'Convertible Marks (Bosnia And Herzegovina)',
|
||||
NIO => 'Cordoba Oro (Nicaragua)',
|
||||
CRC => 'Costa Rican Colon (Costa Rica)',
|
||||
CUP => 'Cuban Peso (Cuba)',
|
||||
CYP => 'Cyprus Pound (Cyprus)',
|
||||
CZK => 'Czech Koruna (Czech Republic)',
|
||||
GMD => 'Dalasi (Gambia)',
|
||||
DKK => 'Danish Krone (Denmark)',
|
||||
MKD => 'Denar (The Former Yugoslav Republic Of Macedonia)',
|
||||
DEM => 'Deutsche Mark (Germany)',
|
||||
AED => 'Dirham (United Arab Emirates)',
|
||||
DJF => 'Djibouti Franc (Djibouti)',
|
||||
STD => 'Dobra (Sao Tome And Principe)',
|
||||
DOP => 'Dominican Peso (Dominican Republic)',
|
||||
VND => 'Dong (Vietnam)',
|
||||
GRD => 'Drachma (Greece)',
|
||||
XCD => 'East Caribbean Dollar (Grenada)',
|
||||
EGP => 'Egyptian Pound (Egypt)',
|
||||
SVC => 'El Salvador Colon (El Salvador)',
|
||||
ETB => 'Ethiopian Birr (Ethiopia)',
|
||||
EUR => 'Euro (Europe)',
|
||||
FKP => 'Falkland Islands Pound (Falkland Islands)',
|
||||
FJD => 'Fiji Dollar (Fiji)',
|
||||
HUF => 'Forint (Hungary)',
|
||||
CDF => 'Franc Congolais (The Democratic Republic Of Congo)',
|
||||
FRF => 'French Franc (France)',
|
||||
GIP => 'Gibraltar Pound (Gibraltar)',
|
||||
XAU => 'Gold',
|
||||
HTG => 'Gourde (Haiti)',
|
||||
PYG => 'Guarani (Paraguay)',
|
||||
GNF => 'Guinea Franc (Guinea)',
|
||||
GWP => 'Guinea-Bissau Peso (Guinea-Bissau)',
|
||||
GYD => 'Guyana Dollar (Guyana)',
|
||||
HKD => 'Hong Kong Dollar (Hong Kong)',
|
||||
UAH => 'Hryvnia (Ukraine)',
|
||||
ISK => 'Iceland Krona (Iceland)',
|
||||
INR => 'Indian Rupee (India)',
|
||||
IRR => 'Iranian Rial (Islamic Republic Of Iran)',
|
||||
IQD => 'Iraqi Dinar (Iraq)',
|
||||
IEP => 'Irish Pound (Ireland)',
|
||||
ITL => 'Italian Lira (Italy)',
|
||||
JMD => 'Jamaican Dollar (Jamaica)',
|
||||
JOD => 'Jordanian Dinar (Jordan)',
|
||||
KES => 'Kenyan Shilling (Kenya)',
|
||||
PGK => 'Kina (Papua New Guinea)',
|
||||
LAK => 'Kip (Lao People\'s Democratic Republic)',
|
||||
EEK => 'Kroon (Estonia)',
|
||||
HRK => 'Kuna (Croatia)',
|
||||
KWD => 'Kuwaiti Dinar (Kuwait)',
|
||||
MWK => 'Kwacha (Malawi)',
|
||||
ZMK => 'Kwacha (Zambia)',
|
||||
AOR => 'Kwanza Reajustado (Angola)',
|
||||
MMK => 'Kyat (Myanmar)',
|
||||
GEL => 'Lari (Georgia)',
|
||||
LVL => 'Latvian Lats (Latvia)',
|
||||
LBP => 'Lebanese Pound (Lebanon)',
|
||||
ALL => 'Lek (Albania)',
|
||||
HNL => 'Lempira (Honduras)',
|
||||
SLL => 'Leone (Sierra Leone)',
|
||||
ROL => 'Leu (Romania)',
|
||||
BGL => 'Lev (Bulgaria)',
|
||||
LRD => 'Liberian Dollar (Liberia)',
|
||||
LYD => 'Libyan Dinar (Libyan Arab Jamahiriya)',
|
||||
SZL => 'Lilangeni (Swaziland)',
|
||||
LTL => 'Lithuanian Litas (Lithuania)',
|
||||
LSL => 'Loti (Lesotho)',
|
||||
LUF => 'Luxembourg Franc (Luxembourg)',
|
||||
MGF => 'Malagasy Franc (Madagascar)',
|
||||
MYR => 'Malaysian Ringgit (Malaysia)',
|
||||
MTL => 'Maltese Lira (Malta)',
|
||||
TMM => 'Manat (Turkmenistan)',
|
||||
FIM => 'Markka (Finland)',
|
||||
MUR => 'Mauritius Rupee (Mauritius)',
|
||||
MZM => 'Metical (Mozambique)',
|
||||
MXN => 'Mexican Peso (Mexico)',
|
||||
MXV => 'Mexican Unidad de Inversion (Mexico)',
|
||||
MDL => 'Moldovan Leu (Republic Of Moldova)',
|
||||
MAD => 'Moroccan Dirham (Morocco)',
|
||||
BOV => 'Mvdol (Bolivia)',
|
||||
NGN => 'Naira (Nigeria)',
|
||||
ERN => 'Nakfa (Eritrea)',
|
||||
NAD => 'Namibia Dollar (Namibia)',
|
||||
NPR => 'Nepalese Rupee (Nepal)',
|
||||
ANG => 'Netherlands (Netherlands)',
|
||||
NLG => 'Netherlands Guilder (Netherlands)',
|
||||
YUM => 'New Dinar (Yugoslavia)',
|
||||
ILS => 'New Israeli Sheqel (Israel)',
|
||||
AON => 'New Kwanza (Angola)',
|
||||
TWD => 'New Taiwan Dollar (Province Of China Taiwan)',
|
||||
ZRN => 'New Zaire (Zaire)',
|
||||
NZD => 'New Zealand Dollar (New Zealand)',
|
||||
BTN => 'Ngultrum (Bhutan)',
|
||||
KPW => 'North Korean Won (Democratic People\'s Republic Of Korea)',
|
||||
NOK => 'Norwegian Krone (Norway)',
|
||||
PEN => 'Nuevo Sol (Peru)',
|
||||
MRO => 'Ouguiya (Mauritania)',
|
||||
TOP => 'Pa\'anga (Tonga)',
|
||||
PKR => 'Pakistan Rupee (Pakistan)',
|
||||
XPD => 'Palladium',
|
||||
MOP => 'Pataca (Macau)',
|
||||
UYU => 'Peso Uruguayo (Uruguay)',
|
||||
PHP => 'Philippine Peso (Philippines)',
|
||||
XPT => 'Platinum',
|
||||
PTE => 'Portuguese Escudo (Portugal)',
|
||||
GBP => 'Pound Sterling (United Kingdom)',
|
||||
BWP => 'Pula (Botswana)',
|
||||
QAR => 'Qatari Rial (Qatar)',
|
||||
GTQ => 'Quetzal (Guatemala)',
|
||||
ZAL => 'Rand (Financial) (Lesotho)',
|
||||
ZAR => 'Rand (South Africa)',
|
||||
OMR => 'Rial Omani (Oman)',
|
||||
KHR => 'Riel (Cambodia)',
|
||||
MVR => 'Rufiyaa (Maldives)',
|
||||
IDR => 'Rupiah (Indonesia)',
|
||||
RUB => 'Russian Ruble (Russian Federation)',
|
||||
RUR => 'Russian Ruble (Russian Federation)',
|
||||
RWF => 'Rwanda Franc (Rwanda)',
|
||||
SAR => 'Saudi Riyal (Saudi Arabia)',
|
||||
ATS => 'Schilling (Austria)',
|
||||
SCR => 'Seychelles Rupee (Seychelles)',
|
||||
XAG => 'Silver',
|
||||
SGD => 'Singapore Dollar (Singapore)',
|
||||
SKK => 'Slovak Koruna (Slovakia)',
|
||||
SBD => 'Solomon Islands Dollar (Solomon Islands)',
|
||||
KGS => 'Som (Kyrgyzstan)',
|
||||
SOS => 'Somali Shilling (Somalia)',
|
||||
ESP => 'Spanish Peseta (Spain)',
|
||||
LKR => 'Sri Lanka Rupee (Sri Lanka)',
|
||||
SHP => 'St Helena Pound (St Helena)',
|
||||
ECS => 'Sucre (Ecuador)',
|
||||
SDD => 'Sudanese Dinar (Sudan)',
|
||||
SRG => 'Surinam Guilder (Suriname)',
|
||||
SEK => 'Swedish Krona (Sweden)',
|
||||
CHF => 'Swiss Franc (Switzerland)',
|
||||
SYP => 'Syrian Pound (Syrian Arab Republic)',
|
||||
TJR => 'Tajik Ruble (Tajikistan)',
|
||||
BDT => 'Taka (Bangladesh)',
|
||||
WST => 'Tala (Samoa)',
|
||||
TZS => 'Tanzanian Shilling (United Republic Of Tanzania)',
|
||||
KZT => 'Tenge (Kazakhstan)',
|
||||
TPE => 'Timor Escudo (East Timor)',
|
||||
SIT => 'Tolar (Slovenia)',
|
||||
TTD => 'Trinidad and Tobago Dollar (Trinidad And Tobago)',
|
||||
MNT => 'Tugrik (Mongolia)',
|
||||
TND => 'Tunisian Dinar (Tunisia)',
|
||||
TRL => 'Turkish Lira (Turkey)',
|
||||
UGX => 'Uganda Shilling (Uganda)',
|
||||
ECV => 'Unidad de Valor Constante (Ecuador)',
|
||||
CLF => 'Unidades de fomento (Chile)',
|
||||
USN => 'US Dollar (Next day) (United States)',
|
||||
USS => 'US Dollar (Same day) (United States)',
|
||||
USD => 'US Dollar (United States)',
|
||||
UZS => 'Uzbekistan Sum (Uzbekistan)',
|
||||
VUV => 'Vatu (Vanuatu)',
|
||||
KRW => 'Won (Republic Of Korea)',
|
||||
YER => 'Yemeni Rial (Yemen)',
|
||||
JPY => 'Yen (Japan)',
|
||||
CNY => 'Yuan Renminbi (China)',
|
||||
ZWD => 'Zimbabwe Dollar (Zimbabwe)',
|
||||
PLN => 'Zloty (Poland)'
|
||||
);
|
||||
|
||||
use constants
|
||||
POST_HOST => 'secure.authorize.net',
|
||||
POST_PATH => '/gateway/transact.dll';
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
my $self = { debug => 0 };
|
||||
bless $self, $class;
|
||||
|
||||
$self->debug("New $class object created") if $self->{debug} and $self->{debug} >= 2;
|
||||
|
||||
while (@_) {
|
||||
my ($method, $value) = splice @_, 0, 2;
|
||||
$self->debug("Found '$method' => '$value' in new() arguments - calling \$self->$method($value)") if $self->{debug} and $self->{debug} >= 2;
|
||||
$self->$method($value);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
DESTROY { }
|
||||
|
||||
sub errcode {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->{errcode};
|
||||
}
|
||||
|
||||
sub error {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $code = shift;
|
||||
$self->{errcode} = $code;
|
||||
my $error = sprintf($ERRORS{$code} || $code, @_);
|
||||
$self->debug($error) if $self->{debug};
|
||||
$self->{error} = $error;
|
||||
|
||||
return undef;
|
||||
}
|
||||
$self->{error};
|
||||
}
|
||||
|
||||
sub clear_error {
|
||||
my $self = shift;
|
||||
$self->{error} = $self->{errcode} = undef;
|
||||
$self->debug("Clearing error code") if $self->{debug} >= 2;
|
||||
}
|
||||
|
||||
sub fatal {
|
||||
# -----------------------------------------------------------------------------
|
||||
my ($self, $code) = splice @_, 0, 2;
|
||||
my $error = sprintf($ERRORS{$code} || $code, @_);
|
||||
my $me = ref $self || $self;
|
||||
croak "$me: @_";
|
||||
}
|
||||
|
||||
sub debug {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = @_ > 1 ? shift : __PACKAGE__;
|
||||
$self = ref $self if ref $self;
|
||||
carp "$self: @_";
|
||||
}
|
||||
|
||||
sub debug_level {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{debug} = int shift;
|
||||
}
|
||||
$self->{debug};
|
||||
}
|
||||
|
||||
AUTOLOAD {
|
||||
my ($method) = $AUTOLOAD =~ /([^:]+)$/;
|
||||
if (exists $VALID{$method}) {
|
||||
no strict 'refs';
|
||||
my $validation = $VALID{$method};
|
||||
*$method = sub {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{error} = undef;
|
||||
if (ref $validation) {
|
||||
if ($$validation eq 'BOOL') {
|
||||
if (shift) {
|
||||
$self->debug("Setting '$method' option to true") if $self->{debug};
|
||||
$self->{$method} = 'TRUE';
|
||||
}
|
||||
else {
|
||||
$self->debug("Setting '$method' option to false") if $self->{debug};
|
||||
$self->{$method} = 'FALSE';
|
||||
}
|
||||
}
|
||||
elsif ($$validation eq 'CURRENCY') {
|
||||
my $value = uc shift;
|
||||
unless (exists $CURRENCY{$value}) {
|
||||
$self->debug("Not setting '$method' to '$value' (Invalid currency code)") if $self->{debug};
|
||||
return $self->error(INVALID_CURRENCY => $method, $value);
|
||||
}
|
||||
$self->debug("Setting '$method' to '$value' (Currency code accepted)") if $self->{debug};
|
||||
$self->{$method} = $value;
|
||||
}
|
||||
}
|
||||
elsif (defined $validation) {
|
||||
my $value = shift;
|
||||
$value =~ s/\s+//g if $method eq 'credit_card_number';
|
||||
if ($value =~ /$validation/) {
|
||||
if (index($value, '|') >= 0) {
|
||||
$self->debug("Not setting '$method' to '$value' (Value contains illegal character '|')") if $self->{debug};
|
||||
return $self->error(INVALID_PIPE => $method, $value);
|
||||
}
|
||||
$self->debug("Setting '$method' to '$value' (Validation regex: $validation passed)") if $self->{debug};
|
||||
$self->{$method} = $value;
|
||||
}
|
||||
else {
|
||||
$self->debug("Not setting '$method' to '$value' (Validation regex: $validation failed)") if $self->{debug};
|
||||
return $self->error(INVALID => $method, $value);
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $value = shift;
|
||||
if (index($value, '|') >= 0) {
|
||||
$self->debug("Not setting '$method' to '$value' (Value contains illegal character '|')") if $self->{debug};
|
||||
return $self->error(INVALID_PIPE => $method, $value);
|
||||
}
|
||||
$self->debug("Setting '$method' to '$value' (No validation regex)") if $self->{debug};
|
||||
$self->{$method} = $value;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
my $value = $self->{$method};
|
||||
$self->debug("Retrieving '$method': '$value'") if $self->{debug} and $self->{debug} >= 2;
|
||||
return $value;
|
||||
};
|
||||
}
|
||||
else {
|
||||
croak qq|Can't locate object method "$method" via package "| . (ref $_[0] or $_[0] or __PACKAGE__) . qq|"|;
|
||||
}
|
||||
goto &$method;
|
||||
}
|
||||
|
||||
sub billing_address {
|
||||
my $self = shift;
|
||||
my ($one, $two) = ($self->billing_address_1, $self->billing_address_2);
|
||||
return unless defined $one;
|
||||
return $two ? $one . "\n" . $two : $one;
|
||||
}
|
||||
|
||||
sub credit_card_expiry {
|
||||
my $self = shift;
|
||||
my ($month, $year) = ($self->credit_card_expiry_month, $self->credit_card_expiry_year);
|
||||
return unless defined $month and defined $year;
|
||||
return $month . '/' . $year;
|
||||
}
|
||||
|
||||
sub check {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Checks that all necessary data is provided for an authorize, capture, or sale.
|
||||
# Takes one argument - 'authorize', 'capture', or 'sale', though 'sale' is
|
||||
# really no different from 'authorize'.
|
||||
my ($self, $type) = @_;
|
||||
|
||||
$self->clear_error();
|
||||
|
||||
$self->fatal(CHECK_INVALID => $type) unless $type =~ /^(?:authorize|capture|sale)$/i;
|
||||
|
||||
my @bad;
|
||||
for my $field (@{$REQUIRED{uc(lc $type eq 'sale' ? 'authorize' : $type)}}) {
|
||||
my $value = $self->$field();
|
||||
if ($field eq 'charge_total') {
|
||||
push @bad, $field if $value <= 0;
|
||||
}
|
||||
else {
|
||||
push @bad, $field if not defined $value or not length $value;
|
||||
}
|
||||
}
|
||||
if (@bad) {
|
||||
$self->error(MISSING_FIELDS => $type => "@bad");
|
||||
return undef;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub response {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->{response};
|
||||
}
|
||||
|
||||
sub _init_www {
|
||||
# -----------------------------------------------------------------------------
|
||||
my ($self, $type) = @_;
|
||||
|
||||
my $www = $self->{www} ||= GT::WWW->new(debug => $self->{debug});
|
||||
$www->url('https://' . POST_HOST . POST_PATH);
|
||||
my @param;
|
||||
|
||||
while (my ($key, $value) = each %PARAM) {
|
||||
if (ref $value) {
|
||||
push @param, $key, $$value;
|
||||
}
|
||||
elsif ($key eq 'x_Type') {
|
||||
push @param, 'x_Type', $type;
|
||||
}
|
||||
else {
|
||||
my $val = $self->$value();
|
||||
push @param, $key, $val if defined $val;
|
||||
}
|
||||
}
|
||||
|
||||
$www->header(Connection => 'close');
|
||||
$www->parameters(@param);
|
||||
|
||||
return $www;
|
||||
}
|
||||
|
||||
sub post_payment_request {
|
||||
# -----------------------------------------------------------------------------
|
||||
my ($self, $type) = @_;
|
||||
my $www = $self->_init_www($type);
|
||||
|
||||
my $response = $www->post;
|
||||
|
||||
unless ($response) {
|
||||
return $self->error(HTTP_CONNECTING => $www->error);
|
||||
}
|
||||
unless ($response->status) {
|
||||
return $self->error(HTTP_COMMUNICATING => int($response->status()) . ' ' . $response->status());
|
||||
}
|
||||
|
||||
|
||||
my @fields = split /\|/, "$response";
|
||||
$self->{response} = { fields => \@fields };
|
||||
|
||||
$self->{response}->{code} = $fields[0]; # 1 = Approved, 2 = Denied, 3 = Error
|
||||
$self->{response}->{reason_code} = $fields[2];
|
||||
$self->{response}->{reason_text} = $fields[3];
|
||||
$self->{response}->{approval_code} = $fields[4]; # The six-digit alphanumeric authorization or approval code
|
||||
$self->{response}->{avs_code} = $fields[5]; # See the AIM Implementation Guide
|
||||
|
||||
# "This number identifies the transaction in the system and can be used to
|
||||
# submit a modification of this transaction at a later time, such as voiding,
|
||||
# crediting or capturing the transaction."
|
||||
$self->{response}->{trans_id} = $fields[6];
|
||||
|
||||
# The 8th through 37th fields are just the form input echoed back.
|
||||
|
||||
# 38 is a "system-generated MD5 hash that may be validated by the merchant to
|
||||
# authenticate a transaction response received from the gateway"
|
||||
$self->{response}->{md5_hash} = $fields[37];
|
||||
|
||||
# 39 "indicates the results of Card Code verification" - see the AIM Implementation Guide
|
||||
$self->{response}->{card_code_response} = $fields[38];
|
||||
|
||||
$self->{transaction_error_code} = $self->{response}->{reason_code};
|
||||
|
||||
# What we return is:
|
||||
# 1 - Payment request successful
|
||||
# 0 - Payment request declined
|
||||
# -1 - An error occurred
|
||||
|
||||
if ($self->{response}->{code} == 1) {
|
||||
my @receipt;
|
||||
push @receipt, 'Approval Code', $self->{response}->{approval_code};
|
||||
push @receipt, 'AVS Code', $self->{response}->{avs_code} if $self->{response}->{avs_code};
|
||||
push @receipt, 'Transaction ID', $self->{response}->{trans_id};
|
||||
push @receipt, 'Card Code Response', $self->{response}->{card_code_response} if $self->{response}->{card_code_response};
|
||||
|
||||
$self->{response}->{receipt} = \@receipt;
|
||||
}
|
||||
|
||||
return $self->{response}->{code} == 1 ? 1 : $self->{response}->{code} == 2 ? 0 : -1;
|
||||
}
|
||||
|
||||
sub authorize {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->debug("Performing authorization") if $self->{debug};
|
||||
|
||||
$self->{type} = 'AUTH_ONLY';
|
||||
$self->check('authorize') or return undef;
|
||||
|
||||
my $ret = $self->post_payment_request('AUTH_ONLY');
|
||||
|
||||
# Set the transaction ID as our 'capture_reference_id', so that this object can
|
||||
# capture() immediately after authorize()ing.
|
||||
$self->{capture_reference_id} = $self->{response}->{trans_id};
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub capture {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->debug("Performing prior-auth capture") if $self->{debug};
|
||||
|
||||
$self->{type} = 'PRIOR_AUTH_CAPTURE';
|
||||
$self->check('capture') or return undef;
|
||||
|
||||
return $self->post_payment_request('PRIOR_AUTH_CAPTURE');
|
||||
}
|
||||
|
||||
sub sale {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->debug("Performing auth-capture (sale)") if $self->{debug};
|
||||
|
||||
$self->{type} = 'AUTH_CAPTURE';
|
||||
$self->check('sale') or return undef;
|
||||
|
||||
return $self->post_payment_request('AUTH_CAPTURE');
|
||||
}
|
||||
|
||||
sub test_connection {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Call this on your object when setting up a payment system to verify that the
|
||||
# payment gateway is reachable. This does a simple HEAD request of
|
||||
# http://secure.authorize.net - if 200 status is returned, it is assumed to be
|
||||
# reachable.
|
||||
my $self = shift;
|
||||
|
||||
my $www = $self->{www} ||= GT::WWW->new();
|
||||
# We're just going to do a HEAD request to make sure we can properly establish
|
||||
# an HTTPS connection.
|
||||
|
||||
unless (gethost(POST_HOST)) {
|
||||
return $self->error(TEST_CONN_RESOLVE => POST_HOST);
|
||||
}
|
||||
|
||||
$www->url('https://' . POST_HOST);
|
||||
|
||||
my $response = $www->head();
|
||||
|
||||
unless ($response and my $status = $response->status) {
|
||||
return $self->error(TEST_CONNECTION => ($response ? "Server response: " . int($status) . " " . $status : $www->error));
|
||||
}
|
||||
|
||||
$self->{connection_tested} = 1;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
#sub test_account {
|
||||
# -----------------------------------------------------------------------------
|
||||
|
||||
1;
|
||||
@ -0,0 +1,773 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Payment::Direct::Moneris
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Moneris.pm,v 1.12 2008/09/23 23:55:26 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Handle payment processing via Moneris eSelect Plus.
|
||||
#
|
||||
|
||||
package GT::Payment::Direct::Moneris;
|
||||
use strict;
|
||||
use vars qw/@ISA $ERRORS $VERSION %REQUIRED %RESPONSE $AUTOLOAD %BRANDS %NAME_MAP/;
|
||||
|
||||
use GT::Base;
|
||||
use GT::WWW;
|
||||
use GT::WWW::https;
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.12 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
use constants
|
||||
LIVE_SERVER => 'https://www3.moneris.com:43924/gateway2/servlet/MpgRequest',
|
||||
TEST_SERVER => 'https://esqa.moneris.com:43924/gateway2/servlet/MpgRequest',
|
||||
TIMEOUT => 60;
|
||||
|
||||
@ISA = 'GT::Base';
|
||||
|
||||
%REQUIRED = (
|
||||
AUTHORIZE => [qw(
|
||||
account_token
|
||||
account_token2
|
||||
credit_card_number
|
||||
credit_card_expiry_month
|
||||
credit_card_expiry_year
|
||||
charge_total
|
||||
billing_fname
|
||||
billing_lname
|
||||
billing_address
|
||||
billing_city
|
||||
billing_state
|
||||
billing_postal_code
|
||||
billing_country
|
||||
order_id
|
||||
)],
|
||||
CAPTURE => [qw(
|
||||
account_token
|
||||
charge_total
|
||||
capture_reference_id
|
||||
order_id
|
||||
)]
|
||||
);
|
||||
|
||||
# The following credit card brands are supported by Moneris
|
||||
%BRANDS = (
|
||||
VISA => 1,
|
||||
MASTERCARD => 1, # Can also be passed as 'MC'
|
||||
AMERICAN_EXPRESS => 1, # Can also be passed as 'AMEX'
|
||||
DISCOVER => 1, # Can also be passed as 'DISC'
|
||||
NOVA => 1,
|
||||
DINERS => 1,
|
||||
EUROCARD => 1
|
||||
);
|
||||
|
||||
%RESPONSE = (
|
||||
0 => 'Approved, account balances included',
|
||||
1 => 'Approved, account balances not included',
|
||||
2 => 'Approved, country club',
|
||||
3 => 'Approved, maybe more ID',
|
||||
4 => 'Approved, pending ID (sign paper draft)',
|
||||
5 => 'Approved, blind',
|
||||
6 => 'Approved, VIP',
|
||||
7 => 'Approved, administrative transaction',
|
||||
8 => 'Approved, national NEG file hit OK',
|
||||
9 => 'Approved, commercial',
|
||||
23 => 'Amex - credit approval',
|
||||
24 => 'Amex 77 - credit approval',
|
||||
25 => 'Amex - credit approval ',
|
||||
26 => 'Amex - credit approval ',
|
||||
27 => 'Credit card approval',
|
||||
28 => 'VIP Credit Approved',
|
||||
29 => 'Credit Response Acknowledgement',
|
||||
50 => 'Decline',
|
||||
51 => 'Expired Card',
|
||||
52 => 'PIN retries exceeded',
|
||||
53 => 'No sharing',
|
||||
54 => 'No security module',
|
||||
55 => 'Invalid transaction',
|
||||
56 => 'No Support',
|
||||
57 => 'Lost or stolen card',
|
||||
58 => 'Invalid status',
|
||||
59 => 'Restricted Card',
|
||||
60 => 'No Chequing account',
|
||||
60 => 'No Savings account',
|
||||
61 => 'No PBF',
|
||||
62 => 'PBF update error',
|
||||
63 => 'Invalid authorization type',
|
||||
64 => 'Bad Track 2',
|
||||
65 => 'Adjustment not allowed',
|
||||
66 => 'Invalid credit card advance increment',
|
||||
67 => 'Invalid transaction date',
|
||||
68 => 'PTLF error',
|
||||
69 => 'Bad message error',
|
||||
70 => 'No IDF',
|
||||
71 => 'Invalid route authorization',
|
||||
72 => 'Card on National NEG file ',
|
||||
73 => 'Invalid route service (destination)',
|
||||
74 => 'Unable to authorize',
|
||||
75 => 'Invalid PAN length',
|
||||
76 => 'Low funds',
|
||||
77 => 'Pre-auth full',
|
||||
78 => 'Duplicate transaction',
|
||||
79 => 'Maximum online refund reached',
|
||||
80 => 'Maximum offline refund reached',
|
||||
81 => 'Maximum credit per refund reached',
|
||||
82 => 'Number of times used exceeded',
|
||||
83 => 'Maximum refund credit reached',
|
||||
84 => 'Duplicate transaction - authorization number has already been corrected by host.',
|
||||
85 => 'Inquiry not allowed',
|
||||
86 => 'Over floor limit ',
|
||||
87 => 'Maximum number of refund credit by retailer',
|
||||
88 => 'Place call ',
|
||||
89 => 'CAF status inactive or closed',
|
||||
90 => 'Referral file full',
|
||||
91 => 'NEG file problem',
|
||||
92 => 'Advance less than minimum',
|
||||
93 => 'Delinquent',
|
||||
94 => 'Over table limit',
|
||||
95 => 'Amount over maximum',
|
||||
96 => 'PIN required',
|
||||
97 => 'Mod 10 check failure',
|
||||
98 => 'Force Post',
|
||||
99 => 'Bad PBF',
|
||||
100 => 'Unable to process transaction',
|
||||
101 => 'Place call',
|
||||
102 => '',
|
||||
103 => 'NEG file problem',
|
||||
104 => 'CAF problem',
|
||||
105 => 'Card not supported',
|
||||
106 => 'Amount over maximum',
|
||||
107 => 'Over daily limit',
|
||||
108 => 'CAF Problem',
|
||||
109 => 'Advance less than minimum',
|
||||
110 => 'Number of times used exceeded',
|
||||
111 => 'Delinquent',
|
||||
112 => 'Over table limit',
|
||||
113 => 'Timeout',
|
||||
115 => 'PTLF error',
|
||||
121 => 'Administration file problem',
|
||||
122 => 'Unable to validate PIN: security module down',
|
||||
150 => 'Merchant not on file',
|
||||
200 => 'Invalid account',
|
||||
201 => 'Incorrect PIN',
|
||||
202 => 'Advance less than minimum',
|
||||
203 => 'Administrative card needed',
|
||||
204 => 'Amount over maximum ',
|
||||
205 => 'Invalid Advance amount',
|
||||
206 => 'CAF not found',
|
||||
207 => 'Invalid transaction date',
|
||||
208 => 'Invalid expiration date',
|
||||
209 => 'Invalid transaction code',
|
||||
210 => 'PIN key sync error',
|
||||
212 => 'Destination not available',
|
||||
251 => 'Error on cash amount',
|
||||
252 => 'Debit not supported',
|
||||
426 => 'AMEX - Denial 12',
|
||||
427 => 'AMEX - Invalid merchant',
|
||||
429 => 'AMEX - Account error',
|
||||
430 => 'AMEX - Expired card',
|
||||
431 => 'AMEX - Call Amex',
|
||||
434 => 'AMEX - Call 03',
|
||||
435 => 'AMEX - System down',
|
||||
436 => 'AMEX - Call 05',
|
||||
437 => 'AMEX - Declined',
|
||||
438 => 'AMEX - Declined',
|
||||
439 => 'AMEX - Service error',
|
||||
440 => 'AMEX - Call Amex',
|
||||
441 => 'AMEX - Amount error',
|
||||
475 => 'CREDIT CARD - Invalid expiration date',
|
||||
476 => 'CREDIT CARD - Invalid transaction, rejected',
|
||||
477 => 'CREDIT CARD - Refer Call',
|
||||
478 => 'CREDIT CARD - Decline, Pick up card, Call',
|
||||
479 => 'CREDIT CARD - Decline, Pick up card',
|
||||
480 => 'CREDIT CARD - Decline, Pick up card',
|
||||
481 => 'CREDIT CARD - Decline',
|
||||
482 => 'CREDIT CARD - Expired Card',
|
||||
483 => 'CREDIT CARD - Refer',
|
||||
484 => 'CREDIT CARD - Expired card - refer',
|
||||
485 => 'CREDIT CARD - Not authorized',
|
||||
486 => 'CREDIT CARD - CVV Cryptographic error',
|
||||
487 => 'CREDIT CARD - Invalid CVV',
|
||||
489 => 'CREDIT CARD - Invalid CVV',
|
||||
490 => 'CREDIT CARD - Invalid CVV',
|
||||
800 => 'Bad format',
|
||||
801 => 'Bad data',
|
||||
802 => 'Invalid Clerk ID',
|
||||
809 => 'Bad close ',
|
||||
810 => 'System timeout',
|
||||
811 => 'System error',
|
||||
821 => 'Bad response length',
|
||||
877 => 'Invalid PIN block',
|
||||
878 => 'PIN length error',
|
||||
880 => 'Final packet of a multi-packet transaction',
|
||||
881 => 'Intermediate packet of a multi-packet transaction',
|
||||
889 => 'MAC key sync error',
|
||||
898 => 'Bad MAC value',
|
||||
899 => 'Bad sequence number - resend transaction',
|
||||
900 => 'Capture - PIN Tries Exceeded',
|
||||
901 => 'Capture - Expired Card',
|
||||
902 => 'Capture - NEG Capture',
|
||||
903 => 'Capture - CAF Status 3',
|
||||
904 => 'Capture - Advance < Minimum',
|
||||
905 => 'Capture - Num Times Used',
|
||||
906 => 'Capture - Delinquent',
|
||||
907 => 'Capture - Over Limit Table',
|
||||
908 => 'Capture - Amount Over Maximum',
|
||||
909 => 'Capture - Capture',
|
||||
960 => 'Initialization failure - merchant number mismatch',
|
||||
961 => 'Initialization failure -pinpad mismatch',
|
||||
963 => 'No match on Poll code',
|
||||
964 => 'No match on Concentrator ID',
|
||||
965 => 'Invalid software version number',
|
||||
966 => 'Duplicate terminal name'
|
||||
);
|
||||
|
||||
# This contains a list of generic methods that take any value, and are handled
|
||||
# via AUTOLOAD.
|
||||
%NAME_MAP = (
|
||||
billing_fname => 1,
|
||||
billing_lname => 1,
|
||||
billing_company => 1,
|
||||
billing_address_1 => 1,
|
||||
billing_address_2 => 1,
|
||||
billing_city => 1,
|
||||
billing_state => 1,
|
||||
billing_postal_code => 1,
|
||||
billing_country => 1,
|
||||
billing_email => 1,
|
||||
billing_phone => 1,
|
||||
billing_fax => 1,
|
||||
billing_note => 1,
|
||||
order_id => 1,
|
||||
account_token => 1,
|
||||
account_token2 => 1
|
||||
);
|
||||
|
||||
$ERRORS = {
|
||||
CARD_NUMBER_NONE => "No credit card number entered",
|
||||
CARD_NUMBER_NUMERIC => "Credit card number is not numeric",
|
||||
CARD_NUMBER_LENGTH => "Invalid credit card number: Invalid length",
|
||||
CARD_NUMBER_INVALID => "The credit card number entered is not valid: %s",
|
||||
BRAND_NONE => "No credit card brand entered",
|
||||
BRAND_INVALID => "Credit card brand '%s' is invalid or not supported%s",
|
||||
EXPIRY_INVALID => "Invalid expiry date entered: %s",
|
||||
EXPIRY_MONTH_NONE => "Empty expiry month entered",
|
||||
EXPIRY_MONTH_NUMERIC => "Expiry month must be numeric: %s",
|
||||
EXPIRY_MONTH_INVALID => "Invalid expiry month entered: %s",
|
||||
EXPIRY_YEAR_NONE => "Empty expiry year entered",
|
||||
EXPIRY_YEAR_NUMERIC => "Expiry year must be numeric: %s",
|
||||
EXPIRY_YEAR_4_DIGIT => "Expiry year must be 4 digits: %s",
|
||||
EXPIRY_YEAR_INVALID => "Invalid expiry year entered: %s",
|
||||
TOTAL_NONE => "No total amount entered",
|
||||
TOTAL_NUMERIC => "Total amount entered is not numeric: %s",
|
||||
EMAIL_NONE => "No e-mail address entered",
|
||||
EMAIL_INVALID => "Invalid e-mail address '%s' entered: %s",
|
||||
GENERIC_NONE => "No value entered for %s",
|
||||
GENERIC_INVALID => "Invalid value '%s' for %s: %s",
|
||||
MISSING_FIELDS => "The following must be set before calling %s: %s",
|
||||
|
||||
TYPE_INVALID => "Invalid/unsupported transaction type: %s",
|
||||
|
||||
AUTHORIZE_FIRST => "You must authorize before capturing",
|
||||
CAPTURE_REF_NONE => "No capture reference ID entered",
|
||||
CAPTURE_REF_INVALID => "Invalid capture reference ID '%s': %s",
|
||||
|
||||
FIELD_MISSING => "The transaction server reported missing fields: %s",
|
||||
FIELD_INVALID => "The transaction server reported invalid data: %s",
|
||||
TRANSACTION_INVALID => "Setup problem: Invalid store information: %s",
|
||||
TRANSACTION_PROBLEM => "A transaction server error has occurred: %s",
|
||||
TRANSACTION_BAD => "You attempted to capture without authorizing first: %s",
|
||||
VERSION_TOO_OLD => "The current version of the software is outdated: %s",
|
||||
DECLINED => "Credit card declined: %s",
|
||||
ERROR => "Credit card processing error: %s",
|
||||
UNKNOWN => "The transaction server returned an unrecognized response: %s"
|
||||
};
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class if ref $class;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
$self->debug("New $class object created") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
|
||||
while (@_) {
|
||||
my ($method, $value) = splice @_, 0, 2;
|
||||
$self->debug("Found '$method' => '$value' in new() arguments - calling \$self->$method($value)") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
$self->$method($value);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
AUTOLOAD {
|
||||
my ($method) = $AUTOLOAD =~ /([^:]+)$/;
|
||||
if (exists $NAME_MAP{$method}) {
|
||||
no strict 'refs';
|
||||
*$method = sub {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $value = shift;
|
||||
$self->debug("Setting '$method' to '$value'") if $self->{_debug};
|
||||
defined $value or $self->warn(GENERIC_NONE => $method), return undef;
|
||||
$self->{$method} = $value;
|
||||
return 1;
|
||||
}
|
||||
$self->debug("Retrieving '$method': '$self->{$method}'") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $self->{$method};
|
||||
};
|
||||
}
|
||||
else {
|
||||
$method = "$ISA[0]::$method"; # Let GT::Base deal with it for now
|
||||
}
|
||||
goto &$method;
|
||||
}
|
||||
|
||||
sub credit_card_number {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $ccnum = shift;
|
||||
$self->debug("Setting 'credit_card_number' to '$ccnum'") if $self->{_debug};
|
||||
unless (defined $ccnum and $ccnum =~ /\S/) {
|
||||
$self->warn('CARD_NUMBER_NONE');
|
||||
return undef;
|
||||
}
|
||||
$ccnum =~ y/ //d;
|
||||
if ($ccnum =~ /\D/) {
|
||||
$self->warn(CARD_NUMBER_NUMERIC => $ccnum);
|
||||
return undef;
|
||||
}
|
||||
if (length($ccnum) < 13 or length($ccnum) > 20) {
|
||||
$self->warn('CARD_NUMBER_LENGTH');
|
||||
}
|
||||
$self->{credit_card_number} = $ccnum;
|
||||
return 1;
|
||||
}
|
||||
my $return = $self->{credit_card_number};
|
||||
$self->debug("Retrieving 'credit_card_number': '$return'") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $return;
|
||||
}
|
||||
|
||||
# Takes \d\d-\d\d\d\d or \d\d/\d\d\d\d,
|
||||
# passes them to credit_card_expiry_month and ..._year
|
||||
# Return 1 if they were set properly, undef otherwise.
|
||||
# Without arguments, returns: \d\d/\d\d\d\d if month and year are set, undef
|
||||
# otherwise.
|
||||
sub credit_card_expiry {
|
||||
my $self = shift;
|
||||
if (@_ >= 2) {
|
||||
my $exp = shift;
|
||||
$exp =~ y/ //d;
|
||||
if (my ($m, $y) = $exp =~ m|^(\d?\d)[/-](\d\d\d\d)$|) {
|
||||
$self->credit_card_expiry_month($m) or return undef;
|
||||
$self->credit_card_expiry_year($y) or return undef;
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
$self->warn(EXPIRY_INVALID => $exp);
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
my ($m, $y) = ($self->credit_card_expiry_month, $self->credit_card_expiry_year);
|
||||
return undef unless defined $m and defined $y;
|
||||
return "$m/$y";
|
||||
}
|
||||
|
||||
sub _cc_exp {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns the credit card expiry in YYMM format, as this is how Moneris takes
|
||||
# it.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($m, $y) = ($self->credit_card_expiry_month, $self->credit_card_expiry_year);
|
||||
return substr($y, -2) . $m;
|
||||
}
|
||||
|
||||
sub credit_card_expiry_month {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $expm = shift;
|
||||
$expm =~ y/ //d;
|
||||
defined $expm or $self->warn('EXPIRY_MONTH_NONE'), return undef;
|
||||
$expm =~ /\D/ and $self->warn(EXPIRY_MONTH_NUMERIC => $expm), return undef;
|
||||
$expm < 1 || $expm > 12 and $self->warn(EXPIRY_MONTH_INVALID => "Month '$expm' outside of 1-12 range"), return undef;
|
||||
$expm = sprintf "%02d", $expm;
|
||||
$self->debug("Setting 'credit_card_expiry_month' to '$expm'") if $self->{_debug};
|
||||
$self->{credit_card_expiry_month} = $expm;
|
||||
return 1;
|
||||
}
|
||||
my $return = $self->{credit_card_expiry_month};
|
||||
$self->debug("Retrieving 'credit_card_expiry_month': '$return'") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub credit_card_expiry_year {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $expy = shift;
|
||||
$self->debug("Setting 'credit_card_expiry_year' to '$expy'") if $self->{_debug};
|
||||
$expy =~ y/ //d;
|
||||
defined $expy or $self->warn('EXPIRY_YEAR_NONE'), return undef;
|
||||
$expy =~ /\D/ and $self->warn(EXPIRY_YEAR_NUMERIC => $expy), return undef;
|
||||
length($expy) == 4 or $self->warn(EXPIRY_YEAR_4_DIGIT => $expy), return undef;
|
||||
$self->{credit_card_expiry_year} = $expy;
|
||||
return 1;
|
||||
}
|
||||
my $return = $self->{credit_card_expiry_year};
|
||||
$self->debug("Retrieving 'credit_card_expiry_year': $return") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub charge_total {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $total = shift;
|
||||
defined $total or $self->warn('TOTAL_NONE'), return undef;
|
||||
$total =~ /^(?:\d+\.?\d*|\.\d+)$/ or $self->warn(TOTAL_NUMERIC => $total), return undef;
|
||||
$total = sprintf "%.2f", $total;
|
||||
$self->debug("Setting 'charge_total' to '$total'") if $self->{_debug};
|
||||
$self->{charge_total} = $total;
|
||||
return 1;
|
||||
}
|
||||
my $return = $self->{charge_total};
|
||||
$self->debug("Retrieving 'charge_total': '$return'") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub billing_email {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $email = shift;
|
||||
$self->debug("Setting 'billing_email' to '$email'") if $self->{_debug};
|
||||
if (!defined $email) {
|
||||
$self->warn('EMAIL_NONE');
|
||||
return undef;
|
||||
}
|
||||
if ($email !~ /.@.+\../) {
|
||||
$self->warn('EMAIL_INVALID' => $email => 'Invalid format');
|
||||
return undef;
|
||||
}
|
||||
$self->{billing_email} = $email;
|
||||
return 1;
|
||||
}
|
||||
my $return = $self->{billing_email};
|
||||
$self->debug("Retrieving 'billing_email': '$return'") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $return;
|
||||
}
|
||||
|
||||
sub billing_address {
|
||||
my $self = shift;
|
||||
my ($one, $two) = ($self->billing_address_1, $self->billing_address_2);
|
||||
return unless defined $one;
|
||||
return $two ? $one . "\n" . $two : $one;
|
||||
}
|
||||
|
||||
sub test_mode {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Test mode for Moneris involves posting to a different location
|
||||
#
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
$self->{test_mode} = !!shift;
|
||||
$self->debug(($self->{test_mode} ? "Enabling" : "Disabling") . " test mode") if $self->{_debug};
|
||||
return 1;
|
||||
}
|
||||
$self->debug("Retrieving 'test_mode': '$self->{test_mode}'") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $self->{test_mode};
|
||||
}
|
||||
|
||||
sub capture_reference_id {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
my $value = shift;
|
||||
$self->debug("Setting 'capture_reference_id' to '$value'") if $self->{_debug};
|
||||
defined $value or $self->warn('CAPTURE_REF_NONE'), return undef;
|
||||
$self->{capture_reference_id} = $value;
|
||||
return 1;
|
||||
}
|
||||
my $return;
|
||||
if ($self->{preauth_capture_reference_id}) {
|
||||
$return = $self->{preauth_capture_reference_id};
|
||||
$self->debug("Retrieving 'capture_reference_id': '$return' (from preauth response)") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
}
|
||||
else {
|
||||
$return = $self->{capture_reference_id};
|
||||
$self->debug("Retrieving 'capture_reference_id': '$return' (manually set)") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
}
|
||||
$return;
|
||||
}
|
||||
|
||||
sub _xml {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Produces the XML string to post to the Moneris eSelect server
|
||||
# Takes a single argument of either 'authorize', 'capture', or 'purchase'
|
||||
#
|
||||
my ($self, $type) = @_;
|
||||
|
||||
my $xml = '<?xml version="1.0"?>';
|
||||
$xml .= '<request>';
|
||||
$xml .= "<store_id>$self->{account_token2}</store_id>";
|
||||
$xml .= "<api_token>$self->{account_token}</api_token>";
|
||||
$xml .= $self->_xml_billing($type);
|
||||
$xml .= '</request>';
|
||||
$xml;
|
||||
}
|
||||
|
||||
my %_Billing = (
|
||||
authorize => [
|
||||
order_id => 'order_id',
|
||||
amount => 'charge_total',
|
||||
pan => 'credit_card_number',
|
||||
expdate => '_cc_exp',
|
||||
crypt_type => \7, # FIXME - 6 is "SSL - SET enabled merchant", 7 is "SSL - nonSET enabled merchant" - what is SET?
|
||||
],
|
||||
capture => [
|
||||
order_id => 'order_id',
|
||||
comp_amount => 'charge_total',
|
||||
txn_number => 'capture_reference_id',
|
||||
crypt_type => \7, # FIXME - see above
|
||||
],
|
||||
txn_type => {
|
||||
authorize => 'preauth',
|
||||
capture => 'completion',
|
||||
sale => 'purchase'
|
||||
}
|
||||
);
|
||||
$_Billing{sale} = $_Billing{authorize};
|
||||
|
||||
sub _xml_billing {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Produces the XML content for the charge portion of the transaction. This is
|
||||
# credit card information, charge amount, etc. but not billing address
|
||||
# information.
|
||||
#
|
||||
my ($self, $type) = @_;
|
||||
|
||||
my $xml = "<$_Billing{txn_type}->{$type}>";
|
||||
for (my $i = 0; $i < @{$_Billing{$type}}; $i += 2) {
|
||||
my ($key, $meth) = @{$_Billing{$type}}[$i, $i+1];
|
||||
$xml .= "<$key>" . (ref $meth ? $$meth : $self->$meth()) . "</$key>";
|
||||
}
|
||||
|
||||
$xml .= $self->_xml_custinfo($type);
|
||||
$xml .= "</$_Billing{txn_type}->{$type}>";
|
||||
$xml;
|
||||
}
|
||||
|
||||
my @_Custinfo = (
|
||||
first_name => 'billing_fname',
|
||||
last_name => 'billing_lname',
|
||||
company_name => 'billing_company',
|
||||
address => 'billing_address',
|
||||
city => 'billing_city',
|
||||
province => 'billing_state',
|
||||
postal_code => 'billing_postal_code',
|
||||
country => 'billing_country',
|
||||
phone_number => 'billing_phone',
|
||||
fax => 'billing_fax'
|
||||
);
|
||||
|
||||
|
||||
sub _xml_custinfo {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Produces the XML custinfo content. This is usually the billing address
|
||||
# information. Although not required by eSelect, this module does require and
|
||||
# pass this information.
|
||||
#
|
||||
my ($self, $type) = @_;
|
||||
my $xml = '<cust_info>';
|
||||
|
||||
if (my $email = $self->billing_email) {
|
||||
$xml .= "<email>$email</email>";
|
||||
}
|
||||
|
||||
$xml .= '<billing>';
|
||||
for (my $i = 0; $i < @_Custinfo; $i += 2) {
|
||||
my ($key, $meth) = @_Custinfo[$i, $i+1];
|
||||
my $val = $self->$meth();
|
||||
if (defined $val) {
|
||||
$xml .= "<$key>$val</$key>";
|
||||
}
|
||||
}
|
||||
$xml .= '</billing>';
|
||||
$xml .= '</cust_info>';
|
||||
|
||||
$xml;
|
||||
}
|
||||
|
||||
sub _process {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Processes a transaction. Takes a single argument - the type of transaction,
|
||||
# which must be with 'authorize', 'capture', or 'sale'.
|
||||
#
|
||||
my ($self, $type) = @_;
|
||||
$type eq 'authorize' or $type eq 'capture' or $type eq 'sale'
|
||||
or return $self->fatal(TYPE_INVALID => $type);
|
||||
|
||||
$self->{response} = undef;
|
||||
|
||||
$self->check($type) or return undef;
|
||||
|
||||
my $www = GT::WWW->new(debug => $self->{_debug});
|
||||
if ($self->{test_mode}) {
|
||||
$www->url(TEST_SERVER);
|
||||
}
|
||||
else {
|
||||
$www->url(LIVE_SERVER);
|
||||
}
|
||||
$www->connection_timeout(TIMEOUT);
|
||||
$www->post_data($self->_xml('authorize'));
|
||||
$www->agent("; GT::Payment::Direct::Moneris/$VERSION");
|
||||
|
||||
$self->debug("Posting data to @{[$self->{test_mode} ? 'test' : 'live']} server") if $self->{_debug};
|
||||
my $response = $www->post
|
||||
or return $self->warn(TRANSACTION_PROBLEM => $www->error);
|
||||
my $status = $response->status;
|
||||
|
||||
$self->debug("Server responded with status " . int($status) . " $status") if $self->{_debug};
|
||||
$status or return $self->warn(TRANSACTION_PROBLEM => "Webserver returned error code: " . int($status) . " $status");
|
||||
|
||||
return $self->_parse_response($response->content);
|
||||
}
|
||||
|
||||
# Attempts to authorize. You'll get back three possible values:
|
||||
# 1 - Authorization successful, funds guaranteed - capture should now be performed
|
||||
# 0 - Authorization declined
|
||||
# undef - An error occurred
|
||||
sub authorize {
|
||||
my $self = shift;
|
||||
$self->debug("Performing authorization") if $self->{_debug};
|
||||
|
||||
my $ret = $self->_process('authorize');
|
||||
if ($ret) { $self->{preauth_capture_reference_id} = $self->{response}->{TransID} }
|
||||
elsif (defined $ret) {
|
||||
my $code = $self->{response}->{ResponseCode};
|
||||
$self->warn(DECLINED => ($code and $RESPONSE{int $code} or $self->{response}->{Message}));
|
||||
}
|
||||
else { $self->warn(ERROR => $self->{response}->{Message}) }
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub capture {
|
||||
my $self = shift;
|
||||
$self->debug("Performing authorization") if $self->{_debug};
|
||||
|
||||
my $ret = $self->_process('capture');
|
||||
if (!defined $ret) { $self->warn(ERROR => $self->{response}->{Message}) }
|
||||
elsif (!$ret) {
|
||||
my $code = $self->{response}->{ResponseCode};
|
||||
$self->warn(DECLINED => ($code and $RESPONSE{int $code} or $self->{response}->{Message}));
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub sale {
|
||||
my $self = shift;
|
||||
$self->debug("Performing sale") if $self->{_debug};
|
||||
|
||||
my $ret = $self->_process('sale');
|
||||
if (!defined $ret) { $self->warn(ERROR => $self->{response}->{Message}) }
|
||||
elsif (!$ret) {
|
||||
my $code = $self->{response}->{ResponseCode};
|
||||
$self->warn(DECLINED => ($code and $RESPONSE{int $code} or $self->{response}->{Message}));
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub _parse_response {
|
||||
my ($self, $content) = @_;
|
||||
|
||||
my (%r, @stack);
|
||||
$self->{response} = \%r;
|
||||
|
||||
while ($content =~ m{<(/)?([^<>]+)>|([^<>]+)}g) {
|
||||
my ($slash, $tag, $value) = ($1, $2, $3);
|
||||
if ($slash) {
|
||||
pop @stack;
|
||||
}
|
||||
elsif (defined $tag) {
|
||||
push @stack, $tag;
|
||||
}
|
||||
elsif ($value =~ /\S/) {
|
||||
$value = undef if $value eq 'null';
|
||||
$r{$stack[-1]} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
my $ret;
|
||||
if (not defined $r{ResponseCode}) {
|
||||
$ret = undef;
|
||||
}
|
||||
elsif ($r{ResponseCode} < 50) {
|
||||
$ret = 1;
|
||||
}
|
||||
else {
|
||||
$ret = 0;
|
||||
}
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub check {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Checks that all necessary data is provided for an authorize, capture, or
|
||||
# sale. Takes one argument - 'authorize', 'capture', or 'sale', though 'sale'
|
||||
# is really no different from 'authorize'.
|
||||
#
|
||||
my ($self, $type) = @_;
|
||||
|
||||
$type = 'authorize' if $type eq 'sale';
|
||||
$type eq 'authorize' or $type eq 'capture'
|
||||
or return $self->fatal(TYPE_INVALID => $type);
|
||||
|
||||
my @bad;
|
||||
for my $field (@{$REQUIRED{uc $type}}) {
|
||||
my $value = $self->$field();
|
||||
if ($field eq 'charge_total') {
|
||||
push @bad, $field if $value <= 0;
|
||||
}
|
||||
else {
|
||||
push @bad, $field if !$value;
|
||||
}
|
||||
}
|
||||
if (@bad) {
|
||||
$self->warn(MISSING_FIELDS => $type => "@bad");
|
||||
return undef;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub receipt {
|
||||
# -----------------------------------------------------------------------------
|
||||
# After a successful sale, you can call this to get a list of Key => Value
|
||||
# pairs that make up a rough receipt. The keys are ordered, so reading them
|
||||
# into an array probably makes more sense than a hash.
|
||||
#
|
||||
my $self = shift;
|
||||
my $r = $self->{response} or return;
|
||||
my @receipt;
|
||||
my $code = $r->{ResponseCode};
|
||||
push @receipt,
|
||||
"Order ID" => $self->order_id,
|
||||
"Amount" => $r->{TransAmount},
|
||||
"Status" => ($code and $RESPONSE{int $code} or $self->{response}->{Message}),
|
||||
"Transaction Type" => $r->{TransType},
|
||||
"Date" => $r->{TransDate},
|
||||
"Auth Code" => $r->{AuthCode},
|
||||
"Response Code" => $code,
|
||||
"Response Message" => $r->{Message},
|
||||
"ISO Code" => $r->{ISO},
|
||||
"Reference Number" => $r->{ReferenceNum},
|
||||
"Cardholder Name" => $self->billing_fname . " " . $self->billing_lname;
|
||||
|
||||
return @receipt;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,317 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Payment::Remote::2CheckOut
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: 2CheckOut.pm,v 1.5 2006/08/22 20:39:04 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# 2CheckOut payment processing.
|
||||
#
|
||||
|
||||
package GT::Payment::Remote::2CheckOut;
|
||||
use strict;
|
||||
use Carp;
|
||||
use GT::MD5 'md5_hex';
|
||||
require Exporter;
|
||||
use vars qw/@EXPORT_OK/;
|
||||
@EXPORT_OK = qw/process/;
|
||||
|
||||
sub process {
|
||||
# -----------------------------------------------------------------------------
|
||||
shift if $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
|
||||
my %opts = @_;
|
||||
$opts{param} and UNIVERSAL::isa($opts{param}, 'GT::CGI') or croak 'Usage: ->process(param => $gtcgi, ...)';
|
||||
my $in = $opts{param};
|
||||
|
||||
ref $opts{on_valid} eq 'CODE'
|
||||
or croak 'Usage: ->process(on_valid => \&CODEREF, ...)';
|
||||
|
||||
defined $opts{password} and length $opts{password} or croak 'Usage: ->process(password => "password", ...)';
|
||||
defined $opts{sellerid} and length $opts{sellerid} or croak 'Usage: ->process(sellerid => "sellerid", ...)';
|
||||
|
||||
$opts{password} eq 'tango' and croak 'Usage: ->process(password => "something other than \'tango\'", ...)';
|
||||
|
||||
my $order_number = $in->param('order_number');
|
||||
|
||||
# Check that the "secret word" (password) combined with the other information
|
||||
# actually checks out.
|
||||
my $str = $opts{password} . $opts{sellerid} . $order_number . $in->param('total');
|
||||
my $md5 = md5_hex($str);
|
||||
|
||||
if (lc $md5 eq lc $in->param('key')) {
|
||||
$opts{on_valid}->();
|
||||
}
|
||||
# If demo mode is enabled, then the order number is set to 1 in the md5:
|
||||
# https://www.2checkout.com/documentation/UsersGuide2/chapter6/md5-hash.html
|
||||
elsif ($opts{demo}) {
|
||||
$str = $opts{password} . $opts{sellerid} . 1 . $in->param('total');
|
||||
$md5 = md5_hex($str);
|
||||
|
||||
if (lc $md5 eq lc $in->param('key')) {
|
||||
$opts{on_valid}->();
|
||||
}
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Payment::Remote::2CheckOut - 2CheckOut payment handling
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
2CheckOut has a pretty weak automated payment system - the security of the
|
||||
entire automated payment process hinges on your "Secret Word" (Admin -> Account
|
||||
Details -> Return -> Secret Word (near the bottom of the page)) - without it,
|
||||
there is no security at all. Another weakness in the system is that if your
|
||||
server is not reachable for whatever reason, the payment information would be
|
||||
lost. Payment providers like 2CheckOut and WorldPay would do well to learn
|
||||
from payment systems like that of PayPal - whatever can be said about other
|
||||
aspects of PayPal, they do have one of the nicest payment systems around - both
|
||||
from a developer and user's point of view.
|
||||
|
||||
Because of the security issue with not using the "Secret Word", this module
|
||||
requires that the secret word be used, even if other 2CheckOut systems may not.
|
||||
Additionally, the default secret word of "tango" is not allowed.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Payment::Remote::2CheckOut;
|
||||
use GT::CGI;
|
||||
|
||||
my $in = new GT::CGI;
|
||||
|
||||
GT::Payment::Remote::2CheckOut->process(
|
||||
param => $in,
|
||||
|
||||
on_valid => \&valid,
|
||||
|
||||
sellerid => "1234",
|
||||
password => "Some Good Secret Word"
|
||||
);
|
||||
|
||||
sub valid {
|
||||
# Update database - the payment has been made successfully.
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is designed to handle 2CheckOut payment processing.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
GT::CGI and GT::MD5.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
This module has only one function: process() does the work of actually
|
||||
figuring out what to do with a postback.
|
||||
|
||||
=head2 process
|
||||
|
||||
process() is the only function provided by this module. It can be called as
|
||||
either a function or class method, and takes a hash (not hash reference) of
|
||||
arguments as described below.
|
||||
|
||||
process() should be called for 2CheckOut initiated postbacks. This can be set
|
||||
up in your main .cgi by looking for 2CheckOut-specific CGI parameters
|
||||
('cart_order_id' is a good one to look for) or by making a seperate .cgi file
|
||||
exclusively for handling 2CheckOut postbacks.
|
||||
|
||||
Additionally, it is strongly advised that database connection, authenticate,
|
||||
etc. be performed before calling process() to ensure that the payment is
|
||||
recorded successfully. 2CheckOut will not attempt to repost the form data if
|
||||
your script produces an error, and the error will be shown to the customer.
|
||||
|
||||
=over 4
|
||||
|
||||
=item param
|
||||
|
||||
param takes a GT::CGI object from which 2CheckOut postback variables are read.
|
||||
|
||||
=item on_valid
|
||||
|
||||
on_valid takes a code reference as value. The code reference will be called
|
||||
when a successful payment has been made. Inside this code reference you are
|
||||
responsible for setting a "paid" status for the order in question. The
|
||||
C<cart_order_id> CGI variable will have whatever cart_order_id you provided.
|
||||
|
||||
=item sellerid
|
||||
|
||||
This should be passed to seller number. This is needed, along with the
|
||||
password field below, to verify that the posted payment is a genuine 2CheckOut
|
||||
payment.
|
||||
|
||||
=item password
|
||||
|
||||
This is a "Secret Word" that the admin must set in the 2CheckOut admin area
|
||||
(under Look & Feel -> Secret Word). This field must be set in the admin, and
|
||||
passed in here. Note that the default value, "tango", is not allowed. Without
|
||||
this password, 2CheckOut postbacks should not be considered secure.
|
||||
|
||||
=item demo
|
||||
|
||||
Whether or not to initiate and accept demo transactions.
|
||||
|
||||
=back
|
||||
|
||||
=head1 INSTRUCTIONS
|
||||
|
||||
To implement 2CheckOut payment processing, there are a number of steps required
|
||||
in addition to this module. Basically, this module handles only the postback
|
||||
stage of the 2CheckOut payment process.
|
||||
|
||||
=head2 Directing customers to 2CheckOut
|
||||
|
||||
This is done by creating a web form containing the following variables. Your
|
||||
form, first of all, should post to
|
||||
C<https://www.2checkout.com/2co/buyer/purchase>. See
|
||||
C<https://www.2checkout.com/documentation/UsersGuide2/third_party_carts/2co-system-parameters.html>
|
||||
for a complete and up-to-date list of parameters that can be passed to 2CheckOut.
|
||||
|
||||
Required fields are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * sid
|
||||
|
||||
Your 2CheckOut account number
|
||||
|
||||
=item * total
|
||||
|
||||
The total amount to be billed, in DD.CC format.
|
||||
|
||||
=item * cart_order_id
|
||||
|
||||
A unique order id, which you should store to track the payment.
|
||||
|
||||
=back
|
||||
|
||||
The following parameters *may* be passed in, and will be available in the
|
||||
postback:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * card_holder_name
|
||||
|
||||
=item * street_address
|
||||
|
||||
=item * city
|
||||
|
||||
=item * state
|
||||
|
||||
=item * zip
|
||||
|
||||
=item * country
|
||||
|
||||
=item * phone
|
||||
|
||||
The card holder's details.
|
||||
|
||||
=item * email
|
||||
|
||||
The card holder's email address.
|
||||
|
||||
=item * ship_name
|
||||
|
||||
=item * ship_street_address
|
||||
|
||||
=item * ship_city
|
||||
|
||||
=item * ship_state
|
||||
|
||||
=item * ship_zip
|
||||
|
||||
=item * ship_country
|
||||
|
||||
Shipping info - however, according to 2CheckOut, you must indicate that you
|
||||
want to take that you want to take down a seperate shipping and billing address
|
||||
on the L<Shipping Details page|https://sellers.2checkout.com/cgi-bin/sellersarea/shipdetails.2c>.
|
||||
|
||||
=item * demo
|
||||
|
||||
Should be set to 'Y' if you want demo mode, omitted for regular transactions.
|
||||
|
||||
=back
|
||||
|
||||
In the postback CGI, you'll get back all of the billing and shipping variables
|
||||
listed above, plus:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * order_number
|
||||
|
||||
2CheckOut order number
|
||||
|
||||
=item * cart_order_id
|
||||
|
||||
=item * cart_id
|
||||
|
||||
Your order number, passed back. Both variables are the same.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Postback
|
||||
|
||||
Before 2CheckOut postback notification can occur, you must set up the postback
|
||||
(in 2CheckOut terminology, "Routine"). This can be set from the Admin ->
|
||||
Shopping Cart -> Cart Details. You need to enable the payment routine, and
|
||||
set it to a CGI that you manage.
|
||||
|
||||
=head2 Putting it all together
|
||||
|
||||
The typical way to implement all of this is as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1 Get necessary merchant information (sid and secret keyword)
|
||||
|
||||
=item 2 Once the customer has selected what to purchase, generate a
|
||||
cart_order_id (a random MD5 hex string works well), and store it somewhere
|
||||
(i.e. in the database).
|
||||
|
||||
=item 3 Make a form with all the necessary fields that
|
||||
L<submits to 2CheckOut|/"Directing customers to 2CheckOut">.
|
||||
|
||||
=item 4 Set up the L<C<on_valid>|/"on_valid"> callback. If using a dedicated
|
||||
CGI script for 2CheckOut callbacks, it should just call process(); otherwise,
|
||||
check for the CGI parameter 'cart_order_id' and if present, call process().
|
||||
|
||||
=item 5 For a valid payment, do whatever you need to do for a valid payment,
|
||||
and store some record of the payment having been made (storing at least the
|
||||
cart_order_id and the order_number is strongly recommended). Use the CGI
|
||||
parameter 'cart_order_id' to locate the order (i.e. in the database).
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<http://www.2checkout.com> - 2CheckOut website.
|
||||
|
||||
L<http://www.support.2checkout.com/deskpro/faq.php> - 2CheckOut knowledgebase
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: 2CheckOut.pm,v 1.5 2006/08/22 20:39:04 brewt Exp $
|
||||
|
||||
=cut
|
||||
573
site/slowtwitch.com/cgi-bin/articles/GT/Payment/Remote/PayPal.pm
Normal file
573
site/slowtwitch.com/cgi-bin/articles/GT/Payment/Remote/PayPal.pm
Normal file
@ -0,0 +1,573 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Payment::Remote::PayPal
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: PayPal.pm,v 1.8 2006/04/08 03:42:05 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# PayPal IPN payment processing.
|
||||
# IPN information: (PayPal login required)
|
||||
# https://www.paypal.com/cgi-bin/webscr?cmd=p/acc/ipn-info
|
||||
#
|
||||
# Net::SSLeay is required. Windows (ActivePerl) Net::SSLeay packages are
|
||||
# available through Gossamer Threads.
|
||||
#
|
||||
|
||||
package GT::Payment::Remote::PayPal;
|
||||
use strict;
|
||||
use Carp;
|
||||
use GT::WWW;
|
||||
use GT::WWW::https;
|
||||
|
||||
# Usage:
|
||||
# process(
|
||||
# param => $GT_CGI_OBJ,
|
||||
# on_valid => \&CODEREF, # Called when everything checks out
|
||||
# on_pending => \&CODEREF, # Optional - another IPN request will come in when no longer pending
|
||||
# on_failed => \&CODEREF, # "The payment has failed. This will only happen if the payment was made from your customer's bank account"
|
||||
# on_denied => \&CODEREF, # "You, the merchant, denied the payment. This will only happen if the payment was previously pending due to one of the "pending reasons" below"
|
||||
# on_invalid => \&CODEREF, # This request did NOT come from PayPal
|
||||
# on_recurring => \&CODEREF, # A recurring payment
|
||||
# on_recurring_signup => \&CODEREF, # A recurring payment signup
|
||||
# on_recurring_cancel => \&CODEREF, # A recurring payment cancellation
|
||||
# on_recurring_failed => \&CODEREF, # A subscription payment failure
|
||||
# on_recurring_eot => \&CODEREF, # A subscription "end of term" notification
|
||||
# on_recurring_modify => \&CODEREF, # A subscription modification notification
|
||||
# duplicate => \&CODEREF, # Check to make sure this isn't a duplicate (1 = okay, 0/undef = duplicate)
|
||||
# email => \&CODEREF, # Called with the specified e-mail - check it against the primary e-mail account, return 1 for valid, 0/undef for error
|
||||
# on_error => \&CODEREF # Optional
|
||||
# )
|
||||
# Only on_error is optional. on_valid will be called if the request is valid,
|
||||
# on_invalid is invalid, and on_error if an error occurs (such as an HTTP error,
|
||||
# connection problem, etc.)
|
||||
sub process {
|
||||
shift if $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
|
||||
my %opts = @_;
|
||||
$opts{param} and UNIVERSAL::isa($opts{param}, 'GT::CGI') or croak 'Usage: ->process(param => $gtcgi, ...)';
|
||||
my $in = $opts{param};
|
||||
for (qw/on_valid on_failed on_denied duplicate email/) {
|
||||
ref $opts{$_} eq 'CODE' or croak "Usage: ->process($_ => \&CODEREF, ...)";
|
||||
}
|
||||
|
||||
for (qw/on_error on_pending on_invalid on_recurring on_recurring_signup on_recurring_cancel
|
||||
on_recurring_failed on_recurring_eot on_recurring_modify/) {
|
||||
!$opts{$_} or ref $opts{$_} eq 'CODE' or croak "Usage: ->process($_ => \\&CODEREF, ...) (optional)";
|
||||
}
|
||||
|
||||
my $sandbox = $opts{sandbox} ? 'sandbox.' : '';
|
||||
my $wwws = GT::WWW->new("https://www.${sandbox}paypal.com/cgi-bin/webscr");
|
||||
my @param;
|
||||
|
||||
for my $p ($in->param) {
|
||||
for my $v ($in->param($p)) {
|
||||
push @param, $p, $v;
|
||||
}
|
||||
}
|
||||
|
||||
# PayPal says:
|
||||
# You will also need to append a variable named "cmd" with the value
|
||||
# "_notify-validate" (e.g. cmd=_notify-validate) to the POST string.
|
||||
$wwws->parameters(@param, cmd => '_notify-validate');
|
||||
|
||||
my $result = $wwws->post;
|
||||
my $status;
|
||||
|
||||
# PayPal says:
|
||||
# PayPal will respond to the post with a single word, "VERIFIED" or
|
||||
# "INVALID", in the body of the response. When you receive a VERIFIED
|
||||
# response, you need to:
|
||||
#
|
||||
# * Check that the "payment_status" is "completed"
|
||||
# * If the "payment_status" is "completed", check the "txn_id" against
|
||||
# the previous PayPal transaction you have processed to ensure it is
|
||||
# not a duplicate.
|
||||
# * After you have checked the "payment_status" and "txn_id", make sure
|
||||
# the "receiver_email" is an email address registered in your PayPal
|
||||
# account
|
||||
# * Once you have completed the above checks, you may update your
|
||||
# database based on the information provided.
|
||||
if ($result) {
|
||||
my $status = "$result";
|
||||
unless ($status eq 'VERIFIED') {
|
||||
$opts{on_invalid}->($status) if $opts{on_invalid};
|
||||
return;
|
||||
}
|
||||
|
||||
# For certain txn_types payment_status and txn_id aren't available
|
||||
my $txn_type = $in->param('txn_type');
|
||||
if ($txn_type =~ /^subscr_(?:signup|cancel|failed|eot|modify)$/) {
|
||||
if ($txn_type eq 'subscr_signup') {
|
||||
$opts{on_recurring_signup}->() if $opts{on_recurring_signup};
|
||||
}
|
||||
elsif ($txn_type eq 'subscr_cancel') {
|
||||
$opts{on_recurring_cancel}->() if $opts{on_recurring_cancel};
|
||||
}
|
||||
elsif ($txn_type eq 'subscr_failed') {
|
||||
$opts{on_recurring_failed}->() if $opts{on_recurring_failed};
|
||||
}
|
||||
elsif ($txn_type eq 'substr_eot') {
|
||||
$opts{on_recurring_eot}->() if $opts{on_recurring_eot};
|
||||
}
|
||||
elsif ($txn_type eq 'substr_modify') {
|
||||
$opts{on_recurring_modify}->() if $opts{on_recurring_modify};
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
# * Check that the "payment_status" is "completed" [sic; should be "Completed"]
|
||||
unless ((my $status = $in->param('payment_status')) eq 'Completed') {
|
||||
if ($status eq 'Pending') {
|
||||
$opts{on_pending}->() if $opts{on_pending};
|
||||
}
|
||||
elsif ($status eq 'Failed') {
|
||||
$opts{on_failed}->();
|
||||
}
|
||||
elsif ($status eq 'Denied') {
|
||||
$opts{on_denied}->();
|
||||
}
|
||||
elsif ($status eq 'Refunded') {
|
||||
$opts{on_refund}->() if $opts{on_refund};
|
||||
}
|
||||
elsif ($opts{on_error}) {
|
||||
$opts{on_error}->("PayPal sent invalid/unknown payment_status value: '$status'");
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
my $txn_id = $in->param('txn_id');
|
||||
return unless $txn_id;
|
||||
|
||||
# * If the "payment_status" is "completed", check the "txn_id" against
|
||||
# the previous PayPal transaction you have processed to ensure it is
|
||||
# not a duplicate.
|
||||
$opts{duplicate}->($txn_id) or return;
|
||||
|
||||
# * After you have checked the "payment_status" and "txn_id", make sure
|
||||
# the "receiver_email" is an email address registered in your PayPal
|
||||
# account
|
||||
$opts{email}->($in->param('receiver_email')) or return; # Ignore if the e-mail addresses don't match
|
||||
|
||||
if ($txn_type eq 'subscr_payment') {
|
||||
$opts{on_recurring}->() if $opts{on_recurring};
|
||||
}
|
||||
else {
|
||||
$opts{on_valid}->();
|
||||
}
|
||||
}
|
||||
elsif ($opts{on_error}) {
|
||||
if (defined $result) {
|
||||
my $http_status = $result->status;
|
||||
$opts{on_error}->("Server returned a non-okay status: " . int($http_status) . " $http_status");
|
||||
}
|
||||
else {
|
||||
$opts{on_error}->("Connection error: " . $wwws->error);
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Payment::Remote::PayPal - PayPal payment handling
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Payment::Remote::PayPal;
|
||||
use GT::CGI;
|
||||
|
||||
my $in = new GT::CGI;
|
||||
|
||||
GT::Payment::Remote::PayPal->process(
|
||||
param => $in,
|
||||
on_valid => \&valid,
|
||||
on_pending => \&pending,
|
||||
on_failed => \&failed,
|
||||
on_denied => \&denied,
|
||||
on_invalid => \&invalid,
|
||||
on_recurring => \&recurring,
|
||||
on_recurring_signup => \&r_signup,
|
||||
on_recurring_cancel => \&r_cancel,
|
||||
on_recurring_failed => \&r_failed,
|
||||
on_recurring_eot => \&r_eot,
|
||||
on_recurring_modify => \&r_modify,
|
||||
duplicate => \&duplicate,
|
||||
email => \&email,
|
||||
on_error => \&error
|
||||
);
|
||||
|
||||
sub valid {
|
||||
# Update database - the payment has been made successfully.
|
||||
}
|
||||
sub pending {
|
||||
# Optional; store a "payment pending" status if you wish. This is optional
|
||||
# because another postback will be made with a completed, failed, or denied
|
||||
# status.
|
||||
}
|
||||
failed {
|
||||
# According to PayPal IPN documentation: "The payment has failed. This
|
||||
# will only happen if the payment was made from your customer's bank
|
||||
# account."
|
||||
# Store a "payment failed" status for the order
|
||||
}
|
||||
sub denied {
|
||||
# According to PayPal IPN documentation: "You, the merchant, denied the
|
||||
# payment. This will only happen if the payment was previously pending due
|
||||
# to one of the "pending reasons" [in pending_reason]"
|
||||
}
|
||||
sub invalid {
|
||||
# This means the request did NOT come from PayPal. You should log the
|
||||
# request for follow up.
|
||||
}
|
||||
sub recurring {
|
||||
# This means a recurring payment has been made successfully. Update
|
||||
# database.
|
||||
}
|
||||
sub r_signup {
|
||||
# This means a recurring signup has been made (NOT a payment, just a
|
||||
# signup).
|
||||
}
|
||||
sub r_cancel {
|
||||
# The user has cancelled their recurring payment
|
||||
}
|
||||
sub r_failed {
|
||||
# A recurring payment has failed (probably declined).
|
||||
}
|
||||
sub r_eot {
|
||||
# A recurring payment has come to its natural conclusion. This only
|
||||
# applies to payments with a set number of payments.
|
||||
}
|
||||
sub r_modify {
|
||||
# Something has been modified regarding the recurring payment
|
||||
}
|
||||
sub duplicate {
|
||||
# Check to see if the payment has already been made. If it _has_ been
|
||||
# made, you should return undef, otherwise return 1 to indicate that this
|
||||
# is not a duplicate postback. The "txn_id" value is passed in, but is
|
||||
# also available through $in->param('txn_id').
|
||||
}
|
||||
sub email {
|
||||
# This will be called with an e-mail address. You should check to make
|
||||
# sure that the e-mail address entered is the same as the one on the PayPal
|
||||
# account. Return true (1) if everything checks out, undef otherwise.
|
||||
}
|
||||
sub error {
|
||||
# An error message is passed in here. This is called when a error such as
|
||||
# a connection problem or HTTP problem occurs.
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is designed to handle PayPal payment processing using PayPal's IPN
|
||||
system. It does very little other than generating and sending a proper
|
||||
response to the PayPal server, and calling the provided code reference(s).
|
||||
|
||||
It is strongly recommended that you familiarize yourself with the PayPal
|
||||
"Single Item Purchases Manual" and "IPN Manual" listed in the L</"SEE ALSO">
|
||||
section of this document.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
GT::WWW with the https protocol, which in turn requires Net::SSLeay. PPM's are
|
||||
available from Gossamer Threads for the latest Windows releases of ActiveState
|
||||
Perl 5.6.1 and 5.8.0.
|
||||
|
||||
=head1 process
|
||||
|
||||
process() is the only function/method provided by this module. It can be
|
||||
called as either a function or class method, and takes a hash (not hash
|
||||
reference) of arguments as described below. This module requires GT::WWW's
|
||||
https interface, which in turn requires Net::SSLeay.
|
||||
|
||||
process() should be called for PayPal initiated requests. This can be set up
|
||||
in your main CGI by looking for PayPal-specific CGI parameters ('txn_type' is a
|
||||
good one to look for) or by making a seperate .cgi file exclusively for
|
||||
handling IPN postbacks.
|
||||
|
||||
Additionally, it is strongly advised that database connection, authenticate,
|
||||
etc. be performed before calling process() to ensure that the payment is
|
||||
recorded successfully. If your CGI script has an error, PayPal will retry the
|
||||
postback again
|
||||
|
||||
Except where indicated, all arguments are required.
|
||||
|
||||
=head2 param
|
||||
|
||||
param takes a GT::CGI object from which PayPal IPN variables are read.
|
||||
|
||||
=head2 on_valid
|
||||
|
||||
on_valid takes a code reference as value. The code reference will be called
|
||||
when a successful payment has been made. Inside this code reference you are
|
||||
responsible for setting a "paid" status for the order in question.
|
||||
|
||||
See the PayPal IPN documentation listed below for information on how to
|
||||
identify an order.
|
||||
|
||||
=head2 on_pending
|
||||
|
||||
on_pending is called when PayPal sends information on a "Pending" payment.
|
||||
This parameter is optional, due to the fact that a "Pending" status means that
|
||||
another notification (either "Completed", "Failed", or "Denied") will be made.
|
||||
|
||||
It is, however, recommended that when a Pending payment is encountered, a note
|
||||
be stored in your application that manual intervention is probably required.
|
||||
|
||||
According to PayPal documentation, there are a few cases where this will
|
||||
happen, which can be obtained from the "pending_reason" CGI input variable.
|
||||
The possible values and what each means follows (this comes straight from the
|
||||
PayPal documentation).
|
||||
|
||||
=over 4
|
||||
|
||||
=item "echeck"
|
||||
|
||||
The payment is pending because it was made by an eCheck, which has not yet
|
||||
cleared.
|
||||
|
||||
=item "multi_currency"
|
||||
|
||||
You do not have a balance in the currency sent, and you do not have your
|
||||
Payment Receiving Preferences set to automatically convert and accept this
|
||||
payment. You must manually accept or deny this payment.
|
||||
|
||||
=item "intl"
|
||||
|
||||
The payment is pending because you, the merchant, hold an international account
|
||||
and do not have a withdrawal mechanism. You must manually accept or deny this
|
||||
payment from your Account Overview.
|
||||
|
||||
=item "verify"
|
||||
|
||||
The payment is pending because you, the merchant, are not yet verified. You
|
||||
must verify your account before you can accept this payment.
|
||||
|
||||
=item "address"
|
||||
|
||||
The payment is pending because your customer did not include a confirmed
|
||||
shipping address and you, the merchant, have your Payment Receiving Preferences
|
||||
set such that you want to manually accept or deny each of these payments. To
|
||||
change your preference, go to the "Preferences" section of your "Profile."
|
||||
|
||||
=item "upgrade"
|
||||
|
||||
The payment is pending because it was made via credit card and you, the
|
||||
merchant, must upgrade your account to Business or Premier status in order to
|
||||
receive the funds.
|
||||
|
||||
=item "unilateral"
|
||||
|
||||
The payment is pending because it was made to an email address that is not yet
|
||||
registered or confirmed.
|
||||
|
||||
=item "other"
|
||||
|
||||
The payment is pending for an "other" reason. For more information, contact
|
||||
customer service.
|
||||
|
||||
=back
|
||||
|
||||
=head2 on_failed
|
||||
|
||||
Takes a code reference to call in the event of a failed payment notification.
|
||||
A failed payment "will only happen if the payment was made from your customer's
|
||||
bank account."
|
||||
|
||||
You should record a failed payment in your application.
|
||||
|
||||
=head2 on_denied
|
||||
|
||||
This code reference is called when a "Denied" payment notification is received.
|
||||
"This will only happen if the payment was previously pending due to one of the
|
||||
'pending reasons'" above.
|
||||
|
||||
You should record a failed or denied payment in your application.
|
||||
|
||||
=head2 on_invalid
|
||||
|
||||
This code reference will be called when an invalid request is made. This
|
||||
usually means that the request B<did not> come from PayPal. According to
|
||||
PayPal, "if you receive an 'INVALID' notification, it should be treated as
|
||||
suspicious and investigated." Thus it is strongly recommended that a record of
|
||||
the invalid request be made.
|
||||
|
||||
=head2 duplicate
|
||||
|
||||
This code reference is required to prevent duplicate payments. It is called
|
||||
for potentially successful requests to ensure that it is not a duplicate
|
||||
postback. It is passed the "txn_id" CGI parameter, which is the
|
||||
PayPal-generated transaction ID. You should check this parameter against your
|
||||
order database. If you have already recorded this payment as successfully
|
||||
made, should should return C<undef> from this function, to indicate that the
|
||||
duplicate check failed. If the transaction ID is okay (i.e. is not a
|
||||
duplicate) return 1 to continue.
|
||||
|
||||
=head2 recurring
|
||||
|
||||
A successful recurring payment has been made. You should set a "paid" status
|
||||
for the item in question.
|
||||
|
||||
=head2 recurring_signup
|
||||
|
||||
=head2 recurring_cancel
|
||||
|
||||
=head2 recurring_failed
|
||||
|
||||
=head2 recurring_eot
|
||||
|
||||
=head2 recurring_modify
|
||||
|
||||
These are called when various things have happened to the subscription. In
|
||||
particular, signup refers to a new subscription, cancel refers to a cancelled
|
||||
subscription, failed refers to a failed payment, eot refers to a subscription
|
||||
that ended naturally (i.e. an end was set when the subscription was initially
|
||||
made), and modify is called when a payment has been modified.
|
||||
|
||||
=head2 email
|
||||
|
||||
This code reference, like duplicate, is called to ensure that the payment was
|
||||
sent to the correct account. An e-mail address is passed in which must be the
|
||||
same as the primary account's e-mail address. If it is the same, return C<1>.
|
||||
If it is I<not> the same, you should return C<undef> and store a note asking
|
||||
the user to check that the PayPal e-mail address they have provided is the
|
||||
correct, primary, PayPal e-mail address.
|
||||
|
||||
=head2 on_error
|
||||
|
||||
This code reference is optional, but recommended. It is called when a
|
||||
non-PayPal generated error occurs - such as a failure to connect to PayPal. It
|
||||
is recommended that you provide this code reference and log any errors that
|
||||
occur. The error message is passed in.
|
||||
|
||||
=head1 INSTRUCTIONS
|
||||
|
||||
To implement PayPal payment processing, there are a number of steps required in
|
||||
addition to this module. Basically, this module handles only the postback
|
||||
stage of the PayPal IPN process.
|
||||
|
||||
Full PayPal single item, subscription, and IPN documentation is available at
|
||||
the URL's listed in the L<SEE ALSO|/"SEE ALSO"> section.
|
||||
|
||||
=head2 Directing customers to PayPal
|
||||
|
||||
This is done by creating a web form containing the following variables. Your
|
||||
form, first of all, must post to C<https://www.paypal.com/cgi-bin/webscr>.
|
||||
|
||||
Your form should contains various PayPal parameters, as outlined in the PayPal
|
||||
manuals linked to in the L<SEE ALSO|/"SEE ALSO"> section.
|
||||
|
||||
Of particular note is the "notify_url" option, which should be used to specify
|
||||
a postback URL for PayPal IPN postbacks.
|
||||
The below is simply a list of the required fields, and only those fields that
|
||||
are absolutely required are described. For descriptions of each field, check
|
||||
the PayPal Single Item Purchases Manual.
|
||||
|
||||
=over 4
|
||||
|
||||
=item cmd
|
||||
|
||||
Must be set to "_xclick".
|
||||
|
||||
=item business
|
||||
|
||||
Your PayPal ID (e-mail address). Must be confirmed and linked to your Verified
|
||||
Business or Premier account.
|
||||
|
||||
=item item_name
|
||||
|
||||
=item item_number
|
||||
|
||||
=item image_url
|
||||
|
||||
=item no_shipping
|
||||
|
||||
|
||||
=item return
|
||||
|
||||
Although optional, this is highly recommend - takes a URL to bring the buyer
|
||||
back to after purchasing. If not specified, they'll remain at PayPal.
|
||||
|
||||
=item rm
|
||||
|
||||
Return method for the L<return|/return> option. If "1", a GET request without
|
||||
the transaction variables will be made, if "2" a POST request WITH the transaction
|
||||
variables will be made.
|
||||
|
||||
=item cancel_return
|
||||
|
||||
=item no_note
|
||||
|
||||
=item cn
|
||||
|
||||
=item cs
|
||||
|
||||
=item on0
|
||||
|
||||
=item on1
|
||||
|
||||
=item os0
|
||||
|
||||
=item os1
|
||||
|
||||
=item quantity
|
||||
|
||||
The quantity of items being purchased. If omitted, defaults to 1 and will not
|
||||
be shown in the payment flow.
|
||||
|
||||
=item undefined_quantity
|
||||
|
||||
"If set to "1", the user will be able to edit the quantity. This means your
|
||||
customer will see a field next to quantity which they must complete. This is
|
||||
optional; if omitted or set to "0", the quantity will not be editable by the
|
||||
user. Instead, it will default to 1"
|
||||
|
||||
=item shipping
|
||||
|
||||
=back
|
||||
|
||||
=head2 IPN
|
||||
|
||||
Before PayPal payment notification can occur, you must instruct the user to
|
||||
enable Instant Payment Notification (IPN) on their PayPal account. The
|
||||
postback URL should be provided and handled by you either by detecting a PayPal
|
||||
request in your main .cgi script (recommended), or through the use of an
|
||||
additional .cgi script exclusively for PayPal IPN.
|
||||
|
||||
If adding to your existing script, it is recommended to look for the 'txn_type'
|
||||
CGI parameter, which will be set for PayPal IPN postbacks.
|
||||
|
||||
Once IPN has been set up, you have to set up your application to direct users
|
||||
to PayPal in order to initiate a PayPal payment.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<https://www.paypal.com/html/single_item.pdf> - Single Item Purchases Manual
|
||||
|
||||
L<https://www.paypal.com/html/subscriptions.pdf> - Subscriptions and Recurring
|
||||
Payments Manual
|
||||
|
||||
L<https://www.paypal.com/html/ipn.pdf> - IPN Manual
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: PayPal.pm,v 1.8 2006/04/08 03:42:05 brewt Exp $
|
||||
|
||||
=cut
|
||||
@ -0,0 +1,466 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Payment::Remote::WorldPay
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: WorldPay.pm,v 1.9 2006/08/22 23:03:14 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# WorldPay "Select Junior" payment processing.
|
||||
#
|
||||
#
|
||||
# One major shortcoming of WorldPay is that its callback system is quite weak.
|
||||
# It won't try to inform you very hard - it tries once, but if it doesn't
|
||||
# connect it gives up and doesn't try again, making it entirely possible and
|
||||
# likely that you will have to manually add missing payments at some point.
|
||||
#
|
||||
|
||||
package GT::Payment::Remote::WorldPay;
|
||||
use strict;
|
||||
use Carp;
|
||||
require Exporter;
|
||||
use vars qw/@ISA @EXPORT_OK/;
|
||||
@ISA = qw/Exporter/;
|
||||
@EXPORT_OK = qw/process md5_signature/;
|
||||
|
||||
sub process {
|
||||
# -----------------------------------------------------------------------------
|
||||
shift if $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
|
||||
my %opts = @_;
|
||||
$opts{param} and UNIVERSAL::isa($opts{param}, 'GT::CGI') or croak 'Usage: ->process(param => $gtcgi, ...)';
|
||||
my $in = $opts{param};
|
||||
|
||||
ref $opts{on_valid} eq 'CODE'
|
||||
or ref $opts{on_recurring} eq 'CODE'
|
||||
or croak 'Usage: ->process(on_valid => \&CODEREF, ...)';
|
||||
|
||||
defined $opts{password} and length $opts{password} or croak 'Usage: ->process(password => "password", ...)';
|
||||
|
||||
for (qw/on_valid on_recurring on_cancel on_invalid_password on_recurring_failed on_recurring_cancelled/) {
|
||||
!$opts{$_} or ref $opts{$_} eq 'CODE' or croak "Usage: ->process($_ => \\&CODEREF, ...)";
|
||||
}
|
||||
|
||||
my $callbackpw = $in->param('callbackPW');
|
||||
unless ($callbackpw and $callbackpw eq $opts{password}) {
|
||||
$opts{on_invalid_password}->() if $opts{on_invalid_password};
|
||||
return;
|
||||
}
|
||||
|
||||
my $trans_status = $in->param('transStatus');
|
||||
|
||||
# The transaction was a testMode transaction, but testMode is not enabled.
|
||||
if ($in->param('testMode') and not $opts{test_mode}) {
|
||||
return;
|
||||
}
|
||||
|
||||
if ($in->param('futurePayId')) {
|
||||
if ($trans_status eq 'Y') {
|
||||
$opts{on_recurring}->() if $opts{on_recurring};
|
||||
}
|
||||
elsif ($trans_status eq 'N') {
|
||||
$opts{on_recurring_failed}->() if $opts{on_recurring_failed};
|
||||
}
|
||||
elsif ($in->param('futurePayStatusChange') eq 'Customer Cancelled') {
|
||||
$opts{on_recurring_cancelled}->() if $opts{on_recurring_cancelled};
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (uc $trans_status eq 'Y') { $opts{on_valid}->() if $opts{on_valid} }
|
||||
elsif (uc $trans_status eq 'C') { $opts{on_cancel}->() if $opts{on_cancel} }
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub md5_signature {
|
||||
# -----------------------------------------------------------------------------
|
||||
shift if $_[0] and UNIVERSAL::isa($_[0], __PACKAGE__);
|
||||
require GT::MD5;
|
||||
return GT::MD5::md5_hex(join ":", @_);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Payment::Remote::WorldPay - WorldPay payment handling
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
One thing to note about WorldPay is that its security system is a little weak -
|
||||
you can't trust a callback post as actually being genuine, unless you use the
|
||||
callback password feature - and even at that it is not a terribly secure
|
||||
solution. In this regard, other payment provides have much cleaner transaction
|
||||
systems. Another shortcoming of WorldPay is that its callback system is
|
||||
somewhat weak - it won't try to inform you very hard: it tries once, but if it
|
||||
doesn't connect it gives up and doesn't try again, making it entirely possible
|
||||
and likely that you will have to manually add (or confirm) missing payments at
|
||||
some point, so supporting at least manual payment approval of initiated
|
||||
payments is absolutely required.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Payment::Remote::WorldPay;
|
||||
use GT::CGI;
|
||||
|
||||
my $in = new GT::CGI;
|
||||
|
||||
GT::Payment::Remote::WorldPay->process(
|
||||
param => $in,
|
||||
on_valid => \&valid,
|
||||
on_cancel => \&cancel,
|
||||
|
||||
on_recurring => \&recurring,
|
||||
on_recurring_failed => \&recurring_failed,
|
||||
on_recurring_cancelled => \&recurring_cancelled,
|
||||
|
||||
password => "123",
|
||||
on_invalid_password => \&invalid_pw
|
||||
);
|
||||
|
||||
sub valid {
|
||||
# Update database - the payment has been made successfully.
|
||||
}
|
||||
|
||||
sub cancel {
|
||||
# Update database - the user has clicked the "Cancel" button, thereby
|
||||
# cancelling the payment. You should take note of the cancellation.
|
||||
}
|
||||
|
||||
sub on_recurring {
|
||||
# Update database - a recurring payment has been made successfully.
|
||||
}
|
||||
|
||||
sub on_recurring_failed {
|
||||
# Update database - a recurring payment has failed.
|
||||
}
|
||||
|
||||
sub on_recurring_cancelled {
|
||||
# Update database - either the customer or the merchant has cancelled
|
||||
# this recurring payment
|
||||
}
|
||||
|
||||
sub on_invalid_password {
|
||||
# Perhaps make a record - a payment callback was received without a
|
||||
# valid password
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is designed to handle WorldPay payment processing using WorldPay's
|
||||
"Select Junior" system and callback.
|
||||
|
||||
=head1 REQUIREMENTS
|
||||
|
||||
GT::CGI is the only requirement, however GT::MD5 is required in order to use
|
||||
the md5_signature function.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
This module has only two functions. process() does the work of actually
|
||||
figuring out what to do with a postback, and md5_signature() is used to
|
||||
generate an MD5 signature for payment verification and security purposes. Both
|
||||
functions can be imported into your package, and can be called as either method
|
||||
or function.
|
||||
|
||||
=head2 process
|
||||
|
||||
process() is the main function provided by this module. It can be called as
|
||||
either a function or class method, and takes a hash (not hash reference) of
|
||||
arguments as described below.
|
||||
|
||||
process() should be called for WorldPay initiated postbacks. This can be set
|
||||
up in your main CGI by looking for WorldPay-specific CGI parameters
|
||||
('transStatus' is a good one to look for) or by making a seperate .cgi file
|
||||
exclusively for handling WorldPay postbacks.
|
||||
|
||||
Additionally, it is strongly advised that database connection, authenticate,
|
||||
etc. be performed before calling process() to ensure that the payment is
|
||||
recorded successfully. WorldPay will not attempt to repost the form data if
|
||||
your script produces an error, and the error will be shown to the customer.
|
||||
|
||||
The L<C<param>|/"param"> argument, either L<C<on_valid>|/"on_valid"> or
|
||||
L<C<on_recurring>|/"on_recurring">, and the L<C<password>|/"password"> options
|
||||
are required. Using L<MD5 signing|/"MD5 signing"> as well is strongly advised.
|
||||
|
||||
=over 4
|
||||
|
||||
=item param
|
||||
|
||||
param takes a GT::CGI object from which WorldPay postback variables are read.
|
||||
|
||||
=item on_valid
|
||||
|
||||
on_valid takes a code reference as value. The code reference will be called
|
||||
when a successful payment has been made. Inside this code reference you are
|
||||
responsible for setting a "paid" status for the order in question.
|
||||
|
||||
=item on_cancel
|
||||
|
||||
Takes a code reference to call in the event of the customer clicking the
|
||||
"cancel" button. Note that this is not sent if the user closes their browser,
|
||||
but only if they click "cancel."
|
||||
|
||||
You should record a cancelled payment in your application.
|
||||
|
||||
=item password
|
||||
|
||||
This is a password that the customer should set in the WorldPay Customer
|
||||
Management System, and provide to you. Without this password, WorldPay
|
||||
postbacks should not be considered secure.
|
||||
|
||||
=item on_invalid_password
|
||||
|
||||
This code reference will be called when the correct password is not present in
|
||||
the postback request. This will also be called if no password is provided.
|
||||
|
||||
=item on_recurring
|
||||
|
||||
=item on_recurring_failed
|
||||
|
||||
=item on_recurring_cancelled
|
||||
|
||||
In order to support recurring payments, you must at least define
|
||||
C<on_recurring>. C<on_recurring> is called when a successful recurring payment
|
||||
has been made. C<on_recurring_failed> is called for a failed recurring payment
|
||||
(e.g. credit card declined). See
|
||||
L<the Recurring charges section|/"Recurring charges"> for more details.
|
||||
|
||||
Bear in mind that if you do not set up the on_recurring callback, recurring
|
||||
payments will be ignored.
|
||||
|
||||
=back
|
||||
|
||||
=head2 md5_signature
|
||||
|
||||
The md5_signature() function takes a password (this must be set for the
|
||||
WorldPay account), and a list of values and generates an appropriate WorldPay
|
||||
MD5 signature, which should be included as the "signature" field. See
|
||||
L<the MD5 signing section|/"MD5 signing"> for more details.
|
||||
|
||||
=head1 INSTRUCTIONS
|
||||
|
||||
To implement WorldPay payment processing, there are a number of steps required
|
||||
in addition to this module. Basically, this module handles only the postback
|
||||
stage of the WorldPay payment process.
|
||||
|
||||
Full WorldPay "Select Junior" information is available from the "Select Junior
|
||||
Integration Guide" available from www.worldpay.com.
|
||||
|
||||
=head2 Directing customers to WorldPay
|
||||
|
||||
This is done by creating a web form containing the following variables. Your
|
||||
form, first of all, must make a C<post> request to
|
||||
C<https://select.worldpay.com/wcc/purchase>.
|
||||
|
||||
Required fields are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item instId
|
||||
|
||||
Your WorldPay Installation ID. Example: C<1234>
|
||||
|
||||
=item currency
|
||||
|
||||
The currency of the purchase. Example: C<GBP>
|
||||
|
||||
=item desc
|
||||
|
||||
A description of the purchase. Example: C<Blue T-Shirt, Medium>
|
||||
|
||||
=item cartId
|
||||
|
||||
A reference you assign to help you identify the purchase. Example: C<10a0491>.
|
||||
|
||||
=item amount
|
||||
|
||||
The total cost of the purchase. Example: C<25.35>
|
||||
|
||||
=back
|
||||
|
||||
=head2 Recurring charges
|
||||
|
||||
Additionally, in order to set up recurring payments, the WorldPay account must
|
||||
have "FuturePay" enabled, and then you need to use the following parameters.
|
||||
|
||||
The below parameters are used for the "Regular FuturePay Agreements" - there is
|
||||
also "Limited FuturePay Agreements" in which a maximum overall charge is set.
|
||||
For more information, see L<Repear Billing With FuturePay|/"SEE ALSO">.
|
||||
|
||||
=over 4
|
||||
|
||||
=item futurePayType
|
||||
|
||||
Should contain the value "regular", unless using "Limited FuturePay Agreements,"
|
||||
which will work but is not described here.
|
||||
|
||||
=item option
|
||||
|
||||
Should contain either 0, 1, or 2. 0 means the payment amount is fixed and
|
||||
cannot be changed. 1 means the payment is fixed, but can be changed to another
|
||||
amount at any point. 2 means the payment amount must be set before each
|
||||
recurring payment.
|
||||
|
||||
=item startDate
|
||||
|
||||
Value in the format: "yyyy-mm-dd". This should be the date on which the first
|
||||
future payment should be taken. Note that this is _NOT_ and CANNOT be today,
|
||||
but must be a value in the future. If using option 2, this value must be at
|
||||
least 2 weeks in the future.
|
||||
|
||||
=item startDelayUnit
|
||||
|
||||
One digit: 1: day, 2: week, 3: month, 4: year. Only used if startDate is
|
||||
B<not> set. If using option 2, this value must be at least 2 weeks in the
|
||||
future.
|
||||
|
||||
=item startDelayMult
|
||||
|
||||
The actual delay is obtained by multiplying this value by startDelayUnit. So,
|
||||
to start in three weeks, this would be "3", and startDelayUnit would be "2".
|
||||
Again, this is not used if startDate is specified. Must be >= 1 if set.
|
||||
|
||||
=item noOfPayments
|
||||
|
||||
This number of payments that will be made. Leave as 0 or unset for unlimited.
|
||||
|
||||
=item intervalUnit
|
||||
|
||||
One digit: 1: day, 2: week, 3: month, 4: year. The unit of interval between
|
||||
payments. This must be set unless noOfPayments is 1. If using option 1 or
|
||||
option 2, the minimum interval is 2 weeks.
|
||||
|
||||
=item intervalMult
|
||||
|
||||
The interval between payments is determined by this value multiplied by
|
||||
intervalUnit. So, to make payments every 1 month, this would be "1", and
|
||||
intervalUnit would be "3". Must be >= 1.
|
||||
|
||||
=item normalAmount
|
||||
|
||||
This must be set for option 0 and option 1, but cannot be set for option 2.
|
||||
|
||||
=item initialAmount
|
||||
|
||||
This can be used for option 0 or option 1, but cannot be set for option 2. If
|
||||
set, this overrides the amount of the first payment.
|
||||
|
||||
=back
|
||||
|
||||
For FuturePay (recurring) payments, you still pass the required fields as
|
||||
normal, except for the amount field: amount can be passed as 0 or a value - if
|
||||
a value is specified, this will be treated as an immediate payment. So, for
|
||||
example, if you wanted to charge someone a monthly subscription of $10 starting
|
||||
today you would pass the following variables:
|
||||
|
||||
instId=1234 # (the merchant's installation reference here)
|
||||
amount=10
|
||||
cartId=8456a9264q314 # (Some random ID here that you generate)
|
||||
currency=USD # (Whatever currency they are charging in goes here)
|
||||
desc=Subscription For Something Cool # (Description of subscription)
|
||||
option=0
|
||||
normalAmount=10
|
||||
startDelayUnit=3
|
||||
startDelayMult=1
|
||||
intervalUnit=3
|
||||
intervalMult=1
|
||||
|
||||
=head2 MD5 signing
|
||||
|
||||
Additionally, using WorldPay's MD5 signature feature is strongly recommended.
|
||||
|
||||
To enable this feature, provide a field "signatureFields", containing fields
|
||||
separated by ":". Although any fields can be used, "amount:currency:cartId" is
|
||||
recommended. Then, call:
|
||||
|
||||
my $md5 = GT::Payment::Remote::WorldPay::md5_signature(
|
||||
$password, $amount, $currency, $cartId
|
||||
);
|
||||
|
||||
$password should be a password provided by the user and known only to the user
|
||||
and WorldPay. The value returned should be passed as the "signature" variable.
|
||||
|
||||
This MD5 protection causes WorldPay to reject any faked payment requests and so
|
||||
is reasonably secure.
|
||||
|
||||
=head2 Postback
|
||||
|
||||
Before WorldPay postback notification can occur, you must instruct the user to
|
||||
enable the callback facility in the Customer Management System. Additionally,
|
||||
it is recommended that a proper URL to your CGI be specified there, or else
|
||||
pass along a "MC_callback" variable that points to the script _WITHOUT_ a
|
||||
leading http:// or https://. (e.g. MC_callback=www.example.com/callback.cgi).
|
||||
|
||||
Note that a WorldPay limitation prevents the callback protocol (http://) from
|
||||
being changed dynamically - whatever protocol is set for your callback URL in
|
||||
the Customer Management System will be used with the dynamic callback URL.
|
||||
|
||||
=head2 Putting it all together
|
||||
|
||||
The typical way to implement all of this is as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1 Get necessary merchant information (instId, currency, callback
|
||||
password, and MD5 password).
|
||||
|
||||
=item 2 Once the customer has selected what to purchase, generate a cartId (a
|
||||
random MD5 hex string works well - but I<do not> use the MD5 signature!), and
|
||||
L<generate the MD5 signature|/"MD5 signing">.
|
||||
|
||||
=item 3 Store the cartId somewhere (i.e. in the database).
|
||||
|
||||
=item 4 Make a form with all the necessary fields that
|
||||
L<submits to WorldPay|/"Directing customers to WorldPay">.
|
||||
|
||||
=item 5 Set up the necessary callbacks (at least L<C<on_valid>|/"on_valid"> and
|
||||
L<C<on_valid>|/"on_cancel">). If using a dedicated CGI script for WorldPay
|
||||
callbacks, it should just call process(); otherwise, check for the CGI
|
||||
parameter 'transStatus' and if present, call process().
|
||||
|
||||
=item 6 For a valid payment, do whatever you need to do for a valid payment,
|
||||
and store some record of the payment having been made (storing at least the
|
||||
cartId, the transId, and the futurePayId is strongly recommended). Use the CGI
|
||||
parameter 'cartId' to locate the order (i.e. in the database). It's
|
||||
recommended that you check Appendix A of the "Select Junior Integration Guide"
|
||||
for all available parameters.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<http://support.worldpay.com> - WorldPay Knowledge Base, containing many
|
||||
useful WorldPay manuals and instructions.
|
||||
|
||||
L<http://support.worldpay.com/kb/integration_guides/junior/integration/help/sjig.html>
|
||||
- Select Junior Integration Guide, from which this documentation and module is
|
||||
primarily derived.
|
||||
|
||||
L<http://support.worldpay.com/kb/product_guides/futurepay/repeatbilling.html> -
|
||||
Repeat Billing with FuturePay.
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
Jason Rhinelander
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: WorldPay.pm,v 1.9 2006/08/22 23:03:14 brewt Exp $
|
||||
|
||||
This module is designed for version 4.4 of the Select Junior payment
|
||||
integration.
|
||||
|
||||
=cut
|
||||
424
site/slowtwitch.com/cgi-bin/articles/GT/Plugins.pm
Normal file
424
site/slowtwitch.com/cgi-bin/articles/GT/Plugins.pm
Normal file
@ -0,0 +1,424 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Plugins.pm,v 1.55 2005/04/01 00:16:51 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A plugin system for CGI scripts.
|
||||
#
|
||||
|
||||
package GT::Plugins;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
# TODO: Eventually we want to get rid of the $ACTION global, but it would break
|
||||
# rather a lot to do so.
|
||||
use vars qw/$VERSION $DEBUG $ERRORS $ATTRIBS $ACTION $error @ISA $AUTOLOAD @EXPORT/;
|
||||
use GT::Base;
|
||||
use GT::Config;
|
||||
use GT::AutoLoader;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$ERRORS = {
|
||||
BADARGS => "Invalid arguments. Usage: %s",
|
||||
CANTLOAD => "Unable to load plugin '%s': %s",
|
||||
CANTOPEN => "Unable to open '%s': %s",
|
||||
CANTDELETE => "Unable to remove plugin file '%s': %s",
|
||||
CANTMOVE => "Unable to move plugin %s from '%s' to '%s': %s",
|
||||
CANTREMOVE => "Unable to remove plugin file '%s': %s",
|
||||
PLUGEXISTS => "The plugin '%s' already exists, unable to overwrite without confirmation",
|
||||
NOINSTALL => "Unable to load install code in plugin '%s'. Missing Install.pm file.",
|
||||
NOCODE => "Unable to load main code for plugin '%s' from tar file. Missing '%s.pm' file.",
|
||||
NOPLUGINNAME => "Please name your plugin before calling save()",
|
||||
NOPLUGIN => "There is no plugin named '%s' in the config file.",
|
||||
CORRUPTCFG => "Syntax error in config file: %s",
|
||||
PLUGINERR => "Error running plugin '%s' hook '%s': %s"
|
||||
};
|
||||
$ATTRIBS = { directory => undef, prefix => '' };
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.55 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
# Actions that plugins can handle.
|
||||
use constants
|
||||
STOP => 1,
|
||||
CONTINUE => 2,
|
||||
|
||||
NAME => 0,
|
||||
TYPE => 1,
|
||||
HOOK => 2,
|
||||
ENABLED => 3;
|
||||
|
||||
@EXPORT = qw/STOP CONTINUE/;
|
||||
|
||||
sub init {
|
||||
# -----------------------------------------------------------------
|
||||
# Set our debug level and any extra options.
|
||||
#
|
||||
my $self = shift;
|
||||
my @args = @_;
|
||||
if (@args == 1 and not ref $args[0]) {
|
||||
@args = (directory => @args);
|
||||
}
|
||||
|
||||
$self->set(@args);
|
||||
|
||||
if ($self->{debug}) {
|
||||
$self->{_debug} = delete $self->{debug};
|
||||
}
|
||||
|
||||
$self->{directory} or $self->fatal(BADARGS => 'No directory passed to GT::Plugins->new()');
|
||||
|
||||
$self->load_cfg;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub active_plugins {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Class/object method that returns a boolean value indicating whether or not
|
||||
# the given argument (a plugin hook name) has any registered plugin hooks.
|
||||
# Primarily designed for optimizations where a section of code isn't needed
|
||||
# except for plugins.
|
||||
#
|
||||
my $self = shift;
|
||||
my $config = ref $self ? $self->{config} : $self->load_cfg(shift);
|
||||
|
||||
my $hook_name = lc shift;
|
||||
|
||||
return (
|
||||
exists $config->{_pre_hooks}->{$hook_name} and @{$config->{_pre_hooks}->{$hook_name}} or
|
||||
exists $config->{_post_hooks}->{$hook_name} and @{$config->{_post_hooks}->{$hook_name}}
|
||||
) ? 1 : undef;
|
||||
}
|
||||
|
||||
sub dispatch {
|
||||
# -----------------------------------------------------------------
|
||||
# Class Method to Run plugins.
|
||||
#
|
||||
my $self = shift;
|
||||
my $directory;
|
||||
my $config = ref $self ? $self->{config} : $self->load_cfg($directory = shift);
|
||||
my ($hook_name, $code, @args) = @_;
|
||||
|
||||
$hook_name = lc $hook_name;
|
||||
|
||||
# Run any pre hooks.
|
||||
my @results;
|
||||
my $debug = ref $self ? $self->{_debug} : $DEBUG;
|
||||
|
||||
if (exists $config->{_pre_hooks}->{$hook_name}) {
|
||||
local $^W; no strict 'refs';
|
||||
# Save our action in case plugins is called twice.
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_pre_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: pre $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'PRE') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->(@args);
|
||||
if ($ACTION == STOP) {
|
||||
$self->debug("Plugin pre hook $hook_name stopped further plugins.") if $debug;
|
||||
last;
|
||||
}
|
||||
}
|
||||
unless ($ACTION == STOP) {
|
||||
@results = $code->(@args);
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
else {
|
||||
@results = $code->(@args);
|
||||
}
|
||||
|
||||
# Run any post hooks.
|
||||
if (exists $config->{_post_hooks}->{$hook_name}) {
|
||||
local ($^W); no strict 'refs';
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_post_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: post $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'POST') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->(@results);
|
||||
if ($ACTION == STOP) {
|
||||
$self->debug("Plugin post hook $hook_name stopped further plugins.") if $debug;
|
||||
last;
|
||||
}
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
|
||||
# Must return as a list
|
||||
return @results ? (@results)[0 .. $#results] : ();
|
||||
}
|
||||
|
||||
sub dispatch_method {
|
||||
# -----------------------------------------------------------------
|
||||
# Class Method to Run plugins.
|
||||
#
|
||||
my $self = shift;
|
||||
my $directory;
|
||||
my $config = ref $self ? $self->{config} : $self->load_cfg($directory = shift);
|
||||
my ($hook_name, $object, $method, @args) = @_;
|
||||
$hook_name = lc $hook_name;
|
||||
|
||||
my $debug = ref $self ? $self->{_debug} : $DEBUG;
|
||||
|
||||
# Run any pre hooks.
|
||||
my @results;
|
||||
if (exists $config->{_pre_hooks}->{$hook_name}) {
|
||||
local ($^W); no strict 'refs';
|
||||
# Save our action in case plugins is called twice.
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_pre_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: pre $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'PRE') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->($object, @args);
|
||||
$ACTION == STOP and last;
|
||||
}
|
||||
unless ($ACTION == STOP) {
|
||||
@results = $object->$method(@args);
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
else {
|
||||
@results = $object->$method(@args);
|
||||
}
|
||||
|
||||
# Run any post hooks.
|
||||
if (exists $config->{_post_hooks}->{$hook_name}) {
|
||||
local ($^W); no strict 'refs';
|
||||
my $orig_action = $ACTION;
|
||||
foreach my $hook (@{$config->{_post_hooks}->{$hook_name}}) {
|
||||
$self->debug("Plugin: post $hook_name running => $hook") if $debug;
|
||||
defined &{$hook} or $self->_load_hook($hook, 'POST') or next;
|
||||
$ACTION = CONTINUE;
|
||||
@results = $hook->($object, @results);
|
||||
# If the post hook returned the object as the first return value
|
||||
# that probably means it returned @_ unaltered, in which case we
|
||||
# want to remove it so that @results doesn't end up with any number
|
||||
# of objects stuck to the beginning of arguments/return values.
|
||||
shift @results if ref $object and ref $results[0] and $object == $results[0];
|
||||
|
||||
$ACTION == STOP and last;
|
||||
}
|
||||
$ACTION = $orig_action;
|
||||
}
|
||||
|
||||
# Must return as a list
|
||||
return @results ? (@results)[0 .. $#results] : ();
|
||||
}
|
||||
|
||||
sub load_cfg {
|
||||
# -----------------------------------------------------------------
|
||||
# Load the plugin config file.
|
||||
#
|
||||
my ($self, $directory) = @_;
|
||||
$directory ||= ref $self ? $self->{directory} : '.';
|
||||
|
||||
my $cfg = GT::Config->load("$directory/plugin.cfg", { local => 0, inheritance => 0, create_ok => 1 });
|
||||
|
||||
if (!$cfg and ref $self ? $self->{_debug} : $DEBUG) {
|
||||
$self->debug("Unable to load plugin config file '$directory/plugin.cfg': $GT::Config::error");
|
||||
}
|
||||
|
||||
# Take care to delete _pre_hooks just in case the file was somehow saved
|
||||
# with _pre_hooks in it.
|
||||
delete $cfg->{_pre_hooks} if not $cfg->cache_hit;
|
||||
|
||||
# If _pre_hooks exists, the config was loaded from the cache, and the below
|
||||
# has already been calculated.
|
||||
unless ($cfg->{_pre_hooks}) {
|
||||
$cfg->{_pre_hooks} = {};
|
||||
$cfg->{_post_hooks} = {};
|
||||
while (my ($plugin, $config) = each %$cfg) {
|
||||
next if substr($plugin, 0, 1) eq '_' or ref $config->{hooks} ne 'ARRAY';
|
||||
for my $hook (@{$config->{hooks}}) {
|
||||
next unless $hook->[ENABLED] and ($hook->[TYPE] eq 'PRE' or $hook->[TYPE] eq 'POST');
|
||||
push @{$cfg->{$hook->[TYPE] eq 'PRE' ? '_pre_hooks' : '_post_hooks'}->{lc $hook->[NAME]}}, $hook->[HOOK];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$self->{config} = $cfg if ref $self;
|
||||
return $cfg;
|
||||
}
|
||||
|
||||
$COMPILE{save_cfg} = __LINE__ . <<'END_OF_SUB';
|
||||
sub save_cfg {
|
||||
# -----------------------------------------------------------------
|
||||
# Save the plugin cfg file. OO usage: $plugin_obj->save; Deprecated, non-OO
|
||||
# usage: GT::Plugins->save_cfg($plugin_config_object); Also supported is:
|
||||
# GT::Plugins->save_cfg($ignored_value, $plugin_config_object); for
|
||||
# compatibility reasons. These are almost equivelant to
|
||||
# $plugin_config_object->save, except that they remove the internal _pre_hooks
|
||||
# and _post_hooks keys first, then restore them after saving.
|
||||
#
|
||||
my $self = shift;
|
||||
my $config = ref $self ? $self->{config} : @_ > 1 ? $_[1] : $_[0];
|
||||
|
||||
my ($pre, $post) = delete @$config{qw/_pre_hooks _post_hooks/};
|
||||
|
||||
$config->save();
|
||||
|
||||
@$config{qw/_pre_hooks _post_hooks/} = ($pre, $post);
|
||||
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub action {
|
||||
# -------------------------------------------------------------------
|
||||
# Sets the action the plugin wants.
|
||||
#
|
||||
$ACTION = $_[1];
|
||||
}
|
||||
|
||||
$COMPILE{_load_hook} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _load_hook {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a module and checks for the hook.
|
||||
#
|
||||
my ($self, $hook, $stage) = @_;
|
||||
my ($pkg) = $hook =~ /^(.*)::[^:]+$/ or return;
|
||||
$pkg =~ s,::,/,g;
|
||||
{
|
||||
local $SIG{__DIE__};
|
||||
eval { require "$pkg.pm" };
|
||||
}
|
||||
if ($@) {
|
||||
return $self->error('PLUGINERR', 'FATAL', $stage, $hook, "$@");
|
||||
}
|
||||
if (! defined &{$hook}) {
|
||||
return $self->error('PLUGINERR', 'FATAL', $stage, $hook, "$hook does not exist in $pkg");
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{reset_env} = __LINE__ . <<'END_OF_SUB';
|
||||
sub reset_env { }
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Plugins - a plugin interface for Gossamer Threads products.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::Plugins;
|
||||
$PLUGIN = GT::Plugins->new('/path/to/plugin/dir');
|
||||
|
||||
$PLUGIN->dispatch(hook_name => \&code_ref => @args);
|
||||
$PLUGIN->dispatch_method(hook_name => $self => method => @args);
|
||||
|
||||
Old style, now deprecated in favour of the object approach above:
|
||||
|
||||
use GT::Plugins;
|
||||
|
||||
GT::Plugins->dispatch('/path/to/plugin/dir', hook_name => \&code_ref => @args);
|
||||
GT::Plugins->dispatch_method('/path/to/plugin/dir', hook_name => $self => method => @args);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The plugin module supports two modes of use. The first mode involves creating
|
||||
and using a GT::Plugins object upon which plugin dispatch methods may be called
|
||||
to provide hooks. The second does not use the object, but instead uses class
|
||||
methods with an extra argument of the plugin path preceding the other
|
||||
->dispatch() arguments.
|
||||
|
||||
Of the two approaches, the object approach is recommended as it is a) faster,
|
||||
and b) requires much less value duplication as the plugin directory needs to be
|
||||
specified only once. The old, class-method-based plugin interface should be
|
||||
considered deprecated, and all new code should attempt to use the object-based
|
||||
system.
|
||||
|
||||
A dispatch with each of the two interfaces work as follows, with differences in
|
||||
interfaces as noted:
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1.
|
||||
|
||||
Loads the plugin config file. The actual file access and evaluation will be
|
||||
cached, but a small amount of extra overhead is required on each dispatch.
|
||||
This only applies to the deprecated class-method dispatch interface - the
|
||||
preferred object interface loads the configuration file only once.
|
||||
|
||||
=item 2.
|
||||
|
||||
Runs any 'PRE' hooks registered in the config file. When using ->dispatch(),
|
||||
each hook is passed the C<@args> arguments passed into ->dispatch. When using
|
||||
->dispatch_method(), both the object ($self) and arguments (@args) are passed
|
||||
to the hook.
|
||||
|
||||
Each plugin hook then has the ability to abort further plugins if desired by
|
||||
calling C<$PLUGIN-E<gt>action(STOP)> (or C<GT::Plugins-E<gt>action(STOP)> for
|
||||
the non-OO interface). STOP is exported by default from the GT::Plugins
|
||||
module. Performing a STOP will skip both any further 'PRE' hooks and the
|
||||
original function/method, and will use the hook's return value instead of the
|
||||
real code's return value.
|
||||
|
||||
The current behaviour of 'PRE' hooks ignores the return value of any 'PRE' hook
|
||||
that does not perform a STOP, however this behaviour B<may> change to use the
|
||||
return value as the arguments to the next PRE hook or actual code called. As
|
||||
such, it is strongly recommended to return @_ from any 'PRE' hooks.
|
||||
|
||||
=item 3.
|
||||
|
||||
Assuming C<-E<gt>action(STOP)> has not been called, the method
|
||||
(->dispatch_method) or code reference (->dispatch) will be called, and its
|
||||
return value stored.
|
||||
|
||||
=item 4.
|
||||
|
||||
Any registered 'POST' hooks registered in the config file will be run. When
|
||||
using ->dispatch(), the list-context return value of the main code run (or, if
|
||||
a 'PRE' hook called STOP, the return value of that 'PRE' hook) will be passed
|
||||
in. When using ->dispatch_method(), the object is additionally passed in as
|
||||
the first argument.
|
||||
|
||||
The list returned by the 'POST' hook will be used as arguments for any
|
||||
subsequent 'POST' hooks and as the final result returned by the ->dispatch() or
|
||||
->dispatch_method() call. There is one exception to this - for
|
||||
->dispatch_method() 'POST' hooks, if the first argument of the return value is
|
||||
the object, it will be removed; this is done to prevent a build-up of excess
|
||||
objects at the beginning of the 'POST' hook arguments/return values due to
|
||||
'POST' hooks simply returning @_ unaltered.
|
||||
|
||||
=item 5.
|
||||
|
||||
The return value of the final 'POST' hook, or, when no post hooks are
|
||||
configured, of the actual code, is returned as the result of the ->dispatch()
|
||||
call.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Also included as part of the plugin system are some modules for web based tools
|
||||
to manage plugins:
|
||||
|
||||
L<GT::Plugins::Manager> - Add, remove and edit plugin files.
|
||||
|
||||
L<GT::Plugins::Wizard> - Create shell plugins.
|
||||
|
||||
L<GT::Plugins::Installer> - Used in installing plugins.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Plugins.pm,v 1.55 2005/04/01 00:16:51 brewt Exp $
|
||||
|
||||
=cut
|
||||
836
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Author.pm
Normal file
836
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Author.pm
Normal file
@ -0,0 +1,836 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Author.pm,v 1.15 2006/06/27 01:44:53 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A web based admin to package new plugins.
|
||||
#
|
||||
|
||||
package GT::Plugins::Author;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $ERRORS $DEBUG $PLUGIN_DIR $FONT/;
|
||||
use GT::Base;
|
||||
use GT::Plugins;
|
||||
use GT::Template;
|
||||
use GT::Dumper;
|
||||
use GT::Tar;
|
||||
|
||||
$ATTRIBS = {
|
||||
plugin_name => '',
|
||||
prefix => '',
|
||||
version => '',
|
||||
meta => {},
|
||||
pre_install => '',
|
||||
install => '',
|
||||
pre_uninstall => '',
|
||||
uninstall => '',
|
||||
header => '',
|
||||
admin_menu => [],
|
||||
options => {},
|
||||
hooks => [],
|
||||
cfg => undef,
|
||||
tar => undef
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::Plugins';
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/;
|
||||
$FONT = 'font face="Tahoma,Arial,Helvetica" size="2"';
|
||||
|
||||
sub init {
|
||||
# ------------------------------------------------------------------
|
||||
# Create a new plugin author object, called from GT::Base on new().
|
||||
#
|
||||
my $self = shift;
|
||||
if (! defined $PLUGIN_DIR) {
|
||||
$PLUGIN_DIR = shift or return $self->error('BADARGS', 'FATAL', "new GT::Plugins::Author ( '/path/to/plugin/dir' )");
|
||||
$PLUGIN_DIR .= $PLUGIN_DIR =~ m,/$, ? "Plugins" : "/Plugins";
|
||||
}
|
||||
$self->{cfg} = GT::Plugins->load_cfg($PLUGIN_DIR);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub list_editable {
|
||||
# ------------------------------------------------------------------
|
||||
# List current plugin names available to be edited.
|
||||
#
|
||||
my $self = shift;
|
||||
my $dir = $PLUGIN_DIR . "/Author";
|
||||
my @projects = ();
|
||||
|
||||
opendir (DIR, $dir) or return $self->error('CANTOPEN', 'FATAL', $dir, $!);
|
||||
while (defined(my $file = readdir(DIR))) {
|
||||
next unless ($file =~ /(.*)\.tar$/);
|
||||
push @projects, $1;
|
||||
}
|
||||
closedir(DIR);
|
||||
return \@projects;
|
||||
}
|
||||
|
||||
sub load_plugin {
|
||||
# ------------------------------------------------------------------
|
||||
# Load a plugin tar file into self.
|
||||
#
|
||||
my ($self, $plugin_name) = @_;
|
||||
$self->{plugin_name} = $plugin_name;
|
||||
$self->{tar} = $self->_load_tar or return;
|
||||
$self->_load_plugin;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub save {
|
||||
# ------------------------------------------------------------------
|
||||
# Save the current state of self into tar file.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{plugin_name} or return $self->error('NOPLUGINNAME', 'WARN');
|
||||
|
||||
|
||||
my ($author);
|
||||
$self->{tar} or $self->_load_tar;
|
||||
foreach my $file ($self->{tar}->files) {
|
||||
if ($file->name =~ /Author\.pm$/) {
|
||||
$author = $file;
|
||||
}
|
||||
}
|
||||
$author ?
|
||||
($author->body( $self->_create_author )) :
|
||||
($author = $self->{tar}->add_data( name => 'Author.pm', body => $self->_create_author ));
|
||||
|
||||
# add files.
|
||||
return $self->{tar}->write();
|
||||
}
|
||||
|
||||
sub add_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the Install.pm file.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $self->{tar}->get_file('Install.pm');
|
||||
if ($file) {
|
||||
$self->_replace_install($file);
|
||||
}
|
||||
else {
|
||||
my $time = localtime();
|
||||
my $version = $self->{version} || 0;
|
||||
my $meta_dump = GT::Dumper->dump( var => '$META', data => $self->{meta} );
|
||||
|
||||
my $output = <<END_OF_PLUGIN;
|
||||
# ==================================================================
|
||||
# $self->{prefix}Plugins::$self->{plugin_name} - Auto Generated Install Module
|
||||
#
|
||||
# $self->{prefix}Plugins::$self->{plugin_name}
|
||||
# Author : $self->{meta}->{author}
|
||||
# Version : $self->{version}
|
||||
# Updated : $time
|
||||
#
|
||||
# ==================================================================
|
||||
#
|
||||
|
||||
package $self->{prefix}Plugins::$self->{plugin_name};
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw/\$VERSION \$DEBUG \$NAME \$META/;
|
||||
\$VERSION = $version;
|
||||
\$DEBUG = 0;
|
||||
\$NAME = '$self->{plugin_name}';
|
||||
$meta_dump
|
||||
$self->{header}
|
||||
|
||||
$self->{install}
|
||||
$self->{uninstall}
|
||||
$self->{pre_install}
|
||||
$self->{pre_uninstall}
|
||||
|
||||
1;
|
||||
|
||||
END_OF_PLUGIN
|
||||
$self->{tar}->add_data( name => 'Install.pm', body => $output );
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# HTML Generationg Methods #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub attribs_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns a hash of attribs as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = {
|
||||
plugin => $self->{plugin},
|
||||
version => $self->{version},
|
||||
meta => $self->meta_as_html,
|
||||
install => $self->install_as_html,
|
||||
hooks => $self->hooks_as_html,
|
||||
admin_menu => $self->admin_menu_as_html,
|
||||
options => $self->options_as_html,
|
||||
files => $self->files_as_html,
|
||||
};
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub attribs_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns a hash of attribs in form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = {
|
||||
plugin => $self->{plugin},
|
||||
version => $self->{version},
|
||||
meta => $self->meta_as_form,
|
||||
install => $self->install_as_form,
|
||||
hooks => $self->hooks_as_form,
|
||||
admin_menu => $self->admin_menu_as_form,
|
||||
options => $self->options_as_form,
|
||||
files => $self->files_as_form,
|
||||
};
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub attribs_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Load author from a cgi object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
$self->meta_from_cgi($cgi);
|
||||
$self->install_from_cgi($cgi);
|
||||
$self->hooks_from_cgi($cgi);
|
||||
$self->admin_menu_from_cgi($cgi);
|
||||
$self->options_from_cgi($cgi);
|
||||
$self->files_from_cgi($cgi);
|
||||
}
|
||||
|
||||
sub meta_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = qq~
|
||||
<tr><td><$FONT>Version:</font></td><td><$FONT>~ . _escape_html($self->{version}) . qq~</font></td></tr>
|
||||
<tr><td><$FONT>Author:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{author}) . qq~</font></td></tr>
|
||||
<tr><td><$FONT>URL:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{url}) . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Description:</font></td><td><$FONT>~ . _escape_html($self->{meta}->{description}) . qq~</font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub meta_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = qq~
|
||||
<tr><td><$FONT>Version:</font></td><td><$FONT><input type="text" name="version" value="~ . _escape_html($self->{version}) . qq~"></font></td></tr>
|
||||
<tr><td><$FONT>Author:</font></td><td><$FONT><input type="text" name="author" value="~ . _escape_html($self->{meta}->{author}) . qq~"></font></td></tr>
|
||||
<tr><td><$FONT>URL:</font></td><td><$FONT><input type="text" name="url" value="~ . _escape_html($self->{meta}->{url}) . qq~"></font></td></tr>
|
||||
<tr><td valign="top"><$FONT>Description:</font></td><td><$FONT><textarea cols=50 rows=5 name="description">~ . _escape_html($self->{meta}->{description}) . qq~</textarea></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub meta_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Takes meta information from CGI object and stores it in self.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
$self->{version} = $cgi->param('version');
|
||||
$self->{meta}->{author} = $cgi->param('author');
|
||||
$self->{meta}->{url} = $cgi->param('url');
|
||||
$self->{meta}->{description} = $cgi->param('description');
|
||||
}
|
||||
|
||||
sub install_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns the install information as html.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->_load_install;
|
||||
my $output = qq~
|
||||
<tr><td valign=top><$FONT>Pre Install Message:</font></td><td><$FONT>~ . ($self->{pre_install} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Post Install Message:</font></td><td><$FONT>~ . ($self->{pre_uninstall} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Install Code:</font></td><td><$FONT>~ . ($self->{install} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
<tr><td valign=top><$FONT>Uninstall Code:</font></td><td><$FONT>~ . ($self->{uninstall} ? "Completed" : "To be done") . qq~</font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub install_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns the install information as a form.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->_load_install;
|
||||
my $output = qq~
|
||||
<tr><td valign=top><$FONT>Pre Install Message:<br>
|
||||
<input type="submit" name="preinst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="pre_install">~ . _escape_html($self->{pre_install}) . qq~</textarea></font></td></tr>
|
||||
<tr><td valign=top><$FONT>Post Install Message:<br>
|
||||
<input type="submit" name="preuninst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="pre_uninstall">~ . _escape_html($self->{pre_uninstall}) . qq~</textarea></font></td></tr>
|
||||
<tr><td valign=top><$FONT>Install Code:<br>
|
||||
<input type="submit" name="inst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 rows=8 wrap="off" name="install">~ . _escape_html($self->{install}) . qq~</textarea></font></td></tr>
|
||||
<tr><td valign=top><$FONT>Uninstall Code:<br>
|
||||
<input type="submit" name="uninst_auto_generate" wrap="off" value="Auto Generate"></font></td><td><$FONT><textarea cols=50 wrap="off" rows=8 name="uninstall">~ . _escape_html($self->{uninstall}) . qq~</textarea></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub install_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the install information from a CGI object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
|
||||
if ($cgi->param('inst_auto_generate')) {
|
||||
$self->{install} = $self->_create_install;
|
||||
}
|
||||
elsif ($cgi->param('preinst_auto_generate')) {
|
||||
$self->{pre_install} = $self->_create_preinstall;
|
||||
}
|
||||
elsif ($cgi->param('preuninst_auto_generate')) {
|
||||
$self->{pre_uninstall} = $self->_create_preuninstall;
|
||||
}
|
||||
elsif ($cgi->param('uninst_auto_generate')) {
|
||||
$self->{uninstall} = $self->_create_uninstall;
|
||||
}
|
||||
else {
|
||||
$self->{pre_install} = $cgi->param('pre_install');
|
||||
$self->{pre_uninstall} = $cgi->param('pre_uninstall');
|
||||
$self->{install} = $cgi->param('install');
|
||||
$self->{uninstall} = $cgi->param('uninstall');
|
||||
}
|
||||
}
|
||||
|
||||
sub hooks_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns plugin hooks as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{hooks}}) {
|
||||
foreach my $hook (@{$self->{hooks}}) {
|
||||
my ($hook_name, $prepost, $code) = @$hook;
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$hook_name ($prepost)</font></td><td><$FONT>$code</font></td></tr>
|
||||
~;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No hooks installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub hooks_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns plugin hooks as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{hooks}}) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Hooks</font></td></tr>
|
||||
~;
|
||||
my $i = 0;
|
||||
foreach my $hook (@{$self->{hooks}}) {
|
||||
my ($hook_name, $prepost, $code) = @$hook;
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$hook_name ($prepost) => $code</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_hooks" value="$i"></font></td></tr>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
my $pkg = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::";
|
||||
$output .= qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Hook</font></td></tr>
|
||||
<tr><td><$FONT>Hook: <input type="text" name="hook_name" size="10"> <select name="prepost"><option>PRE<option>POST</select></font></td>
|
||||
<td><$FONT>Code: <input type="text" name="code" value="$pkg"></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub hooks_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the hook info based on CGI object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
my @to_delete = $cgi->param('delete_hooks');
|
||||
foreach my $delete_pos (@to_delete) {
|
||||
splice(@{$self->{hooks}}, $delete_pos, 1);
|
||||
}
|
||||
if ($cgi->param('hook_name')) {
|
||||
my ($name, $prepost, $code) = ($cgi->param('hook_name'), uc $cgi->param('prepost'), $cgi->param('code'));
|
||||
push @{$self->{hooks}}, [$name, $prepost, $code];
|
||||
}
|
||||
}
|
||||
|
||||
sub admin_menu_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{admin_menu}}) {
|
||||
foreach my $menu (@{$self->{admin_menu}}) {
|
||||
my $menu_name = _escape_html($menu->[0]);
|
||||
my $menu_url = _escape_html($menu->[1]);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$menu_name</font></td><td><$FONT>=> $menu_url</font></td></tr>
|
||||
~;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No Admin Menu options installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub admin_menu_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (@{$self->{admin_menu}}) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Admin Menu options</font></td></tr>
|
||||
~;
|
||||
my $i = 0;
|
||||
foreach my $menu (@{$self->{admin_menu}}) {
|
||||
my $menu_name = _escape_html($menu->[0]);
|
||||
my $menu_url = _escape_html($menu->[1]);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$menu_name => $menu_url</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_admin_menu" value="$i"></font></td></tr>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
$output .= qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Menu</font></td></tr>
|
||||
<tr><td><$FONT>Name: <input type="text" name="menu_name" size="10"></font></td>
|
||||
<td><$FONT>URL: <input type="text" name="menu_url" size="20"></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub admin_menu_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the admin menu info based on CGI object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
my @to_delete = $cgi->param('delete_admin_menu');
|
||||
foreach my $delete_pos (@to_delete) {
|
||||
splice(@{$self->{admin_menu}}, $delete_pos, 1);
|
||||
}
|
||||
if ($cgi->param('menu_name')) {
|
||||
my ($name, $url) = ($cgi->param('menu_name'), $cgi->param('menu_url'));
|
||||
push @{$self->{admin_menu}}, [$name, $url];
|
||||
}
|
||||
}
|
||||
|
||||
sub options_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (keys %{$self->{options}}) {
|
||||
foreach my $key (sort keys %{$self->{options}}) {
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>~ . _escape_html($key) . qq~</font></td><td><$FONT>=> ~ . _escape_html($self->{options}->{$key}) . qq~</font></td></tr>
|
||||
~;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No user options installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub options_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
if (keys %{$self->{options}}) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed User options</font></td></tr>
|
||||
~;
|
||||
my $i = 0;
|
||||
foreach my $key (sort keys %{$self->{options}}) {
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>~ . _escape_html($key) . qq~ => ~ . _escape_html($self->{options}->{$key}) . qq~</font></td><td><$FONT>Delete: <input type="checkbox" name="delete_options" value="~ . _escape_html($key) . qq~"></font></td></tr>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
$output .= qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Add New Option</font></td></tr>
|
||||
<tr><td><$FONT>Name: <input type="text" name="add_key" size="10"></font></td>
|
||||
<td><$FONT>Default: <input type="text" name="add_val" size="20"></font></td></tr>
|
||||
~;
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub options_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Sets the options based on the user input.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
my @to_delete = $cgi->param('delete_options');
|
||||
foreach my $key (@to_delete) {
|
||||
delete $self->{options}->{$key};
|
||||
}
|
||||
my ($key, $value) = ($cgi->param('add_key'), $cgi->param('add_val'));
|
||||
if (defined $key and $key) {
|
||||
$self->{options}->{$key} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
sub files_as_html {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output;
|
||||
my $num_files = 0;
|
||||
if ($self->{tar}) {
|
||||
my $files = $self->{tar}->files;
|
||||
foreach my $file (@$files) {
|
||||
my $name = $file->name;
|
||||
my $size = $file->size;
|
||||
$size = ($size > 1000) ? sprintf("%0.2f kb", $size /1000) : "$size bytes";
|
||||
next if ($name =~ /Author\.pm$/);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$name</font></td><td><$FONT>$size</font></td></tr>
|
||||
~;
|
||||
$num_files++;
|
||||
}
|
||||
}
|
||||
if (! $num_files) {
|
||||
$output = qq~
|
||||
<tr><td><$FONT>No extra files installed</font></td></tr>
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub files_as_form {
|
||||
# ----------------------------------------------------------------
|
||||
# Returns meta info + version as form.
|
||||
#
|
||||
my ($self, $edit_url) = @_;
|
||||
my $output;
|
||||
my $num_files = 0;
|
||||
if ($self->{tar}) {
|
||||
my $files = $self->{tar}->files;
|
||||
foreach my $file (@$files) {
|
||||
my $name = _escape_html($file->name);
|
||||
my $size = $file->size;
|
||||
$size = ($size > 1000) ? sprintf("%0.2f kb", $size /1000) : "$size bytes";
|
||||
next if ($name =~ /Author\.pm$/);
|
||||
$output .= qq~
|
||||
<tr><td><$FONT>$name</font></td><td><$FONT>($size)</font></td></tr>
|
||||
~;
|
||||
$num_files++;
|
||||
}
|
||||
}
|
||||
if ($num_files) {
|
||||
$output = qq~
|
||||
<tr><td colspan=2 bgcolor="#DDDDDD" align="center"><$FONT>Installed Files</font></td></tr>
|
||||
$output
|
||||
~;
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub files_from_cgi {
|
||||
# ----------------------------------------------------------------
|
||||
# Set the file information.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
$self->{tar} or $self->_load_tar;
|
||||
my $filename = $cgi->param('add_name');
|
||||
my $filehandle = $cgi->param('add_file');
|
||||
my $body = $cgi->param('add_body');
|
||||
if ($filename) {
|
||||
if (ref $filehandle) {
|
||||
my ($buffer, $read);
|
||||
while ($read = read($filehandle, $buffer, 4096)) {
|
||||
$body .= $buffer;
|
||||
}
|
||||
}
|
||||
if (! $body) {
|
||||
$body = ' ';
|
||||
}
|
||||
$body =~ s/\r//g;
|
||||
my $res = $self->{tar}->add_data( name => $filename, body => $body );
|
||||
}
|
||||
my @to_delete = $cgi->param('delete_files');
|
||||
foreach my $file (@to_delete) {
|
||||
$self->{tar}->remove_file($file);
|
||||
}
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Private Methods #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub _load_plugin {
|
||||
# ----------------------------------------------------------------
|
||||
# Examines a plugin tar and fills up self with info.
|
||||
#
|
||||
my $self = shift;
|
||||
my $author = $self->{tar}->get_file('Author.pm') or return $self->error('CANTLOAD', 'WARN', $self->{plugin_name}, "No Author.pm file found in tar!");
|
||||
|
||||
# Eval the install file.
|
||||
my $file = $author->body_as_string;
|
||||
{
|
||||
local ($@, $SIG{__DIE__}, $^W);
|
||||
eval "$file";
|
||||
if ($@) {
|
||||
return $self->error('CANTLOAD', 'WARN', $file, "Author.pm does not compile: $@");
|
||||
}
|
||||
}
|
||||
|
||||
# Load the information.
|
||||
no strict 'refs';
|
||||
my $var = "$self->{prefix}Plugins::" . $self->{plugin_name} . "::AUTHOR";
|
||||
my $author_info = ${$var};
|
||||
if (ref $author_info eq 'HASH') {
|
||||
foreach my $key (keys %$author_info) {
|
||||
$self->{$key} = $author_info->{$key};
|
||||
}
|
||||
}
|
||||
use strict 'refs';
|
||||
$self->_load_install;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _load_tar {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads the tar file into memory.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $PLUGIN_DIR . "/Author/" . $self->{plugin_name} . ".tar";
|
||||
if (-e $file) {
|
||||
$self->{tar} = GT::Tar->open($file) or return $self->error('CANTLOAD', 'WARN', $file, $GT::Tar::error);
|
||||
}
|
||||
else {
|
||||
$self->{tar} = new GT::Tar($file) or return $self->error('CANTLOAD', 'WARN', $file, $GT::Tar::error);
|
||||
}
|
||||
}
|
||||
|
||||
sub _create_author {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the author.pm file used by the web tool to auto create the plugin.
|
||||
#
|
||||
my $self = shift;
|
||||
my $output = '';
|
||||
my $time = localtime();
|
||||
my $version = $self->{version} || 0;
|
||||
my $meta_dump = GT::Dumper->dump(var => '$META', data => $self->{meta});
|
||||
|
||||
$output = <<END_OF_PLUGIN;
|
||||
# ==================================================================
|
||||
# Auto Generated Plugin Configuration - Needed for Web Based Creator.
|
||||
#
|
||||
# $self->{prefix}Plugins::$self->{plugin_name}
|
||||
# Author : $self->{meta}->{author}
|
||||
# Version : $self->{version}
|
||||
# Updated : $time
|
||||
#
|
||||
# ==================================================================
|
||||
#
|
||||
|
||||
package $self->{prefix}Plugins::$self->{plugin_name};
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw/\$AUTHOR/;
|
||||
|
||||
END_OF_PLUGIN
|
||||
my $author = {};
|
||||
foreach (keys %$ATTRIBS) {
|
||||
next if ($_ eq 'tar');
|
||||
$author->{$_} = $self->{$_};
|
||||
}
|
||||
$output .= GT::Dumper->dump(var => '$AUTHOR', data => $author);
|
||||
$output .= "\n\n1;\n";
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub _escape_html {
|
||||
# -------------------------------------------------------------------
|
||||
# Escape html.
|
||||
#
|
||||
my $val = shift;
|
||||
defined $val or return '';
|
||||
$val =~ s/&/&/g;
|
||||
$val =~ s/</</g;
|
||||
$val =~ s/>/>/g;
|
||||
$val =~ s/"/"/g;
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _create_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub install {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated install function. Must return status message to user.
|
||||
#
|
||||
my \$mgr = new GT::Plugins::Manager;~;
|
||||
foreach my $hook (@{$self->{hooks}}) {
|
||||
$code .= qq~
|
||||
\$mgr->install_hooks('$self->{plugin_name}', [['$hook->[0]', '$hook->[1]', '$hook->[2]']]);~;
|
||||
}
|
||||
foreach my $menu (@{$self->{admin_menu}}) {
|
||||
$code .= qq~
|
||||
\$mgr->install_menu('$self->{plugin_name}', [['$menu->[0]', '$menu->[1]']]);~;
|
||||
}
|
||||
if (keys %{$self->{options}}) {
|
||||
my $options = GT::Dumper->dump(var => '$opts', data => $self->{options});
|
||||
$options =~ s/\n/\n\t/g;
|
||||
$code .= qq~
|
||||
my $options
|
||||
\$mgr->install_options('$self->{plugin_name}', \$opts);~;
|
||||
}
|
||||
$code .= qq~
|
||||
return "Plugin $self->{plugin_name} installed successfully.";
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _create_uninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the pre-install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub uninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated uninstall function. Must return status message to user.
|
||||
#
|
||||
my \$message = "Plugin $self->{plugin_name} has been uninstalled.";
|
||||
return \$message;
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _create_preinstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the pre-install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub pre_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated pre_install function. Must return status message to user.
|
||||
#
|
||||
my \$message = "INSERT INSTALL MESSAGE HERE";
|
||||
return \$message;
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _create_preuninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto generate the pre-install function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $code = qq~
|
||||
sub pre_uninstall {
|
||||
# -------------------------------------------------------------------
|
||||
# Auto-generated pre_uninstall function. Must return status message to user.
|
||||
#
|
||||
my \$message = "INSERT UNINSTALL MESSAGE HERE";
|
||||
return \$message;
|
||||
}
|
||||
~;
|
||||
return $code;
|
||||
}
|
||||
|
||||
sub _load_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Load the install functions from the Install.pm file.
|
||||
#
|
||||
my $self = shift;
|
||||
return unless ($self->{tar});
|
||||
my $install = $self->{tar}->get_file('Install.pm') or return;
|
||||
my $install_code = $install->body_as_string;
|
||||
$self->{pre_install} = $self->_parse_sub('pre_install', \$install_code);
|
||||
$self->{install} = $self->_parse_sub('install', \$install_code);
|
||||
$self->{pre_uninstall} = $self->_parse_sub('pre_uninstall', \$install_code);
|
||||
$self->{uninstall} = $self->_parse_sub('uninstall', \$install_code);
|
||||
}
|
||||
|
||||
sub _replace_install {
|
||||
# -------------------------------------------------------------------
|
||||
# Load the install functions from the Install.pm file.
|
||||
#
|
||||
my ($self, $install) = @_;
|
||||
return unless ($install);
|
||||
|
||||
my $install_code = $install->body_as_string;
|
||||
$install_code =~ s/\r//g;
|
||||
$self->_replace_sub('pre_install', \$install_code, $self->{pre_install});
|
||||
$self->_replace_sub('install', \$install_code, $self->{install});
|
||||
$self->_replace_sub('pre_uninstall', \$install_code, $self->{pre_uninstall});
|
||||
$self->_replace_sub('uninstall', \$install_code, $self->{uninstall});
|
||||
$install_code =~ s/(\$VERSION\s*=\s*)(['"]?)[\d\.]+(['"]?)/$1$2$self->{version}$3/;
|
||||
$install_code =~ s/(Version\s*:\s*)[\d\.]+/$1$self->{version}/;
|
||||
$install_code =~ s/\$META\s*=\s*[^\}]+\}[\s\n]*;[\s\n]*/GT::Dumper->dump(var => '$META', data => $self->{meta}) . "\n"/esm;
|
||||
$install->body($install_code);
|
||||
}
|
||||
|
||||
sub _parse_sub {
|
||||
# -------------------------------------------------------------------
|
||||
# Parse out a subroutine in some code, and return it.
|
||||
#
|
||||
my ($self, $sub, $code) = @_;
|
||||
return '' unless ($sub and $$code);
|
||||
|
||||
$$code =~ m/(\s*)(sub\s+$sub[^\{]*\{.*?\n\1\})/sm;
|
||||
my $code_block = $2 || '';
|
||||
$code_block =~ s/\r//g;
|
||||
return $code_block;
|
||||
}
|
||||
|
||||
sub _replace_sub {
|
||||
# -------------------------------------------------------------------
|
||||
# Parse out a subroutine in some code, and replace it.
|
||||
#
|
||||
my ($self, $sub, $code, $new) = @_;
|
||||
return unless ($new);
|
||||
$new =~ s/\r//g;
|
||||
$new =~ s/^[\s\n]+|[\s\n]$//g;
|
||||
$$code =~ s/\r//g;
|
||||
if (! ($$code =~ s/([\s\n]*)(sub\s+$sub[^\{]*\{.*?\n\1\})/\n$new/sm)) {
|
||||
$$code =~ s/1;[\s\n\r]+$//gsm;
|
||||
$$code .= "\n" . $new . "\n1;\n\n";
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
266
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Installer.pm
Normal file
266
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Installer.pm
Normal file
@ -0,0 +1,266 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Installer.pm,v 1.15 2006/11/22 01:21:14 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A web based admin to install/uninstall plugins.
|
||||
#
|
||||
|
||||
package GT::Plugins::Installer;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
|
||||
use vars qw/@ISA $ATTRIBS $ERROR_MESSAGE $VERSION $DEBUG/;
|
||||
use GT::Base;
|
||||
use GT::Plugins;
|
||||
use GT::Tar;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::Plugins';
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
plugin_dir => undef,
|
||||
prog_ver => undef,
|
||||
prog_user_cgi => undef,
|
||||
prog_admin_cgi => undef,
|
||||
prog_images => undef,
|
||||
prog_libs => undef
|
||||
};
|
||||
@ISA = qw/GT::Base/;
|
||||
|
||||
sub init {
|
||||
# ----------------------------------------------------------------
|
||||
# Load the plugin config file on init() called from GT::Base.
|
||||
#
|
||||
my $self = shift;
|
||||
my $param = $self->common_param(@_);
|
||||
$self->set($param);
|
||||
if (! $self->{plugin_dir} or ! -d $self->{plugin_dir}) {
|
||||
return $self->error('BADARGS', 'FATAL', "missing/invalid plugin dir passed to manager.");
|
||||
}
|
||||
$self->{cfg} = GT::Plugins->load_cfg($self->{plugin_dir});
|
||||
}
|
||||
|
||||
# ----------------------------------------------------------------------------------------- #
|
||||
# Utilities used in Install/Uninstall by Plugins #
|
||||
# ----------------------------------------------------------------------------------------- #
|
||||
|
||||
sub install_hooks {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of plugin hooks.
|
||||
#
|
||||
my ($self, $plugin, $hooks) = @_;
|
||||
if (ref $hooks ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_menu('PLUGINNAME', [['hookname', 'PRE/POST', 'action', status], ...])");
|
||||
}
|
||||
if (ref $hooks->[0] ne 'ARRAY') {
|
||||
$hooks = [ $hooks ];
|
||||
}
|
||||
foreach my $hook (@$hooks) {
|
||||
my ($hookname, $prepost, $action, $status) = @$hook;
|
||||
if (! ((uc $prepost eq 'PRE') or (uc $prepost eq 'POST'))) {
|
||||
die "Invalid hook argument. Must be pre/post, not: $prepost";
|
||||
}
|
||||
# Allow a hook to be installed as disabled by default, but for backwards compatibility, it has to be a 0 (not just a false value).
|
||||
$status = (defined $status and $status ne '' and $status == 0) ? 0 : 1;
|
||||
push @{$self->{cfg}->{$plugin}->{hooks}}, [lc $hookname, uc $prepost, $action, $status];
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of menu options for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $menus) = @_;
|
||||
if (ref $menus ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_menu('PLUGINNAME', [['title', 'url'], ...])");
|
||||
}
|
||||
if (ref $menus->[0] ne 'ARRAY') {
|
||||
$menus = [ $menus ];
|
||||
}
|
||||
foreach my $menu (@$menus) {
|
||||
push @{$self->{cfg}->{$plugin}->{menu}}, $menu;
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_options {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a list of options for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $opts, ) = @_;
|
||||
if (ref $opts ne 'ARRAY') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_options('PLUGINNAME', [['name', 'val', 'instructions'] ...])");
|
||||
}
|
||||
if (ref $opts->[0] ne 'ARRAY') {
|
||||
$opts = [ $opts ];
|
||||
}
|
||||
foreach my $opt (@$opts) {
|
||||
exists $self->{cfg}->{$plugin}->{user} or ($self->{cfg}->{$plugin}->{user} = []);
|
||||
push @{$self->{cfg}->{$plugin}->{user}}, $opt;
|
||||
}
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub install_registry {
|
||||
# -----------------------------------------------------------------
|
||||
# Register a registry item for a plugin.
|
||||
#
|
||||
my ($self, $plugin, $opts) = @_;
|
||||
if (ref $opts ne 'HASH') {
|
||||
return $self->error('BADARGS', 'FATAL', "Usage: $self->install_options('PLUGINNAME', { key => value, ... })");
|
||||
}
|
||||
my $registry = ($self->{cfg}->{$plugin}->{registry} ||= {});
|
||||
foreach my $key (keys %$opts) {
|
||||
$registry->{$key} = $opts->{$key};
|
||||
}
|
||||
|
||||
GT::Plugins->save_cfg($self->{plugin_dir}, $self->{cfg});
|
||||
}
|
||||
|
||||
sub uninstall_hooks {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove plugins, just a no-op as the config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $hooks) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove menus, no-op as config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $menus) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_options {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove options, just a no-op as config gets deleted.
|
||||
#
|
||||
my ($self, $plugin, $opts) = @_;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub uninstall_registry {
|
||||
# -----------------------------------------------------------------
|
||||
# Remove registry, just a no-op as config gets deleted.
|
||||
#
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::Plugins::Installer
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$mgr->install_hooks('PluginName', ['hook_name', 'PRE|POST', 'code', status]);
|
||||
$mgr->install_menu('PluginName', ['menu_name', 'menu_url', 'enabled']);
|
||||
$mgr->install_options('PluginName', ['option_key', 'option_val', 'instructions']);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The installer is an object that is passed into plugins during installation.
|
||||
It provides methods to add hooks, menu options, admin options or copy files
|
||||
into the users application.
|
||||
|
||||
=head2 install_hooks
|
||||
|
||||
C<install_hooks> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item hook_name
|
||||
|
||||
The hook you want to override.
|
||||
|
||||
=item PRE/POST
|
||||
|
||||
Either the string PRE or POST depending on whether the hook should be run
|
||||
before the main code, or after.
|
||||
|
||||
=item code
|
||||
|
||||
The name of the code to run. It should be Plugins::PACKAGE::YourPluginName::function.
|
||||
Where PACKAGE is the name of the Gossamer Product the plugin is for. For example
|
||||
Plugins::GMail::Wap::header
|
||||
|
||||
=item status
|
||||
|
||||
Whether or not the hook will be enabled or disabled. For backwards
|
||||
compatibility, if this option is set to anything but '0' then the hook will be
|
||||
enabled.
|
||||
|
||||
=back
|
||||
|
||||
C<install_hooks> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head2 install_menu
|
||||
|
||||
C<install_menu> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item menu_name
|
||||
|
||||
The name that will show up in the admin menu.
|
||||
|
||||
=item menu_url
|
||||
|
||||
The URL for the menu option.
|
||||
|
||||
=item enabled
|
||||
|
||||
Either true or false depending on whether the menu option should be shown.
|
||||
|
||||
=back
|
||||
|
||||
C<install_menu> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head2 install_options
|
||||
|
||||
C<install_options> takes as arguments the plugin name and an array of:
|
||||
|
||||
=over 4
|
||||
|
||||
=item option_key
|
||||
|
||||
This is the key, and is used when accessing the options hash.
|
||||
|
||||
=item option_value
|
||||
|
||||
This is the default value.
|
||||
|
||||
=item instructions
|
||||
|
||||
A string instruction users on what the plugin does.
|
||||
|
||||
=back
|
||||
|
||||
C<install_options> returns 1 on success, undef on failure with the error
|
||||
message in $GT::Plugins::error.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Installer.pm,v 1.15 2006/11/22 01:21:14 brewt Exp $
|
||||
|
||||
=cut
|
||||
1189
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Manager.pm
Normal file
1189
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Manager.pm
Normal file
File diff suppressed because it is too large
Load Diff
1098
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Wizard.pm
Normal file
1098
site/slowtwitch.com/cgi-bin/articles/GT/Plugins/Wizard.pm
Normal file
File diff suppressed because it is too large
Load Diff
155
site/slowtwitch.com/cgi-bin/articles/GT/RDF.pm
Normal file
155
site/slowtwitch.com/cgi-bin/articles/GT/RDF.pm
Normal file
@ -0,0 +1,155 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::RDF
|
||||
# Author : Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: RDF.pm,v 1.2 2001/04/11 02:37:12 alex Exp $
|
||||
#
|
||||
# Copyright (c) 2000 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: An RDF parser.
|
||||
#
|
||||
|
||||
package GT::RDF;
|
||||
|
||||
use GT::Base;
|
||||
use strict;
|
||||
use vars qw/$DEBUG @ISA $TAG $ERRORS/;
|
||||
|
||||
@ISA = qw(GT::Base);
|
||||
$DEBUG = 0;
|
||||
$TAG = 'Topic|ExternalPage';
|
||||
$ERRORS = {};
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
my $opt = {};
|
||||
if (@_ == 1) {
|
||||
$self->io (shift()) or return;
|
||||
}
|
||||
else {
|
||||
if (ref $_[0] eq 'HASH') { $opt = shift }
|
||||
elsif (defined ($_[0]) and not @_ % 2) { $opt = {@_} }
|
||||
exists ($opt->{io}) or return $self->error ("BADARGS", "FATAL", 'CLASS->new (%opt) %opt must contain the key io and it must be either a file handle or a path to a file.');
|
||||
$self->io ($opt->{io});
|
||||
}
|
||||
$self->{io} || return $self->error ("BADARGS", "FATAL", 'CLASS->new (\\*FH) -or- CLASS->new (%opts). You must define in input. Either a file or a file handle');
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub io {
|
||||
my ($self, $io) = @_;
|
||||
if (ref $io eq 'GLOB') {
|
||||
$self->{io} = $io;
|
||||
}
|
||||
elsif (-e $io) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
open $fh, $io or return $self->error ("OPENREAD", "FATAL", $!);
|
||||
$self->{io} = $fh;
|
||||
}
|
||||
else {
|
||||
return $self->error ("BADARGS", "FATAL", '$obj->io (\*FH) -or- $obj->io ("/path/to/file")');
|
||||
}
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
|
||||
my $io = $self->{io};
|
||||
|
||||
while (1) {
|
||||
$self->{name} = '';
|
||||
$self->{attribs} = {};
|
||||
$self->{tags} = [];
|
||||
my $parse;
|
||||
if ($self->{buffer} =~ s,(<($TAG).*?</\2[^>]*?>),$parse = $1; '',oes) {
|
||||
my @tokens = grep !/^\s*$/, split /(<[^>]+?>)/, $parse;
|
||||
my $start = shift (@tokens);
|
||||
|
||||
# Discard closing tag
|
||||
pop (@tokens);
|
||||
|
||||
# Get the start tag and its attributes
|
||||
$start =~ /^<($TAG)\s*(.*[^\/])>$/os;
|
||||
$self->{name} = $1;
|
||||
my $attr = $2;
|
||||
if ($attr) {
|
||||
my @tmp = split (/"/, $attr);
|
||||
my $ret = {};
|
||||
my $last = '';
|
||||
for (0 .. $#tmp) {
|
||||
if (!$_ % 2) {
|
||||
$tmp[$_] =~ s/^\s+|=$//g;
|
||||
$last = $tmp[$_];
|
||||
$ret->{$last} = '';
|
||||
}
|
||||
else {
|
||||
$ret->{$last} = $tmp[$_];
|
||||
}
|
||||
}
|
||||
$self->{attribs} = $ret;
|
||||
}
|
||||
|
||||
# Parse the remaining tags.
|
||||
my $last_entry;
|
||||
for (@tokens) {
|
||||
if (/^<([^\/\s]+)\s*(.*?[^\/])?>$/s) {
|
||||
my $tag = $1;
|
||||
my $attr = $2;
|
||||
my $ret = {};
|
||||
if ($attr) {
|
||||
my @tmp = split (/"/, $attr);
|
||||
my $last = '';
|
||||
for (0 .. $#tmp) {
|
||||
if (!$_ % 2) {
|
||||
$tmp[$_] =~ s/^\s+|=$//g;
|
||||
$last = $tmp[$_];
|
||||
$ret->{$last} = '';
|
||||
}
|
||||
else {
|
||||
$ret->{$last} = $tmp[$_];
|
||||
}
|
||||
}
|
||||
}
|
||||
$last_entry = { name => $tag, attribs => $ret };
|
||||
push (@{$self->{tags}}, $last_entry);
|
||||
}
|
||||
elsif (/^<([^\s\/]+)\s*(.*?)\/>$/s) {
|
||||
my $tag = $1;
|
||||
my $attr = $2;
|
||||
my $ret = {};
|
||||
if ($attr) {
|
||||
my @tmp = split (/"/, $attr);
|
||||
my $last = '';
|
||||
for (0 .. $#tmp) {
|
||||
if (!$_ % 2) {
|
||||
$tmp[$_] =~ s/^\s+|=$//g;
|
||||
$last = $tmp[$_];
|
||||
$ret->{$last} = '';
|
||||
}
|
||||
else {
|
||||
$ret->{$last} = $tmp[$_];
|
||||
}
|
||||
}
|
||||
}
|
||||
my $entry = { name => $tag, attribs => $ret };
|
||||
push (@{$self->{tags}}, $entry);
|
||||
}
|
||||
elsif (/^([^<]+)$/ and $last_entry) {
|
||||
$last_entry->{data} = $1;
|
||||
}
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
# No match
|
||||
else {
|
||||
my $tmp;
|
||||
read ($io, $tmp, 3072) or last;
|
||||
$self->{buffer} .= $tmp;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
716
site/slowtwitch.com/cgi-bin/articles/GT/SQL.pm
Normal file
716
site/slowtwitch.com/cgi-bin/articles/GT/SQL.pm
Normal file
@ -0,0 +1,716 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: SQL.pm,v 1.112 2007/08/30 00:14:38 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: A general purpose perl interface to a RDBMS.
|
||||
#
|
||||
|
||||
package GT::SQL;
|
||||
# ==================================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use GT::Config;
|
||||
use GT::SQL::Base;
|
||||
use GT::SQL::Table;
|
||||
use GT::SQL::Driver;
|
||||
use strict;
|
||||
use vars qw(@ISA $DEBUG $ERRORS $VERSION %OBJ_CACHE $error $errcode);
|
||||
|
||||
@ISA = qw(GT::SQL::Base);
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.112 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERRORS = {
|
||||
# Common Errors
|
||||
UNIQUE => "The column '%s' must be unique, and already has an entry '%s'",
|
||||
NOTABLE => 'No table defined -- call $db->table($table) before accessing',
|
||||
CANTOPEN => "Cannot open file '%s': %s",
|
||||
CANTOPENDIR => "Cannot read directory '%s': %s",
|
||||
FILENOEXISTS => "File '%s' does not exist or the permissions are set incorrectly",
|
||||
# GT::SQL Errors
|
||||
NODRIVER => "Database driver %s is not installed. Available drivers: %s",
|
||||
CANTLOAD => "Unable to load driver '%s': %s",
|
||||
BADPREFIX => "Invalid prefix: '%s'",
|
||||
NODATABASE => 'No database def file -- create def file with ->set_connect before calling $obj->%s',
|
||||
CANTCONNECT => "Could not connect to database: %s",
|
||||
CANTPREPARE => "Failed to prepare query: '%s': %s",
|
||||
CANTEXECUTE => "Failed to execute query: '%s': %s",
|
||||
BADSUBCLASS => "Unable to load subclass: '%s': %s",
|
||||
NEEDDEBUG => "You must turn on debug in order to access query logs",
|
||||
NOORACLEHOME => "The environment variable ORACLE_HOME is not defined. It must be defined for the script to connect properly",
|
||||
NONLSDATE => "Unable to set NLS_DATE_FORMAT: %s",
|
||||
# Table Errors
|
||||
BADNAME => "Invalid table name '%s'",
|
||||
NOTNULL => "Column %s cannot be left blank",
|
||||
NORECMOD => "The record you are attempting to modify no longer exists in the current table",
|
||||
NOVALUES => "You did not pass any valid column names to %s",
|
||||
BADMULTVALUES => "One or more of the value groups passed to %s contained an incorrect number of values",
|
||||
NOPKTOMOD => "Cannot modify record, no primary key specified",
|
||||
DEPENDENCY => "Table %s has dependencies. Aborting",
|
||||
ILLEGALVAL => "%s cannot contain the value '%s'",
|
||||
ALREADYCHANGED => "The record you are attempting to modify has changed since you last accessed it",
|
||||
REGEXFAIL => "The regular expressions %s for this column is not properly formed",
|
||||
FKNOTABLE => "A foreign key is referencing a non existant table: %s. GT::SQL load error: %s",
|
||||
FKNOEXISTS => "You attempted to remove non-existent foreign key '%s' from table '%s'",
|
||||
FKMISSING => "The '%s' table has a relationship with the '%s' table, but the foreign key information from the '%s' table is missing.",
|
||||
CIRCULAR => "Circular reference detected in the foreign key schema. Already seen column: %s",
|
||||
CIRCULARLIMIT => "Loop detected in circular reference check, hit maximum recursion depth of 100",
|
||||
# Relation Errors
|
||||
BADCOLS => "Bad columns / column clash: columns named '%s' have been found in current relation, please qualify your expression",
|
||||
# Creator Errors
|
||||
BADTYPE => "%s is not a supported type",
|
||||
AINOTPK => "Column %s defined as auto_increment but is not an INT",
|
||||
TBLEXISTS => "Could not create table '%s': It already exists",
|
||||
NOTABLEDEFS => "You must define your table before creating it",
|
||||
NOPOS => "No position column was found in definition for column: %s",
|
||||
# Editor Errors
|
||||
NOCOL => "There is no column %s in this table",
|
||||
REFCOL => "You cannot alter column %s, as table %s still has references to it. Remove those references first",
|
||||
NOPK => "There is no primary key for this table",
|
||||
COLREF => "You cannot alter column %s, as it is a foreign key. Remove the foreign key first",
|
||||
NOINDEX => "You are trying to modify an index that does not exist",
|
||||
NOUNIQUE => "You are trying to drop a unique column '%s', but it is not unique",
|
||||
INDXQTEXT => "Cannot create index on '%s' as it is a text/blob field",
|
||||
COLEXISTS => "Unable to add column '%s' - already exists",
|
||||
NOTUNIQUE => "Cannot create unique index on '%s', data is not unique",
|
||||
INDXEXISTS => "Unable to add index '%s' - already exists",
|
||||
PKTEXT => "Column %s specified as a primary key but is a text or a blob type",
|
||||
UNIQTEXT => "Column %s specified as a unique but is a text or blob column type",
|
||||
TABLEREFD => "%s cannot be dropped as table still has references to it",
|
||||
NOFILESAVEIN => "Column %s must have file_save_in set if is to be File type",
|
||||
NODIRPRIV => "Privileges on directory %s do not allow write or directory does not exist",
|
||||
SAMEDRIVER => "Search Driver '%s' is unchanged",
|
||||
NOTNULLDEFAULT => "Column %s was specified as not null, but has no default value",
|
||||
# Admin Error
|
||||
NOACTION => "The CGI object passed in did not contain a valid action. %s",
|
||||
# Tree errors
|
||||
NOTREE => "No tree object exists for table '%s'. Create a tree first with \$editor->add_tree",
|
||||
NOTREEOBJ => "You attempted to call '%s' without a valid tree object. Call \$table->tree() first",
|
||||
TREEEXISTS => "A tree already exists for table '%s'",
|
||||
TREENOCANDO => "You attempted to call '%s' on table '%s', but that table has a tree attached and does not support the command",
|
||||
TREENOIDS => "You did not pass any ID's to %s",
|
||||
TREEBADPK => "You tried to create a tree on table '%s', but that table doesn't have a primary key, or has multiple primary keys",
|
||||
TREEBADJOIN => "Joining more than 2 tables with a tree is not supported. You attempted to join: %s",
|
||||
TREEFATHER => "Unable to update a tree record to a descendant of itself",
|
||||
# Driver errors
|
||||
DRIVERPROTOCOL => "Driver implements wrong protocol: protocol v%d required, driver is v%d",
|
||||
};
|
||||
|
||||
use constant DEF_HEADER => <<'HEADER';
|
||||
# Database access & configuration file
|
||||
# Last updated: [localtime]
|
||||
# Created by GT::SQL $Revision: 1.112 $
|
||||
HEADER
|
||||
|
||||
sub new {
|
||||
# -------------------------------------------------------------------
|
||||
# GT::SQL constructor. Takes:
|
||||
# my $db = new GT::SQL '/path/to/def';
|
||||
# my $db = new GT::SQL { def_path => '/defpath', debug => 1 };
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless { _err_pkg => __PACKAGE__, _debug => $DEBUG }, $class;
|
||||
|
||||
# Get our arguments into a hash ref
|
||||
my $opts = {};
|
||||
if (@_ == 0) { $opts = {}; }
|
||||
elsif (@_ == 1 and ref $_[0] eq 'HASH') { $opts = shift; }
|
||||
elsif (@_ > 1 and !(@_ % 2)) { $opts = {@_}; }
|
||||
else {
|
||||
$opts->{def_path} = shift;
|
||||
}
|
||||
|
||||
# Set debugging level, caching options and whether to allow subclassing.
|
||||
$self->{_debug} = exists $opts->{debug} ? $opts->{debug} : $DEBUG;
|
||||
$self->{cache} = exists $opts->{cache} ? $opts->{cache} : 1;
|
||||
$self->{subclass} = exists $opts->{subclass} ? $opts->{subclass} : 1;
|
||||
|
||||
# Def path must exist and be a directory
|
||||
exists $opts->{def_path} or return $self->fatal(BADARGS => "$class->new(HASH_REF). def_path must be defined and a directory path in the hash");
|
||||
-d $opts->{def_path} or return $self->fatal(BADARGS => "The defs directory '$opts->{def_path}' does not exist, or is not a directory");
|
||||
|
||||
# Load the database def file if it exists
|
||||
|
||||
# Some old programs would sometimes erroneously leave an invalid blank
|
||||
# database.def file in the def_path; if such a file exists, make GT::Config
|
||||
# ignore it.
|
||||
my $empty = (-f "$opts->{def_path}/database.def" and !-s _);
|
||||
|
||||
$self->{connect} = GT::Config->load(
|
||||
"$opts->{def_path}/database.def" => {
|
||||
create_ok => 1,
|
||||
chmod => 0666,
|
||||
debug => $self->{_debug},
|
||||
header => DEF_HEADER,
|
||||
($empty ? (empty => 1) : ()),
|
||||
}
|
||||
);
|
||||
|
||||
$self->{connect}->{PREFIX} = '' unless defined $self->{connect}->{PREFIX};
|
||||
# Heavily deprecated. Not guaranteed to always be correct:
|
||||
$GT::SQL::PREFIX = $self->{connect}->{PREFIX};
|
||||
$self->{connect}->{def_path} = $opts->{def_path};
|
||||
$self->{connect}->{obj_cache} = $self->{cache};
|
||||
|
||||
$self->debug("OBJECT CREATED") if $self->{_debug} and $self->{_debug} > 2;
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{set_connect} = __LINE__ . <<'END_OF_SUB';
|
||||
sub set_connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Sets the connection info, only needed to setup the database.def file.
|
||||
# $db->set_connect({
|
||||
# driver => 'mysql',
|
||||
# host => 'localhost',
|
||||
# port => 2323,
|
||||
# database => 'mydatabase',
|
||||
# login => 'user',
|
||||
# password => 'foo',
|
||||
# }) or die "Can't connect: $GT::SQL::error";
|
||||
#
|
||||
my $self = shift;
|
||||
my $connect = $self->{connect};
|
||||
my %old_connect = %$connect;
|
||||
# Parse our arguments.
|
||||
if (!@_) { return $self->fatal(BADARGS => '$obj->set_connect(HASH_REF)') }
|
||||
elsif (@_ == 1 and ref $_[0] eq 'HASH') { %$connect = %{+shift} }
|
||||
elsif (@_ % 2 == 0) { %$connect = @_ }
|
||||
else { return $self->fatal(BADARGS => '$obj->set_connect(HASH_REF)') }
|
||||
|
||||
if (keys %old_connect) {
|
||||
for (keys %old_connect) {
|
||||
$connect->{$_} = $old_connect{$_} unless exists $connect->{$_};
|
||||
}
|
||||
}
|
||||
$connect->{PREFIX} = '' unless defined $connect->{PREFIX};
|
||||
|
||||
# Fix the connect string for test connecting
|
||||
$connect->{driver} ||= 'mysql';
|
||||
|
||||
# Make sure DBI has been loaded
|
||||
eval { require DBI };
|
||||
$@ and return $self->warn(CANTCONNECT => "DBI module not installed. You must install the perl database module DBI from: http://www.perl.com/CPAN/modules/by-module/DBI");
|
||||
|
||||
# Make sure the requested driver exists
|
||||
my @drivers = GT::SQL::Driver->available_drivers;
|
||||
unless (grep $_ eq uc $connect->{driver}, @drivers, 'ODBC') {
|
||||
return $self->warn(NODRIVER => $connect->{driver}, join ", ", @drivers);
|
||||
}
|
||||
|
||||
my $raiseerror = delete $connect->{RaiseError};
|
||||
my $printerror = delete $connect->{PrintError};
|
||||
$connect->{RaiseError} = 0;
|
||||
$connect->{PrintError} = 0;
|
||||
|
||||
# Get our driver.
|
||||
my $table = GT::SQL::Table->new(connect => $connect, debug => $self->{_debug});
|
||||
$table->connect or return;
|
||||
|
||||
# Put things back the way they were.
|
||||
$connect->{RaiseError} = defined $raiseerror ? $raiseerror : 1;
|
||||
$connect->{PrintError} = defined $printerror ? $printerror : 0;
|
||||
|
||||
$self->{connect} = $connect;
|
||||
|
||||
# Use this connect string from now on.
|
||||
$self->write_db_config;
|
||||
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{write_db_config} = __LINE__ . <<'END_OF_SUB';
|
||||
sub write_db_config {
|
||||
# -------------------------------------------------------------------
|
||||
# Saves the database.def file. Takes no arguments.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{connect}->save;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# ============================================================================ #
|
||||
# DATABASE INFO ACCESSORS #
|
||||
# ============================================================================ #
|
||||
$COMPILE{driver} = __LINE__ . <<'END_OF_SUB';
|
||||
sub driver {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the name of the driver being used.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{driver};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{host} = __LINE__ . <<'END_OF_SUB';
|
||||
sub host {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the name of the host being used.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{host};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{port} = __LINE__ . <<'END_OF_SUB';
|
||||
sub port {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the port currently being used, undef if default.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{port};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{database} = __LINE__ . <<'END_OF_SUB';
|
||||
sub database {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the name of the database being used.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{database};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{login} = __LINE__ . <<'END_OF_SUB';
|
||||
sub login {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the login username for the current connection.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{login};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{password} = __LINE__ . <<'END_OF_SUB';
|
||||
sub password {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the login password for the current connection.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{connect}->{password};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# ============================================================================ #
|
||||
# HTML ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
$COMPILE{html} = __LINE__ . <<'END_OF_SUB';
|
||||
sub html {
|
||||
# -------------------------------------------------------------------
|
||||
# Return an html object. Takes an array ref of table names, or a, and a cgi
|
||||
# object.
|
||||
# my $html = $db->html(['Links'], $in);
|
||||
# or
|
||||
# my $html = $db->html($table_obj, $in);
|
||||
#
|
||||
my ($self, $tables, $cgi) = @_;
|
||||
ref $tables or return $self->fatal(BADARGS => 'Error: no table array ref passed to html');
|
||||
ref $cgi or return $self->fatal(BADARGS => 'Error: no cgi object/hash ref passed to html');
|
||||
|
||||
# If already passed a table object, use it, otherwise create a new one
|
||||
my ($table);
|
||||
if (ref $tables eq 'ARRAY') {
|
||||
$table = $self->table(@$tables);
|
||||
}
|
||||
elsif (UNIVERSAL::isa($tables, 'GT::SQL::Table') or UNIVERSAL::isa($tables, 'GT::SQL::Relation')) {
|
||||
$table = $tables;
|
||||
}
|
||||
else {
|
||||
return $self->fatal(BADARGS => "Error: '$tables' must be either an array ref or a table object");
|
||||
}
|
||||
|
||||
my $meth = @{[$table->name]} > 1 ? "_html_relation" : "_html_table";
|
||||
$self->$meth($table, $cgi);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_html_relation} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _html_relation {
|
||||
my ($self, $rel, $cgi) = @_;
|
||||
|
||||
my $class;
|
||||
my $key = join "\0", map { s/^$self->{connect}->{PREFIX}//; $_ } sort keys %{$rel->{tables}};
|
||||
foreach my $table (values %{$rel->{tables}}) {
|
||||
my $subclass = $table->subclass;
|
||||
if ($self->{subclass} and exists $subclass->{html}->{$self->{connect}->{PREFIX} . $key}) {
|
||||
$class = $subclass->{html}->{$self->{connect}->{PREFIX} . $key};
|
||||
$self->_load_module($class) or return;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
if (!$class) {
|
||||
require GT::SQL::Display::HTML::Relation;
|
||||
$class = 'GT::SQL::Display::HTML::Relation';
|
||||
}
|
||||
return $class->new(
|
||||
db => $rel,
|
||||
input => $cgi
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_html_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _html_table {
|
||||
my ($self, $table, $cgi) = @_;
|
||||
my $class;
|
||||
if ($self->{subclass} and $table->{schema}->{subclass}->{html}->{$table->name}) {
|
||||
$class = $table->{schema}->{subclass}->{html}->{$table->name};
|
||||
$self->_load_module($class) or return;
|
||||
}
|
||||
if (!$class) {
|
||||
require GT::SQL::Display::HTML::Table;
|
||||
$class = 'GT::SQL::Display::HTML::Table';
|
||||
}
|
||||
return $class->new(
|
||||
db => $table,
|
||||
input => $cgi
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub query_stack {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns raw query stack (as array/array ref).
|
||||
#
|
||||
return wantarray ? @GT::SQL::Driver::debug::QUERY_STACK : \@GT::SQL::Driver::debug::QUERY_STACK;
|
||||
}
|
||||
|
||||
sub query_stack_disp {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns formatted query stack (handled in Driver.pm).
|
||||
#
|
||||
my ($out, $i) = ('', 0);
|
||||
foreach (reverse 0 .. $#GT::SQL::Driver::debug::QUERY_STACK) {
|
||||
my $query = $GT::SQL::Driver::debug::QUERY_STACK[$_];
|
||||
my $stack = $GT::SQL::Driver::debug::STACK_TRACE[$_] || '';
|
||||
$i++;
|
||||
chomp $query;
|
||||
$query =~ s/^[\s]*(.*?)[\s]*$/$1/mg;
|
||||
$query =~ s/\n/\n /mg;
|
||||
$out .= "$i: $query\n$stack";
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prefix {
|
||||
# -------------------------------------------------------------------
|
||||
# Set/Get the database prefix to be attached to all tables. Calling this as a
|
||||
# class accessor method is extremely deprecated (it returns $GT::SQL::PREFIX,
|
||||
# which is itself extremely deprecated); calling this to *set* a prefix is not
|
||||
# permitted.
|
||||
#
|
||||
|
||||
my $self = shift;
|
||||
|
||||
if (@_) {
|
||||
ref $self or $self->fatal(BADARGS => 'Usage: $obj->prefix(...) not CLASS->prefix(...)');
|
||||
my $prefix = shift;
|
||||
if ($prefix =~ /\W/) {
|
||||
return $self->fatal(BADPREFIX => $prefix);
|
||||
}
|
||||
$self->{connect}->{PREFIX} = $prefix;
|
||||
}
|
||||
else {
|
||||
return ref $self ? $self->{connect}->{PREFIX} : $GT::SQL::PREFIX;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{reset_env} = __LINE__ . <<'END_OF_SUB';
|
||||
sub reset_env {
|
||||
# -------------------------------------------------------------------
|
||||
# Reset globals.
|
||||
#
|
||||
GT::SQL::Driver->reset_env(); # Shut down database connections.
|
||||
%OBJ_CACHE = ();
|
||||
$error = '';
|
||||
$errcode = '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL - A database independent perl interface
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::SQL;
|
||||
|
||||
my $db = GT::SQL->new('/path/to/def');
|
||||
my $table = $db->table('Links');
|
||||
my $editor = $db->editor('Links');
|
||||
my $creator = $db->creator('NewTable');
|
||||
my $html = $db->html('Links', new CGI);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::SQL is a perl database abstraction layer to relational databases, providing
|
||||
a native Perl interface rather than a query-based interface.
|
||||
|
||||
A GT::SQL object provides the interface to the entire database by providing
|
||||
objects that are able to perform the work needed.
|
||||
|
||||
=head2 Creating a new GT::SQL object
|
||||
|
||||
There are two ways to get a GT::SQL object. First, you can simply provide the
|
||||
path to the def file directory where GT::SQL stores all it's information:
|
||||
|
||||
$db = GT::SQL->new('/path/to/def');
|
||||
|
||||
or you can pass in a hash or hash ref and specify options:
|
||||
|
||||
$db = GT::SQL->new(
|
||||
def_path => '/path/to/def',
|
||||
cache => 1,
|
||||
debug => 1,
|
||||
subclass => 1
|
||||
);
|
||||
|
||||
You must specify def_path. Setting C<cache =E<gt> 1> will result in all table
|
||||
and relation objects being cached, which provides a performance improvement in
|
||||
any situation where the same table or relation is used again.
|
||||
|
||||
Specifying C<subclass =E<gt> 0> or C<subclass =E<gt> 1> will enable or disable
|
||||
the ability to subclass any of the objects GT::SQL creates. The default
|
||||
value is C<1>, and should not normally be changed.
|
||||
|
||||
GT::SQL has significant amounts of debugging output that can be enabled by
|
||||
specifying a value of C<1> to the C<debug> option. Larger values can be
|
||||
specified for more detailed debugging output, however a level of C<1> is almost
|
||||
always more than sufficient. The accepted values are as follows:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Level 0
|
||||
|
||||
This is the default, no debugging information is printed to stderr. All errors
|
||||
can be obtained in $GT::SQL::error.
|
||||
|
||||
=item Level 1
|
||||
|
||||
All queries will be displayed to stderr. This is the recommended value if
|
||||
query debugging is desired.
|
||||
|
||||
=item Level 2
|
||||
|
||||
Same as level 1, but includes more detailed information. Also, when calling
|
||||
query_stack you get a stack trace on what generated each query. Not
|
||||
recommended except when working directly on GT::SQL.
|
||||
|
||||
=item Level 3
|
||||
|
||||
Very detailed debug logs including creation and destruction of objects.
|
||||
query_stack generates a javascript page with query, stack trace, and data dump
|
||||
of arguments, but can be extremely large. Not recommended except for debugging
|
||||
GT::SQL internals.
|
||||
|
||||
=back
|
||||
|
||||
B<Pass in a def path>
|
||||
|
||||
$obj = GT::SQL->new('/path/to/def/directory');
|
||||
|
||||
This method of calling new is also supported, however has the drawback that
|
||||
none of the above options can be provided.
|
||||
|
||||
=head2 Getting Connected
|
||||
|
||||
GT::SQL loads the database connection info from database.def which is located
|
||||
in the defs directory.
|
||||
|
||||
To create this file, you call set_connect() as follows:
|
||||
|
||||
$obj->set_connect({
|
||||
driver => 'mysql',
|
||||
host => 'localhost',
|
||||
port => 3243,
|
||||
database => 'databasename',
|
||||
login => 'username',
|
||||
password => 'password',
|
||||
PREFIX => 'prefix_'
|
||||
});
|
||||
|
||||
This will test the database information, and save it to the def file. All
|
||||
future connections will automatically use this connection information.
|
||||
|
||||
Not all of the arguments in this hash are necessary; some have reasonable
|
||||
defaults for the connection.
|
||||
|
||||
=over 4
|
||||
|
||||
=item driver
|
||||
|
||||
This needs to be the driver that is being used for the connection. The default
|
||||
for this is C<mysql>. Driver names are case-insensitive. Available drivers
|
||||
are:
|
||||
|
||||
=over 4
|
||||
|
||||
=item MySQL
|
||||
|
||||
Driver for MySQL databases. Requires that the DBD::mysql module be installed.
|
||||
|
||||
=item Pg
|
||||
|
||||
Driver for PostgreSQL databases. Requires that the DBD::Pg module be
|
||||
installed.
|
||||
|
||||
=item MSSQL
|
||||
|
||||
Driver for MSSQL 7.0 and above. Requires that the DBD::ODBC module be
|
||||
installed.
|
||||
|
||||
=item Oracle
|
||||
|
||||
Driver for Oracle 8 and above. Requires the DBD::Oracle module.
|
||||
|
||||
=back
|
||||
|
||||
=item host
|
||||
|
||||
This will specify the host to connect to. The default, which is acceptable for
|
||||
most installations, is C<localhost>.
|
||||
|
||||
=item port
|
||||
|
||||
This is the port on which to connect to the SQL server. The default for this
|
||||
is to allow the DBI driver to choose the default, which is almost always the
|
||||
appropriate choice.
|
||||
|
||||
=item database
|
||||
|
||||
This is the database name to use on the SQL server. This is required to
|
||||
connect. For MSSQL, this is the I<Data Source> name.
|
||||
|
||||
=item PREFIX
|
||||
|
||||
This specifies a prefix to use for table names. See the L</"Table Prefixes">
|
||||
section below for more information.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Supported Objects
|
||||
|
||||
The following objects can be obtained through a GT::SQL object:
|
||||
|
||||
=over 4
|
||||
|
||||
=item Table/Relation
|
||||
|
||||
To get a table or relation object for working with SQL tables, you should call:
|
||||
|
||||
my $table = $db->table('table_name');
|
||||
|
||||
or for a table join:
|
||||
|
||||
my $relation = $db->table('table_name', 'other_table');
|
||||
|
||||
See L<GT::SQL::Table> for more information on how to use a table object.
|
||||
|
||||
=item Creator
|
||||
|
||||
To create new tables, you need to use a creator. You can get one by calling:
|
||||
|
||||
my $creator = $db->creator('new_table');
|
||||
|
||||
where C<new_table> is the name of the table you wish to create. See
|
||||
L<GT::SQL::Creator> for more information on how to use a creator object.
|
||||
|
||||
=item Editor
|
||||
|
||||
To edit existing tables (i.e. add/drop/change columns, add/drop indexes, etc.)
|
||||
you need an editor object:
|
||||
|
||||
my $editor = $db->editor('existing_table');
|
||||
|
||||
where C<existing_table> is the name of the table you wish the modify. See
|
||||
L<GT::SQL::Editor> for more information on how to use an editor object.
|
||||
|
||||
=item HTML
|
||||
|
||||
To get an html object for generating forms and html output, you need to pass in
|
||||
the table/relation object you want to work with, and a cgi object:
|
||||
|
||||
my $html = $db->html($table, $cgi);
|
||||
|
||||
The html object uses information found in CGI to set values, etc. See
|
||||
L<GT::SQL::Display::HTML> for more information on how to use a html object.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Table Prefixes
|
||||
|
||||
GT::SQL supports the concept of table prefixes. If you specify a prefix using
|
||||
the accessor, it is saved in the database.def file and will be used in all
|
||||
future calls to table(), editor() and creator().
|
||||
|
||||
To set a prefix:
|
||||
|
||||
$db->prefix("foo");
|
||||
|
||||
to get the current prefix:
|
||||
|
||||
my $prefix = $db->prefix;
|
||||
|
||||
What this will do is transparently prepend C<foo> to the beginning of every
|
||||
table name. This means anywhere you access the table C<bar>, the actual table
|
||||
stored on the SQL server will be C<foobar>. Note that the prefix should B<not>
|
||||
be included when getting table/creator/editor/etc. objects - the prefix is
|
||||
handled completely transparently to all public GT::SQL functionality.
|
||||
|
||||
=head2 Query Stack
|
||||
|
||||
To display a list of all raw SQL queries sent to the database you can use:
|
||||
|
||||
my @queries = $db->query_stack;
|
||||
|
||||
or to have them formatted try
|
||||
|
||||
print $db->query_stack_disp;
|
||||
|
||||
which will join them up, displayed nicely. This is also available as a class
|
||||
method:
|
||||
|
||||
print GT::SQL->query_stack_disp;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<GT::SQL::Table>
|
||||
|
||||
L<GT::SQL::Editor>
|
||||
|
||||
L<GT::SQL::Creator>
|
||||
|
||||
L<GT::SQL::Types>
|
||||
|
||||
L<GT::SQL::Admin>
|
||||
|
||||
L<GT::SQL::Display::HTML>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: SQL.pm,v 1.112 2007/08/30 00:14:38 brewt Exp $
|
||||
|
||||
=cut
|
||||
2994
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Admin.pm
Normal file
2994
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Admin.pm
Normal file
File diff suppressed because it is too large
Load Diff
607
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Base.pm
Normal file
607
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Base.pm
Normal file
@ -0,0 +1,607 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Table
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Base.pm,v 1.72 2011/05/13 23:56:51 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base class for GT::SQL::Table and GT::SQL::Relation
|
||||
#
|
||||
|
||||
package GT::SQL::Base;
|
||||
# ===============================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use strict;
|
||||
use vars qw($ERRORS $DEBUG @ISA $VERSION $ERROR_MESSAGE);
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.72 $ =~ /(\d+)\.(\d+)/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
|
||||
# ============================================================================ #
|
||||
# TABLE ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
sub table {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a table or relation argument. Called with array of table names:
|
||||
# my $relation = $db->table('Links', 'CatLinks', 'Category');
|
||||
# my $table = $db->table('Links');
|
||||
#
|
||||
my ($self, @tables) = @_;
|
||||
|
||||
# Make sure we have a driver, and a list of tables were specified.
|
||||
$self->{connect} or return $self->fatal(NODATABASE => 'table()');
|
||||
@tables or return $self->fatal(BADARGS => 'Usage: $obj->table(@TABLES)');
|
||||
|
||||
for (@tables) { # Tables aren't passed to table() prefixed, so prefix them all.
|
||||
$_ = $self->{connect}->{PREFIX} . $_;
|
||||
}
|
||||
my $cache_key = join("\0", @tables, $self->{connect}->{def_path});
|
||||
$cache_key = (@tables > 1 ? "RELATION\0" : "TABLE\0") . $cache_key;
|
||||
$self->{cache} and exists $GT::SQL::OBJ_CACHE{$cache_key} and return $GT::SQL::OBJ_CACHE{$cache_key};
|
||||
|
||||
my $obj;
|
||||
if (@tables > 1) {
|
||||
$obj = $self->new_relation(@tables);
|
||||
}
|
||||
else {
|
||||
my $name = $self->{connect}->{def_path} . '/' . $tables[0] . '.def';
|
||||
(-e $name) or return $self->fatal(FILENOEXISTS => $name);
|
||||
$obj = $self->new_table($tables[0]);
|
||||
}
|
||||
# We don't need to worry about caching here - new_relation or new_table will add it to the cache.
|
||||
return $obj;
|
||||
}
|
||||
|
||||
# ============================================================================ #
|
||||
# EDITOR ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
|
||||
$COMPILE{editor} = __LINE__ . <<'END_OF_SUB';
|
||||
sub editor {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns an editor object. Takes a table name as argument.
|
||||
# my $editor = $db->editor('Links')
|
||||
#
|
||||
my $self = shift;
|
||||
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->editor(\'tablename\')');
|
||||
|
||||
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'editor()');
|
||||
|
||||
my $table = $self->table($table_name);
|
||||
|
||||
# Set the error package to reflect the editor
|
||||
$table->{_err_pkg} = 'GT::SQL::Editor';
|
||||
$table->{_err_pkg} = 'GT::SQL::Editor';
|
||||
|
||||
# Get an editor object
|
||||
require GT::SQL::Editor;
|
||||
$self->debug("CREATING GT::SQL::Editor OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
return GT::SQL::Editor->new(
|
||||
debug => $self->{_debug},
|
||||
table => $table,
|
||||
connect => $self->{connect}
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prefix} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prefix {
|
||||
my $self = shift;
|
||||
return $self->{connect}->{PREFIX};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub new_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates a table object for a single table.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $cache_key = "TABLE\0$table\0$self->{connect}->{def_path}";
|
||||
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
|
||||
$self->debug("Returning table object for $table from cache") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $cached;
|
||||
}
|
||||
|
||||
$self->debug("Creating new table object for $table") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
# Create a blank table object.
|
||||
my $table_obj = GT::SQL::Table->new(
|
||||
name => $table, # Already prefixed in schema
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Table'
|
||||
);
|
||||
|
||||
# Create a new object if we are subclassed.
|
||||
my $subclass = $table_obj->subclass;
|
||||
my $name = $table_obj->name;
|
||||
my $class = $subclass->{table}->{$name} || 'GT::SQL::Table';
|
||||
if ($subclass and $subclass->{table}->{$name}) {
|
||||
no strict 'refs';
|
||||
$self->_load_module($class) or return;
|
||||
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : {};
|
||||
foreach (keys %$errors) {
|
||||
$ERRORS->{$_} = $errors->{$_};
|
||||
}
|
||||
use strict 'refs';
|
||||
$table_obj = $class->new(
|
||||
name => $name, # Already prefixed in schema
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Table',
|
||||
_schema => $table_obj->{schema}
|
||||
);
|
||||
}
|
||||
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
|
||||
$GT::SQL::OBJ_CACHE{$cache_key} = $table_obj if $self->{connect}->{obj_cache};
|
||||
return $table_obj;
|
||||
}
|
||||
|
||||
sub new_relation {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the table objects and relation object for multi-table tasks.
|
||||
# Internal use. Call table instead.
|
||||
#
|
||||
my ($self, @tables) = @_;
|
||||
my $href = {};
|
||||
my $tables_ord = [];
|
||||
my $tables = {};
|
||||
|
||||
require GT::SQL::Relation;
|
||||
|
||||
my $cache_key = join "\0", "RELATION", @tables, $self->{connect}->{def_path};
|
||||
if ($self->{connect}->{obj_cache} and my $cached = $GT::SQL::OBJ_CACHE{$cache_key}) {
|
||||
$self->debug("Returning relation object for @tables from cache") if $self->{_debug} and $self->{_debug} >= 2;
|
||||
return $cached;
|
||||
}
|
||||
|
||||
# Build our hash of prefixed table name to table object.
|
||||
foreach my $table (@tables) {
|
||||
$self->debug("CREATING GT::SQL::Table OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
my $tmp = $self->new_table($table);
|
||||
my $name = $tmp->name;
|
||||
push @$tables_ord, $name;
|
||||
$tables->{$name} = $tmp;
|
||||
}
|
||||
|
||||
# Get our driver, class name and key to look up subclasses (without prefixes).
|
||||
my $class = 'GT::SQL::Relation';
|
||||
my $prefix = $self->{connect}->{PREFIX};
|
||||
my $subclass_key = join "\0", map { s/^$prefix//; $_ } sort keys %{$tables};
|
||||
|
||||
# Look for any subclass to use, and load any error messages.
|
||||
no strict 'refs';
|
||||
|
||||
foreach my $table (values %{$tables}) {
|
||||
my $subclass = $table->subclass;
|
||||
if ((!exists $self->{subclass} or $self->{subclass}) and exists $subclass->{relation}->{$prefix . $subclass_key}) {
|
||||
$class = $subclass->{relation}->{$prefix . $subclass_key};
|
||||
my $errors = defined ${$class . "::ERRORS"} ? ${$class . "::ERRORS"} : next;
|
||||
foreach (keys %$errors) {
|
||||
$ERRORS->{$_} = $errors->{$_};
|
||||
}
|
||||
}
|
||||
}
|
||||
use strict 'refs';
|
||||
|
||||
# Load our relation object.
|
||||
$self->debug("CREATING $class OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
$self->_load_module($class) or return;
|
||||
|
||||
my $rel = $class->new(
|
||||
tables => $tables,
|
||||
debug => $self->{_debug},
|
||||
connect => $self->{connect},
|
||||
_err_pkg => 'GT::SQL::Relation',
|
||||
tables_ord => $tables_ord
|
||||
);
|
||||
$GT::SQL::OBJ_CACHE{$cache_key} = $rel if ($self->{connect}->{obj_cache});
|
||||
|
||||
return $rel;
|
||||
}
|
||||
|
||||
# ============================================================================ #
|
||||
# CREATOR ACCESSSOR #
|
||||
# ============================================================================ #
|
||||
$COMPILE{creator} = __LINE__ . <<'END_OF_SUB';
|
||||
sub creator {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a creator object. Takes a table name as argument.
|
||||
# my $creator = $db->creator('Links')
|
||||
#
|
||||
my $self = shift;
|
||||
my $table_name = shift or return $self->fatal(BADARGS => 'Usage: $db->creator(\'tablename\')');
|
||||
$self->{connect}->{driver} or return $self->fatal(NODATABASE => 'creator()');
|
||||
my $name = $self->{connect}->{PREFIX} . $table_name;
|
||||
|
||||
# Create either an empty schema or use an old one.
|
||||
$self->debug("Creating new GT::SQL::Table object '$table_name' to be used in Creator.") if $self->{_debug} and $self->{_debug} > 2;
|
||||
my $table = GT::SQL::Table->new(
|
||||
name => $table_name,
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => 'GT::SQL::Creator'
|
||||
);
|
||||
|
||||
# Return a creator object.
|
||||
require GT::SQL::Creator;
|
||||
$self->debug("CREATING GT::SQL::Creator OBJECT") if $self->{_debug} and $self->{_debug} > 2;
|
||||
return GT::SQL::Creator->new(
|
||||
table => $table,
|
||||
debug => $self->{_debug},
|
||||
connect => $self->{connect}
|
||||
);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a driver object, and connects.
|
||||
#
|
||||
my $self = shift;
|
||||
return 1 if $self->{driver};
|
||||
$self->{connect} or return $self->fatal('NOCONNECT');
|
||||
|
||||
my $driver = uc $self->{connect}->{driver} || 'MYSQL';
|
||||
$self->{driver} = GT::SQL::Driver->load_driver(
|
||||
$driver,
|
||||
schema => $self->{tables} || $self->{schema},
|
||||
name => scalar $self->name,
|
||||
connect => $self->{connect},
|
||||
debug => $self->{_debug},
|
||||
_err_pkg => $self->{_err_pkg}
|
||||
) or return $self->fatal(CANTLOAD => $driver, $GT::SQL::error);
|
||||
|
||||
unless ($self->{driver}->connect) {
|
||||
delete $self->{driver};
|
||||
return;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub count {
|
||||
# -------------------------------------------------------------------
|
||||
# $obj->count;
|
||||
# ------------
|
||||
# Returns the number of tuples handled
|
||||
# by this relation.
|
||||
#
|
||||
# $obj->count($condition);
|
||||
# -------------------------
|
||||
# Returns the number of tuples that matches
|
||||
# that $condition.
|
||||
#
|
||||
my $self = shift;
|
||||
my @cond;
|
||||
if (!ref $_[0] and @_ % 2 == 0 and defined $_[0]) {
|
||||
push @cond, {@_};
|
||||
}
|
||||
else {
|
||||
for (@_) {
|
||||
return $self->fatal(BADARGS => 'Arguments to count() must either be a hash, or one or more hash refs and/or GT::SQL::Condition objects')
|
||||
unless ref eq 'GT::SQL::Condition' or ref eq 'HASH';
|
||||
push @cond, $_;
|
||||
}
|
||||
}
|
||||
my $sel_opts = $self->{sel_opts};
|
||||
$self->{sel_opts} = [];
|
||||
my $sth = $self->select('COUNT(*)' => @cond ? GT::SQL::Condition->new(@cond) : ()) or return;
|
||||
$self->{sel_opts} = $sel_opts;
|
||||
return int $sth->fetchrow;
|
||||
}
|
||||
|
||||
$COMPILE{total} = __LINE__ . <<'END_OF_SUB';
|
||||
sub total {
|
||||
# -------------------------------------------------------------------
|
||||
# total()
|
||||
# IN : none
|
||||
# OUT: total number of records in table
|
||||
#
|
||||
shift->count
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{quote} = __LINE__ . <<'END_OF_SUB';
|
||||
sub quote {
|
||||
# -------------------------------------------------------------------
|
||||
# $obj->quote($value);
|
||||
# ---------------------
|
||||
# Returns the quoted representation of $value.
|
||||
#
|
||||
return GT::SQL::Driver::quote(pop)
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{hits} = __LINE__ . <<'END_OF_SUB';
|
||||
sub hits {
|
||||
# -----------------------------------------------------------
|
||||
# hits()
|
||||
# IN : none
|
||||
# OUT: number of results in last search. (calls count(*) on
|
||||
# demand from hits() or toolbar())
|
||||
#
|
||||
my $self = shift;
|
||||
if (! defined $self->{last_hits}) {
|
||||
$self->{last_hits} = (defined $self->{last_where} ? $self->count($self->{last_where}) : $self->count) || 0;
|
||||
}
|
||||
return $self->{last_hits};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_cgi_to_hash} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _cgi_to_hash {
|
||||
# -------------------------------------------------------------------
|
||||
# Internal Use
|
||||
# $self->_cgi_to_hash($in);
|
||||
# --------------------------
|
||||
# Creates a hash ref from a cgi object.
|
||||
#
|
||||
my ($self, $cgi) = @_;
|
||||
defined $cgi and ref $cgi =~ /CGI/ or return $self->fatal(BADARGS => "'$cgi' is not a CGI object");
|
||||
|
||||
my @keys = $cgi->param;
|
||||
my $result = {};
|
||||
for my $key (@keys) {
|
||||
my @values = $cgi->param($key);
|
||||
$result->{$key} = @values == 1 ? $values[0] : \@values;
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_get_search_opts} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _get_search_opts {
|
||||
# -------------------------------------------------------------------
|
||||
# Internal Use
|
||||
# _get_search_opts($hash_ref);
|
||||
# ----------------------------
|
||||
# Gets the search options based on the hash ref
|
||||
# passed in.
|
||||
#
|
||||
# sb => field_list # Return results sorted by field list.
|
||||
# so => [ASC|DESC] # Sort order of results.
|
||||
# mh => n # Return n results maximum, default to 25.
|
||||
# nh => n # Return the n'th set of results, default to 1.
|
||||
# rs => [col, col2] # A list of columns you want returned
|
||||
#
|
||||
my $self = shift;
|
||||
my $opt_r = shift;
|
||||
my $ret = {};
|
||||
$ret->{nh} = (defined $opt_r->{nh} and $opt_r->{nh} =~ /^(\d+)$/) ? $1 : 1;
|
||||
$ret->{mh} = (defined $opt_r->{mh} and $opt_r->{mh} =~ /^(-?\d+)$/) ? $1 : 25;
|
||||
$ret->{so} = (defined $opt_r->{so} and $opt_r->{so} =~ /^(ASC|DESC)$/i) ? $1 : '';
|
||||
$ret->{sb} = (defined $opt_r->{sb} and $opt_r->{sb} =~ /^([\w\s,.]+)$/) ? $1 : '';
|
||||
|
||||
# You can pass in 'Col ASC, Col2 DESC' in {sb} so we need to remove sort order then.
|
||||
if ((lc $ret->{sb}) =~ /\s(?:asc|desc)/) {
|
||||
$ret->{so} = '';
|
||||
}
|
||||
if (defined $ret->{rs} and ref $ret->{rs} eq 'ARRAY') {
|
||||
my @valid;
|
||||
foreach my $col (@{$ret->{rs}}) {
|
||||
$col =~ /^([\w\s,]+)$/ and push @valid, $1;
|
||||
}
|
||||
$ret->{rs} = \@valid;
|
||||
}
|
||||
else {
|
||||
$ret->{rs} = (defined $opt_r->{rs} and $opt_r->{rs} =~ /^([\w\s,]+)$/) ? $1 : '';
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Transitional support. build_query_cond _was_ a private method
|
||||
$COMPILE{_build_query_cond} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _build_query_cond {
|
||||
my $self = shift;
|
||||
warn "obj->_build_query_cond() is deprecated; use obj->build_query_cond()" if $self->{_debug};
|
||||
$self->build_query_cond(@_)
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{build_query_cond} = __LINE__ . <<'END_OF_SUB';
|
||||
sub build_query_cond {
|
||||
# -------------------------------------------------------------------
|
||||
# Builds a condition object based on form input.
|
||||
# field_name => value # Find all rows with field_name = value
|
||||
# field_name => ">=?value" # Find all rows with field_name > or >= value.
|
||||
# field_name => "<=?value" # Find all rows with field_name < or <= value.
|
||||
# field_name => "!value" # Find all rows with field_name != value.
|
||||
# field_name-opt => >=?|<=?|=|<>|LIKE|STARTS|ENDS
|
||||
# # Find all rows with field_name (whichever) value.
|
||||
# field_name-gt => value # Find all rows with field_name > value.
|
||||
# field_name-lt => value # Find all rows with field_name < value.
|
||||
# field_name-ge => value # Find all rows with field_name >= value.
|
||||
# field_name-le => value # Find all rows with field_name <= value.
|
||||
# field_name-ne => value # Find all rows with field_name != value.
|
||||
# keyword => value # Find all rows where any field_name = value
|
||||
# query => value # Find all rows using GT::SQL::Search module
|
||||
# ww => 1 # 1 => use = comparision, 0/unspecified => use LIKE '%value%' comparision
|
||||
# ma => 1 # 1 => OR match 0/unspecified => AND match
|
||||
#
|
||||
my ($self, $opts, $c) = @_;
|
||||
|
||||
my $cond = new GT::SQL::Condition;
|
||||
my ($cmp, $l);
|
||||
($cmp, $l) = $opts->{ww} ? ('=', '') : ('LIKE', '%');
|
||||
$cond->boolean($opts->{ma} ? 'OR' : 'AND');
|
||||
my $ins = 0;
|
||||
|
||||
# First find the fields and find what we
|
||||
# want to do with them.
|
||||
if (defined $opts->{query} and $opts->{query} =~ /\S/) {
|
||||
require GT::SQL::Search;
|
||||
my $search = GT::SQL::Search->load_search({
|
||||
%{$opts},
|
||||
db => $self->{driver},
|
||||
table => $self,
|
||||
debug => $self->{debug},
|
||||
_debug => $self->{_debug}
|
||||
});
|
||||
my $sth = $search->query();
|
||||
$self->{last_hits} = $search->rows();
|
||||
$self->{rejected_keywords} = $search->{rejected_keywords};
|
||||
return $sth;
|
||||
}
|
||||
elsif (defined $opts->{keyword} and ($opts->{keyword} ne "") and ($opts->{keyword} ne '*')) {
|
||||
my $val = $opts->{keyword};
|
||||
my $is_dig = $val =~ /^[+-]*\d+\.?\d*$/;
|
||||
|
||||
foreach my $field (keys %$c) {
|
||||
next unless (index($c->{$field}->{type}, 'DATE') == -1); # No DATE fields.
|
||||
next unless (index($c->{$field}->{type}, 'TIME') == -1); # No TIME fields.
|
||||
next unless (index($c->{$field}->{type}, 'ENUM') == -1); # No ENUM fields.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'INT') != -1)); # No ints if not an int.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'DECIMAL') != -1)); # No ints if not an int.
|
||||
next if (!$is_dig and (index($c->{$field}->{type}, 'FLOAT') != -1)); # No ints if not an int.
|
||||
|
||||
$cond->add($field, $cmp, "$l$opts->{keyword}$l");
|
||||
$ins = 1;
|
||||
}
|
||||
$cond->bool('OR');
|
||||
}
|
||||
else {
|
||||
|
||||
# Go through each column and build condition.
|
||||
foreach my $field (keys %$c) {
|
||||
my $comp = $cmp;
|
||||
my $s = $l;
|
||||
my $e = $l;
|
||||
my @ins;
|
||||
|
||||
if ($opts->{"$field-opt"}) {
|
||||
$comp = uc $opts->{"$field-opt"};
|
||||
|
||||
$s = $e = '';
|
||||
if ( $comp eq 'LIKE' ) {
|
||||
$e = $s = '%';
|
||||
}
|
||||
elsif ( $comp eq 'STARTS' ) {
|
||||
$comp = 'LIKE';
|
||||
$e = '%';
|
||||
}
|
||||
elsif ( $comp eq 'ENDS' ) {
|
||||
$comp = 'LIKE';
|
||||
$s = '%';
|
||||
}
|
||||
|
||||
}
|
||||
else {
|
||||
if ($c->{$field}->{type} =~ /ENUM/i) {
|
||||
$comp = '=';
|
||||
$e = $s = '';
|
||||
}
|
||||
}
|
||||
|
||||
# Comp can only be: =, <, >, <=, >=, <>, LIKE, STARTS, ENDS
|
||||
$comp = '=' unless $comp =~ /^(=|<=?|>=?|<>|LIKE)$/i;
|
||||
|
||||
if (exists $opts->{"$field-gt"} and ($opts->{"$field-gt"} ne "")) {
|
||||
push @ins, [$field, '>', $opts->{$field . "-gt"}];
|
||||
}
|
||||
if (exists $opts->{"$field-lt"} and ($opts->{"$field-lt"} ne "")) {
|
||||
push @ins, [$field, '<', $opts->{$field . "-lt"}];
|
||||
}
|
||||
if (exists $opts->{"$field-ge"} and ($opts->{"$field-ge"} ne "")) {
|
||||
push @ins, [$field, '>=', $opts->{$field . "-ge"}];
|
||||
}
|
||||
if (exists $opts->{"$field-le"} and ($opts->{"$field-le"} ne "")) {
|
||||
push @ins, [$field, '<=', $opts->{$field . "-le"}];
|
||||
}
|
||||
if (exists $opts->{"$field-ne"} and ($opts->{"$field-ne"} ne "")) {
|
||||
push @ins, [$field, '!=', $opts->{$field . "-ne"}];
|
||||
}
|
||||
|
||||
if (exists $opts->{$field} and ($opts->{$field} ne "")) {
|
||||
if (ref($opts->{$field}) eq 'ARRAY' ) {
|
||||
my $add = [];
|
||||
for ( @{$opts->{$field}} ) {
|
||||
next if !defined( $_ ) or !length( $_ ) or !/\S/;
|
||||
push @$add, $_;
|
||||
}
|
||||
if ( @$add ) {
|
||||
push @ins, [$field, 'IN', $add];
|
||||
}
|
||||
}
|
||||
elsif ($opts->{$field} =~ /^(>=?|<=?|!)(.*)/) {
|
||||
push @ins, [$field, ($1 eq '!') ? '<>' : $1, $2];
|
||||
}
|
||||
elsif ($opts->{$field} eq '+') {
|
||||
push @ins, [$field, "<>", ''];
|
||||
}
|
||||
elsif ($opts->{$field} eq '-') {
|
||||
push @ins, [$field, "=", ''];
|
||||
}
|
||||
elsif ($opts->{$field} eq '*') {
|
||||
if ($opts->{"$field-opt"} and ($opts->{"$field-opt"} eq '<>')) {
|
||||
push @ins, [$field, '=', ''];
|
||||
}
|
||||
else {
|
||||
next;
|
||||
}
|
||||
}
|
||||
else {
|
||||
substr($opts->{$field}, 0, 1) = "" if substr($opts->{$field}, 0, 1) eq '\\';
|
||||
push @ins, [$field, $comp, "$s$opts->{$field}$e"];
|
||||
}
|
||||
}
|
||||
|
||||
if (@ins) {
|
||||
for (@ins) {
|
||||
$cond->add($_);
|
||||
}
|
||||
$ins = 1;
|
||||
}
|
||||
|
||||
}
|
||||
}
|
||||
|
||||
return $ins ? $cond : '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _load_module {
|
||||
# -------------------------------------------------------------------
|
||||
# Loads a subclassed module.
|
||||
#
|
||||
my ($self, $class) = @_;
|
||||
|
||||
no strict 'refs';
|
||||
return 1 if (UNIVERSAL::can($class, 'new'));
|
||||
|
||||
(my $pkg = $class) =~ s,::,/,g;
|
||||
my $ok = 0;
|
||||
my @err = ();
|
||||
until ($ok) {
|
||||
local ($@, $SIG{__DIE__});
|
||||
eval { require "$pkg.pm" };
|
||||
if ($@) {
|
||||
push @err, $@;
|
||||
# In case the module had compile errors, %class:: will be defined, but not complete.
|
||||
undef %{$class . '::'} if %{$class . '::'};
|
||||
}
|
||||
else {
|
||||
$ok = 1;
|
||||
last;
|
||||
}
|
||||
my $pos = rindex($pkg, '/');
|
||||
last if $pos == -1;
|
||||
substr($pkg, $pos) = "";
|
||||
}
|
||||
unless ($ok and UNIVERSAL::can($class, 'new')) {
|
||||
return $self->fatal(BADSUBCLASS => $class, join ", ", @err);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
404
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Condition.pm
Normal file
404
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Condition.pm
Normal file
@ -0,0 +1,404 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Base
|
||||
# Author: Scott Beck
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Condition.pm,v 1.45 2006/02/16 20:26:14 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements an SQL condition.
|
||||
#
|
||||
|
||||
package GT::SQL::Condition;
|
||||
# ===============================================================
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $VERSION/;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.45 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# CLASS->new;
|
||||
# $obj->new;
|
||||
# ----------
|
||||
# This class method is the base constructor for the GT::SQL::Condition
|
||||
# object. It can be passed the boolean operator that has to be used for that
|
||||
# object ("AND" is the default), the conditions for this object.
|
||||
#
|
||||
my $class = shift;
|
||||
$class = ref $class || $class;
|
||||
my $self = {
|
||||
cond => [],
|
||||
not => 0,
|
||||
bool => 'AND'
|
||||
};
|
||||
bless $self, $class;
|
||||
|
||||
if (@_ and defined $_[-1] and (uc $_[-1] eq 'AND' or uc $_[-1] eq 'OR' or $_[-1] eq ',') ) {
|
||||
$self->boolean(uc pop);
|
||||
}
|
||||
$self->add(@_) if @_;
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{clone} = __LINE__ . <<'END_OF_SUB';
|
||||
sub clone {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Clones the current object - that is, gives you an identical object that
|
||||
# doesn't reference the original at all.
|
||||
#
|
||||
my $self = shift;
|
||||
my $newself = { not => $self->{not}, bool => $self->{bool} };
|
||||
bless $newself, ref $self;
|
||||
my @cond;
|
||||
|
||||
for (@{$self->{cond}}) {
|
||||
# {cond} can contain two things - three-value array references
|
||||
# ('COL', '=', 'VAL'), or full-fledged condition objects.
|
||||
if (ref eq 'ARRAY') {
|
||||
push @cond, [@$_];
|
||||
}
|
||||
elsif (UNIVERSAL::isa($_, __PACKAGE__)) {
|
||||
push @cond, $_->clone;
|
||||
}
|
||||
}
|
||||
$newself->{cond} = \@cond;
|
||||
$newself;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{not} = __LINE__ . <<'END_OF_SUB';
|
||||
sub not {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->not;
|
||||
# ----------------
|
||||
# Negates the current condition.
|
||||
#
|
||||
$_[0]->{not} = 1;
|
||||
return $_[0];
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
|
||||
$COMPILE{new_clean} = __LINE__ . <<'END_OF_SUB';
|
||||
sub new_clean {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->new_clean;
|
||||
# ----------------
|
||||
# Returns the same condition object, but ready to be prepared again.
|
||||
#
|
||||
my $self = shift;
|
||||
my $class = ref $self;
|
||||
my $res = $class->new;
|
||||
$res->boolean($self->boolean);
|
||||
for my $cond (@{$self->{cond}}) {
|
||||
$res->add($cond);
|
||||
}
|
||||
return $res;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub boolean {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->boolean;
|
||||
# --------------
|
||||
# Returns the boolean operator which is being used for the current object.
|
||||
#
|
||||
# $obj->boolean($string);
|
||||
# ------------------------
|
||||
# Sets $string as the boolean operator for this condition object. Typically
|
||||
# this should be nothing else than "AND" or "OR", but no checks are
|
||||
# performed, so watch out for typos!
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{bool} = shift || return $self->{bool};
|
||||
}
|
||||
|
||||
sub add {
|
||||
# -----------------------------------------------------------------------------
|
||||
# $obj->add($col => $op => $val [, $col2 => $op2 => $val2, ...]);
|
||||
# ----------------------------
|
||||
# Adds a one or more COL OP VAL clauses to the current condition.
|
||||
#
|
||||
# $obj->add($condition [, $cond2, ...]);
|
||||
# -----------------------
|
||||
# Adds one or more condition clauses to the current condition.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
while (@_) {
|
||||
my $var = shift;
|
||||
if (ref $var eq 'ARRAY' or UNIVERSAL::isa($var, __PACKAGE__)) {
|
||||
push @{$self->{cond}}, $var;
|
||||
}
|
||||
elsif (ref $var eq 'HASH') {
|
||||
for (keys %$var) {
|
||||
push @{$self->{cond}}, [$_ => '=' => $var->{$_}];
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $op = @_ >= 2 ? shift || '=' : '='; # To support $cond->add(foo => $bar);
|
||||
my $val = shift;
|
||||
if (not defined $val) {
|
||||
if ($op eq '=' and $self->{bool} ne ',') {
|
||||
$op = 'IS';
|
||||
}
|
||||
elsif ($op eq '!=' or $op eq '<>') {
|
||||
$op = 'IS NOT';
|
||||
}
|
||||
}
|
||||
push @{$self->{cond}}, [$var => $op => $val];
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub sql {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a string for the current SQL object which is the SQL representation
|
||||
# of that condition. The string can then be inserted after a SQL WHERE clause.
|
||||
# Optionally takes an option which, if true, uses placeholders and returns
|
||||
# ($sql, \@values, \@columns) instead of just $sql.
|
||||
#
|
||||
my ($self, $ph) = @_;
|
||||
my $bool = $self->{bool};
|
||||
my (@vals, @cols, @output);
|
||||
|
||||
foreach my $cond (@{$self->{cond}}) {
|
||||
if (ref $cond eq 'ARRAY') {
|
||||
my ($col, $op, $val) = @$cond;
|
||||
# Perl: column => '=' => [1,2,3]
|
||||
# SQL: column IN (1,2,3)
|
||||
if (uc $op eq 'IN' || $op eq '=' and ref $val eq 'ARRAY') {
|
||||
if (@$val > 1) {
|
||||
$op = 'IN';
|
||||
$val = '('
|
||||
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
|
||||
. ')';
|
||||
}
|
||||
elsif (@$val == 0) {
|
||||
($col, $op, $val) = (qw(1 = 0));
|
||||
}
|
||||
else {
|
||||
$op = '=';
|
||||
$val = quote($val->[0]);
|
||||
}
|
||||
push @output, "$col $op $val";
|
||||
}
|
||||
# Perl: column => '!=' => [1,2,3]
|
||||
# SQL: NOT(column IN (1,2,3))
|
||||
elsif ($op eq '!=' || $op eq '<>' and ref $val eq 'ARRAY') {
|
||||
my $output;
|
||||
if (@$val > 1) {
|
||||
$output = "NOT ($col IN ";
|
||||
$output .= '('
|
||||
. join(',' => map !length || /\D/ ? quote($_) : $_, @$val)
|
||||
. ')';
|
||||
$output .= ')';
|
||||
}
|
||||
elsif (@$val == 0) {
|
||||
$output = '1 = 1';
|
||||
}
|
||||
else {
|
||||
$output = "$col $op " . quote($val->[0]);
|
||||
}
|
||||
push @output, $output;
|
||||
}
|
||||
elsif ($ph and defined $val and not ref $val) {
|
||||
push @output, "$col $op ?";
|
||||
push @cols, $col;
|
||||
push @vals, $val;
|
||||
}
|
||||
else {
|
||||
push @output, "$col $op " . quote($val);
|
||||
}
|
||||
}
|
||||
elsif (UNIVERSAL::isa($cond, __PACKAGE__)) {
|
||||
my @sql = $cond->sql($ph);
|
||||
if ($sql[0]) {
|
||||
push @output, "($sql[0])";
|
||||
if ($ph) {
|
||||
push @vals, @{$sql[1]};
|
||||
push @cols, @{$sql[2]};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
my $final = join " $bool ", @output;
|
||||
$final &&= "NOT ($final)" if $self->{not};
|
||||
|
||||
return wantarray ? ($final, $ph ? (\@vals, \@cols) : ()) : $final;
|
||||
}
|
||||
|
||||
$COMPILE{sql_ph} = __LINE__ . <<'END_OF_SUB';
|
||||
sub sql_ph {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Depreciated form of ->sql(1);
|
||||
shift->sql(1);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub quote {
|
||||
# -----------------------------------------------------------------------------
|
||||
# this subroutines quotes (or not) a value given its column.
|
||||
#
|
||||
defined(my $val = pop) or return 'NULL';
|
||||
return ref $val eq 'SCALAR' ? $$val : GT::SQL::Driver->quote($val);
|
||||
}
|
||||
|
||||
sub as_hash {
|
||||
# -----------------------------------------------------------------------------
|
||||
# returns the condition object as a flattened hash.
|
||||
#
|
||||
my $cond = shift;
|
||||
ref $cond eq 'HASH' and return $cond;
|
||||
my %ret;
|
||||
for my $arr (@{$cond->{cond}}) {
|
||||
if (ref $arr eq 'ARRAY') {
|
||||
$ret{$arr->[0]} = $arr->[2];
|
||||
}
|
||||
else {
|
||||
my $h = as_hash($arr);
|
||||
for my $k (keys %$h) {
|
||||
$ret{$k} = $h->{$k};
|
||||
}
|
||||
}
|
||||
}
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL::Condition - Creates complex where clauses
|
||||
|
||||
=head1 SYNOPSYS
|
||||
|
||||
my $cond = GT::SQL::Condition->new(Column => LIKE => 'foo%');
|
||||
print $cond->sql;
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
Column => LIKE => 'foo%',
|
||||
Column2 => '<' => 'abc'
|
||||
);
|
||||
$cond->bool('OR');
|
||||
print $cond->sql;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The condition module is useful for generating complex SQL WHERE clauses. At
|
||||
it's simplest, a condition is composed of three parts: column, condition and
|
||||
value.
|
||||
|
||||
Here are some examples.
|
||||
|
||||
To find all users with a first name that starts with Alex use:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(FirstName => LIKE => 'Alex%');
|
||||
|
||||
To find users with first name like alex, B<and> last name like krohn use:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
FirstName => LIKE => 'Alex%',
|
||||
LastName => LIKE => 'Krohn%'
|
||||
);
|
||||
|
||||
To find users with first name like alex B<or> last name like krohn use:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
FirstName => LIKE => 'Alex%',
|
||||
LastName => LIKE => 'Krohn%'
|
||||
);
|
||||
$cond->bool('OR');
|
||||
|
||||
You may also specify this as:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
FirstName => LIKE => 'Alex%',
|
||||
LastName => LIKE => 'Krohn%',
|
||||
'OR'
|
||||
);
|
||||
|
||||
Now say we wanted something a bit more complex that would normally involve
|
||||
setting parentheses. We want to find users who have either first name like alex
|
||||
or last name like krohn, and whose employer is Gossamer Threads. We could use:
|
||||
|
||||
my $cond1 = GT::SQL::Condition->new(
|
||||
'FirstName', 'LIKE', 'Alex%',
|
||||
'LastName', 'LIKE', 'Krohn%'
|
||||
);
|
||||
$cond1->bool('or');
|
||||
my $cond2 = GT::SQL::Condition->new(
|
||||
$cond1,
|
||||
Employer => '=' => 'Gossamer Threads'
|
||||
);
|
||||
|
||||
By default, all values are quoted, so you don't need to bother using any quote
|
||||
function. If you don't want something quoted (say you want to use a function
|
||||
for example), then you pass in a reference.
|
||||
|
||||
For example, to find users who have a last name that sounds like 'krohn', you
|
||||
could use your SQL engines SOUNDEX function:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(LastName => '=' => \"SOUNDEX('krohn')");
|
||||
|
||||
and the right side wouldn't be quoted.
|
||||
|
||||
You can also use a condition object to specify a list of multiple values, which
|
||||
will become the SQL 'IN' operator. For example, to match anyone with a first
|
||||
name of Alex, Scott or Jason, you can do:
|
||||
|
||||
my $cond = GT::SQL::Condition->new(FirstName => IN => ['Alex', 'Scott', 'Jason']);
|
||||
|
||||
which will turn into:
|
||||
|
||||
FirstName IN ('Alex', 'Scott', 'Jason')
|
||||
|
||||
Note that when using multiple values, you can use '=' instead of 'IN'. Empty
|
||||
lists will be treated as an impossible condition (1 = 0). This is primarily
|
||||
useful for list handling list of id numbers.
|
||||
|
||||
To match NULL values, you can use C<undef> for the value passed to the add()
|
||||
method. If specifying '=' as the operator, it will automatically be changed to
|
||||
'IS':
|
||||
|
||||
$cond->add(MiddleName => '=' => undef);
|
||||
|
||||
becomes:
|
||||
|
||||
MiddleName IS NULL
|
||||
|
||||
|
||||
To negate your queries you can use the C<not> function.
|
||||
|
||||
my $cond = GT::SQL::Condition->new(a => '=' => 5);
|
||||
$cond->not;
|
||||
|
||||
would translate into NOT (a = '5'). You can also do this all on one line like:
|
||||
|
||||
print GT::SQL::Condition->new(a => '=' => '5')->not->sql;
|
||||
|
||||
This returns the sql right away.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Condition.pm,v 1.45 2006/02/16 20:26:14 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1216
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Creator.pm
Normal file
1216
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Creator.pm
Normal file
File diff suppressed because it is too large
Load Diff
893
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML.pm
Normal file
893
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Display/HTML.pm
Normal file
@ -0,0 +1,893 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: HTML.pm,v 1.98 2009/03/23 22:55:53 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS $INPUT_SEPARATOR/;
|
||||
use GT::Base;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size="2"';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.98 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$INPUT_SEPARATOR = "\n";
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
mode => '',
|
||||
code => {},
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
hide_download => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border="0" width="500"',
|
||||
tr => '',
|
||||
td => 'valign="top" align="left"',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
url => $ENV{REQUEST_URI},
|
||||
};
|
||||
|
||||
sub init {
|
||||
# ---------------------------------------------------------------
|
||||
# new() comes from GT::Base.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Set any passed in options.
|
||||
$self->set (@_);
|
||||
|
||||
# Try to set the URL
|
||||
$self->{url} or eval { require GT::CGI; $self->{url} = GT::CGI->url(); };
|
||||
$self->{url} ||= '';
|
||||
|
||||
# Make sure we have a database object.
|
||||
# exists ($self->{db}) and (ref $self->{db}) or return $self->error ("BADARGS", "FATAL", "You must pass in a GT::SQL::Table object");
|
||||
|
||||
my $input = ref $self->{input};
|
||||
if ($input and ($input eq 'GT::CGI')) {
|
||||
$self->{input} = $self->{input}->get_hash;
|
||||
}
|
||||
elsif ($input and ($input eq 'CGI')) {
|
||||
my $h = {};
|
||||
foreach my $key ($self->{input}->param) {
|
||||
$h->{$key} = $self->{input}->param($key);
|
||||
}
|
||||
$self->{input} = $h;
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub reset_opts {
|
||||
# ---------------------------------------------------------------
|
||||
# Resets the display options.
|
||||
#
|
||||
my $self = shift;
|
||||
while (my ($k, $v) = each %$ATTRIBS) {
|
||||
next if $k eq 'db';
|
||||
next if $k eq 'disp_form';
|
||||
next if $k eq 'disp_html';
|
||||
next if $k eq 'input';
|
||||
if (! ref $v) {
|
||||
$self->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$self->{$k} = {};
|
||||
foreach my $k1 (keys %{$ATTRIBS->{$k}}) { $self->{$k}->{$k1} = $ATTRIBS->{$k}->{$k1}; }
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$self->{$k} = [];
|
||||
foreach my $v1 (@{$ATTRIBS->{$k}}) { push @{$self->{$k}}, $v1; }
|
||||
}
|
||||
else { $self->{$k} = $v; }
|
||||
}
|
||||
}
|
||||
|
||||
sub form {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as an html form.
|
||||
#
|
||||
my $self = shift;
|
||||
$_[0]->{disp_form} = 1;
|
||||
$_[0]->{disp_html} = 0;
|
||||
return $self->_display (@_);
|
||||
}
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->error ("NEEDSUBCLASS", "FATAL")
|
||||
}
|
||||
|
||||
sub _get_defaults {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns default values for fields. Bases it on what's passed in,
|
||||
# cgi input, def file defaults, otherwise blank.
|
||||
#
|
||||
my $self = shift;
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $c = $self->{cols} || $self->{db}->cols;
|
||||
my $values = {};
|
||||
foreach my $col (@cols) {
|
||||
my $value = '';
|
||||
if (exists $self->{values}->{$col}) { $value = $self->{values}->{$col} }
|
||||
elsif (exists $self->{input}->{$col}) { $value = $self->{input}->{$col} }
|
||||
elsif ($self->{defaults} and exists $c->{$col}->{default}) {
|
||||
if ($c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
($c->{$col}->{default} =~ /0000/)
|
||||
? ($value = $self->_get_time($c->{$col}))
|
||||
: ($value = $c->{$col}->{default});
|
||||
}
|
||||
else {
|
||||
$value = $c->{$col}->{default};
|
||||
}
|
||||
}
|
||||
elsif ($self->{defaults} and $c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
$value = $self->_get_time($c->{$col});
|
||||
}
|
||||
if ($c->{$col}->{form_type} and uc $c->{$col}->{form_type} eq 'FILE' ) {
|
||||
for (qw/_filename _del/) {
|
||||
$values->{$col.$_} = $self->{values}->{$col.$_} if exists $self->{values}->{$col.$_};
|
||||
}
|
||||
}
|
||||
$values->{$col} = $value;
|
||||
}
|
||||
return $values;
|
||||
}
|
||||
|
||||
sub _skip {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $col) = @_;
|
||||
|
||||
# Skip timestamps, any fields requested to be skipped or any hidden fields (hidden forms appended at bottom).
|
||||
return 1 if ($self->{hide_timestamp} and $self->{cols}->{$col}->{time_check});
|
||||
return 1 if ($self->{skip} and (grep /^$col$/, @{$self->{skip}}));
|
||||
return 1 if ($self->{hide} and (grep /^$col$/, @{$self->{hide}}));
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub _get_form_display {
|
||||
my ($self, $col) = @_;
|
||||
|
||||
if (
|
||||
($self->{view_key} and
|
||||
exists $self->{cols}->{$col}->{time_check} and
|
||||
$self->{cols}->{$col}->{time_check})
|
||||
||
|
||||
($self->{view} and (grep /^$col$/, @{$self->{view}}))
|
||||
)
|
||||
{
|
||||
return 'hidden_text';
|
||||
}
|
||||
|
||||
my $form_type = lc $self->{cols}->{$col}->{form_type} or return 'default';
|
||||
|
||||
if ( $form_type eq 'password' and index( $self->{mode}, 'search_form' ) + 1 ) {
|
||||
return 'default'
|
||||
}
|
||||
|
||||
elsif ( $form_type and $self->can( $form_type ) ) {
|
||||
return $form_type;
|
||||
}
|
||||
|
||||
return 'default';
|
||||
}
|
||||
|
||||
sub _get_html_display {
|
||||
my $self = shift;
|
||||
my $col = shift;
|
||||
return 'display_text';
|
||||
}
|
||||
|
||||
# Form types
|
||||
sub default {
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_char_form");
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_char_form");
|
||||
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
||||
my $size = exists $opts->{form_size} ? $opts->{form_size} : (exists $def->{form_size} ? ($def->{form_size} || 30) : 30);
|
||||
my $max = exists $opts->{size} ? $opts->{def}->{size} : (exists $def->{size} ? $def->{size} : 255);
|
||||
|
||||
defined ($val) or $val = '';
|
||||
_escape(\$val);
|
||||
return qq~<input type="text" name="$name" value="$val" maxlength="$max" size="$size" />~;
|
||||
}
|
||||
|
||||
sub date {
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{form_size} ||= 20;
|
||||
return $self->text ($opts);
|
||||
}
|
||||
|
||||
sub multiple { shift->select (@_) }
|
||||
|
||||
sub select {
|
||||
# ---------------------------------------------------------------
|
||||
# Make a select list. Valid options are:
|
||||
# name => FORM_NAME
|
||||
# values => { form_value => displayed_value }
|
||||
# value => selected_value
|
||||
# or
|
||||
# value => [selected_value1, selected_value2]
|
||||
# multiple => n - adds MULTIPLE SIZE=n to select list
|
||||
# sort => coderef called to sort the list or array ref specifying the order in
|
||||
# which the fields should be display. A code ref, when called, will be
|
||||
# passed the following arguments: ($value{$a}, $value{$b}, $a, $b)
|
||||
# blank => 1 or 0. If true, a blank first option will be printed, if false
|
||||
# the blank first element will not be printed. Defaults to true.
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS1", "FATAL", "No form name passed to select");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Get the default value to display if nothing is selected.
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
else { $def = '' }
|
||||
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my ($sort_f, $sort_o);
|
||||
if (ref $opts->{sort} eq 'CODE') {
|
||||
$sort_f = $opts->{sort};
|
||||
}
|
||||
elsif (ref $opts->{sort} eq 'ARRAY') {
|
||||
$sort_o = $opts->{sort};
|
||||
}
|
||||
# sort_order => [...] has been replaced with sort => [...] and so it
|
||||
# is NOT mentioned in the subroutine comments.
|
||||
elsif (ref $opts->{sort_order} eq 'ARRAY') {
|
||||
$sort_o = $opts->{sort_order};
|
||||
}
|
||||
my $blank = exists $opts->{blank} ? $opts->{blank} : 1;
|
||||
|
||||
# Multiple was passed in
|
||||
my $mult;
|
||||
my $clean_name = $name;
|
||||
if ($name =~ /^\d\-(.+)$/) {
|
||||
$clean_name = $1;
|
||||
}
|
||||
if (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_type} and $self->{cols}->{$clean_name}->{form_type} eq 'MULTIPLE') {
|
||||
$mult = qq! multiple="multiple" size="$self->{cols}->{$clean_name}->{form_size}"!;
|
||||
}
|
||||
elsif (exists $opts->{multiple} and $opts->{multiple} > 1) {
|
||||
$mult = qq! multiple="multiple" size="$opts->{multiple}"!;
|
||||
}
|
||||
elsif (exists $self->{cols}->{$clean_name} and $self->{cols}->{$clean_name}->{form_size}) {
|
||||
$mult = qq! size="$self->{cols}->{$clean_name}->{form_size}"!;
|
||||
}
|
||||
else {
|
||||
$mult = '';
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
my $out = qq~<select$mult name="$name"$class>~;
|
||||
$blank and ($out .= qq~<option value="">---</option>~);
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->($hash{$a}, $hash{$b}, $a, $b) } keys %hash }
|
||||
else { @keys = @$names; }
|
||||
|
||||
if (! ref $def) {
|
||||
$def = { map { ($_ => 1) } split (/\Q$INPUT_SEPARATOR\E%?/o, $def) };
|
||||
}
|
||||
else { # Array ref
|
||||
$def = { map { ($_ => 1) } @$def };
|
||||
}
|
||||
for my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
$out .= qq~<option value="$key"~;
|
||||
$out .= ' selected="selected"' if $def->{$key};
|
||||
$out .= ">$val</option>";
|
||||
}
|
||||
$out .= "</select>\n";
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub radio {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a radio series.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No name for field passed to radio");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Make sure we have something.
|
||||
if (! @{$names} or ! @{$values}) {
|
||||
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
||||
}
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
||||
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
||||
my $out;
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o; }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash; }
|
||||
else { @keys = keys %hash; }
|
||||
|
||||
(ref $def eq 'ARRAY') or ($def = [$def]);
|
||||
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
KEY: foreach my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
VAL: foreach my $sel (@$def) {
|
||||
($key eq $sel) and ($out .= qq~$val<input type="radio" value="$key"$class name="$name" checked="checked" /> ~) and next KEY;
|
||||
}
|
||||
$out .= qq~$val<input name="$name" type="radio" value="$key"$class /> ~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub checkbox {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a checkbox set.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my ($names, $values) = $self->_get_multi ($opts);
|
||||
|
||||
# Make sure we have something.
|
||||
if (! @{$names} or ! @{$values}) {
|
||||
return $self->error ("BADARGS", "FATAL", "No value hash passed to checkbox");
|
||||
}
|
||||
my %hash;
|
||||
# Build key value pairs we can keep sorted
|
||||
for (0 .. $#{$names}) {
|
||||
$hash{$names->[$_]} = $values->[$_];
|
||||
}
|
||||
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
my $sort_f = exists $opts->{sort} ? $opts->{sort} : sub { lc $hash{$a} cmp lc $hash{$b} };
|
||||
my $sort_o = exists $opts->{sort_order} ? $opts->{sort_order} : '';
|
||||
my $out;
|
||||
|
||||
# Figure out how to order this select list.
|
||||
my @keys;
|
||||
if ($sort_o) { @keys = @$sort_o; }
|
||||
elsif ($sort_f) { @keys = sort { $sort_f->() } keys %hash }
|
||||
else { @keys = keys %hash }
|
||||
|
||||
if (! ref $def) {
|
||||
$def = [sort split (/\Q$INPUT_SEPARATOR\E%?/o, $def)];
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
KEY: foreach my $key (@keys) {
|
||||
my $val = $hash{$key};
|
||||
_escape(\$val);
|
||||
VAL: foreach my $sel (@$def) {
|
||||
($key eq $sel) and ($out .= qq~ <input name="$name" type="checkbox" value="$key" checked="checked"$class />$val~) and next KEY;
|
||||
}
|
||||
$out .= qq~ <input name="$name" type="checkbox" value="$key"$class />$val~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub hidden {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a hidden field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
return qq~<input type="hidden" name="$name" value="$def" />~;
|
||||
}
|
||||
|
||||
sub hidden_text {
|
||||
my ($self, $opts) = @_;
|
||||
my $out;
|
||||
my $html = $self->_get_html_display;
|
||||
$out .= "<font $self->{val_font}>";
|
||||
$out .= $self->$html($opts);
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
elsif (exists $opts->{def}->{time_check}) { $def = $self->_get_time ($opts->{def}) }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
$out .= qq~<input type="hidden" name="$opts->{name}" value="$def" /></font>~;
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub file {
|
||||
# ---------------------------------------------------------------
|
||||
# creates a file field
|
||||
#
|
||||
# function is a bit large since it has to do a fair bit, with multiple options.
|
||||
#
|
||||
my ($self, $opts, $values, $display ) = @_;
|
||||
|
||||
$values ||= {};
|
||||
$self->{file_field} or return $self->text($opts);
|
||||
|
||||
my @parts = split /\./, $opts->{name};
|
||||
my $name = pop @parts;
|
||||
my $dbname = shift @parts || $self->{db}->name;
|
||||
my $prefix = $self->{db}->prefix;
|
||||
$dbname =~ s,^$prefix,, if ($prefix);
|
||||
|
||||
my $def = $opts->{def};
|
||||
my $out;
|
||||
my $colname = $opts->{name}; $colname =~ s,^\d*-,,;
|
||||
my $fname = $opts->{value};
|
||||
_escape(\$fname);
|
||||
|
||||
# Find out if the file exists
|
||||
my $tbl = $display->{db}->new_table( $dbname . "_Files" ) or return 'Associated _File table is missing';
|
||||
my @pk = $self->{db}->pk; @pk == 1 or return 'File handling requires one primary key';
|
||||
|
||||
my $href = $tbl->get({ ForeignColName => $colname, ForeignColKey => $values->{$pk[0]} });
|
||||
|
||||
my $use_path = $self->{file_use_path} && -e $opts->{value};
|
||||
if ($use_path or $href) {
|
||||
|
||||
require GT::SQL::File;
|
||||
my $sfname = $values->{$colname."_filename"};
|
||||
$out = $sfname || GT::SQL::File->get_filename($fname ||= $href->{File_Name});
|
||||
$use_path and $out .= qq!<input name="$opts->{name}_path" type="hidden" value="$fname" />!;
|
||||
$sfname and $out .= qq!<input type="hidden" name="$opts->{name}_filename" value="$sfname" />!;
|
||||
|
||||
if ( $fname and $self->{file_delete} ) {
|
||||
|
||||
if ( $def->{form_type} =~ /^file$/i and not $self->{hide_downloads} and $self->{url} ) {
|
||||
my $url = _reparam_url(
|
||||
$self->{url},
|
||||
{
|
||||
do => 'download_file',
|
||||
id => $values->{$pk[0]},
|
||||
cn => $colname,
|
||||
db => $dbname,
|
||||
src => $use_path ? 'path' : 'db',
|
||||
fname => $fname
|
||||
},
|
||||
[qw( do id cn db src )]
|
||||
);
|
||||
$out .= qq! <font $self->{font}><font size="1"><i><a href="$url">download</a></i></font></font>!;
|
||||
$url = _reparam_url(
|
||||
$self->{url},
|
||||
{
|
||||
do => 'view_file',
|
||||
id => $values->{$pk[0]},
|
||||
cn => $colname,
|
||||
db => $dbname,
|
||||
src => $use_path ? 'path' : 'db',
|
||||
fname => $fname
|
||||
},
|
||||
[qw( do id cn db src )]
|
||||
);
|
||||
$out .= qq! <font $self->{font}><font size="1"><i><a href="$url" target="_blank">view</a></i></font></font>!;
|
||||
}
|
||||
my $checked = $values->{"${colname}_del"} ? ' checked="checked" ' : '';
|
||||
$out .= qq~ <input type="checkbox" name="$opts->{name}_del" value="delete"$checked /> Delete~;
|
||||
}
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
$out .= qq~<input type="file" name="$opts->{name}"$class />~;
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub text {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a text field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
return qq~<input type="text" name="$name" value="$def" size="$size"$class />~;
|
||||
}
|
||||
|
||||
sub password {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a password field.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my $def;
|
||||
if ( $opts->{blank} ) { $def = '' } # keep the password element blank
|
||||
elsif (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
return qq~<input type="password" name="$name" value="$def" size="$size"$class />~;
|
||||
}
|
||||
|
||||
sub textarea {
|
||||
# ---------------------------------------------------------------
|
||||
# Create a textarea.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to select");
|
||||
my $size = $opts->{def}->{form_size} ? $opts->{def}->{form_size} : $SIZE_FORMS{uc $opts->{def}->{type}};
|
||||
$size ||= 20;
|
||||
my ($cols, $rows) = (ref $size) ? (@{$size}) : ($size, 4);
|
||||
|
||||
my $def;
|
||||
if (defined $opts->{value}) { $def = $opts->{value} }
|
||||
elsif (exists $opts->{def}->{default}) { $def = $opts->{def}->{default} }
|
||||
else { $def = '' }
|
||||
_escape(\$def);
|
||||
my $class = ($opts->{def}->{class}) ? qq| class="$opts->{def}->{class}"| : "";
|
||||
return qq~<textarea rows="$rows" cols="$cols" name="$name"$class>\n$def</textarea>~;
|
||||
}
|
||||
|
||||
sub display_text {
|
||||
# ---------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator display_text");
|
||||
my $values = shift;
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to view creator display_text (" . (caller())[2] . ")" );
|
||||
my $val = exists $opts->{value} ? $opts->{value} : (exists $def->{default} ? $def->{default} : '');
|
||||
my $pval = $val;
|
||||
defined $val or ($val = '');
|
||||
_escape(\$val);
|
||||
|
||||
# If they are using checkbox/radio/selects then we map form_names => form_values.
|
||||
if (ref $def->{form_names} and ref $def->{form_values}) {
|
||||
if (@{$def->{form_names}} and @{$def->{form_values}}) {
|
||||
my %map = map { $def->{form_names}->[$_] => $def->{form_values}->[$_] } (0 .. $#{$def->{form_names}});
|
||||
my @keys = split /\Q$INPUT_SEPARATOR\E|\n/, $val;
|
||||
$val = '';
|
||||
|
||||
foreach (@keys) {
|
||||
$val .= $map{$_} ? $map{$_} : $_;
|
||||
$val .= "<br />";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($def->{form_type} and uc $def->{form_type} eq 'FILE' and not $self->{hide_downloads} and $self->{url}) {
|
||||
$pval or return $val;
|
||||
|
||||
my @parts = split /\./, $opts->{name};
|
||||
my $name = pop @parts;
|
||||
my $dbname = shift @parts || $self->{db}->name;
|
||||
my $prefix = $self->{db}->prefix;
|
||||
$dbname =~ s,^$prefix,, if ($prefix);
|
||||
my $colname = $opts->{name}; $colname =~ s,^$dbname\.,,g;
|
||||
|
||||
my @pk = $self->{db}->pk; @pk == 1 or return;
|
||||
my $url = _reparam_url( $self->{url}, { do => 'download_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
||||
$val .= qq! <font $self->{font}><font size="1"><i><a href="$url">download</a></i></font></font>!;
|
||||
|
||||
$url = _reparam_url( $self->{url}, { do => 'view_file', id => $values->{$pk[0]}, cn => $colname, db => $dbname }, [qw( do id cn db )] );
|
||||
$val .= qq! <font $self->{font}><font size="1"><i><a href="$url" target="_blank">view</a></i></font></font>!;
|
||||
}
|
||||
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _reparam_url {
|
||||
# ---------------------------------------------------------------
|
||||
my $orig_url = shift;
|
||||
my $add = shift || {};
|
||||
my $remove = shift || [];
|
||||
my %params = ();
|
||||
my $new_url = $orig_url;
|
||||
|
||||
# get the original parameters
|
||||
my $qloc = index( $orig_url, '?');
|
||||
if ( $qloc > 0 ) {
|
||||
require GT::CGI;
|
||||
$new_url = substr( $orig_url, 0, $qloc );
|
||||
my $base_parms = substr( $orig_url, $qloc+1 );
|
||||
$base_parms = GT::CGI::unescape($base_parms);
|
||||
|
||||
# now parse the parameters
|
||||
foreach my $param ( grep $_, split /[&;]/, $base_parms ) {
|
||||
my $eloc = index( $param, '=' );
|
||||
$eloc < 0 and push( @{$params{$param} ||= []}, undef ), next;
|
||||
my $key = substr( $param, 0, $eloc );
|
||||
my $value = substr( $param, $eloc+1 );
|
||||
push( @{$params{$key} ||= []}, $value);
|
||||
}
|
||||
}
|
||||
|
||||
# delete a few parameters
|
||||
foreach my $param ( @$remove ) { delete $params{$param}; }
|
||||
|
||||
# add a few parameters
|
||||
foreach my $key ( keys %$add ) {
|
||||
push( @{$params{$key} ||= []}, $add->{$key});
|
||||
}
|
||||
|
||||
# put everything together
|
||||
require GT::CGI;
|
||||
my @params;
|
||||
foreach my $key ( keys %params ) {
|
||||
foreach my $value ( @{$params{$key}} ) {
|
||||
push @params, GT::CGI::escape($key).'='.GT::CGI::escape($value);
|
||||
}
|
||||
}
|
||||
$new_url .= "?" . join( '&', @params );
|
||||
return $new_url;
|
||||
}
|
||||
|
||||
sub toolbar {
|
||||
# ---------------------------------------------------------------
|
||||
# Display/calculate a "next hits" toolbar.
|
||||
#
|
||||
my $class = shift;
|
||||
my ($nh, $maxhits, $numhits, $script) = @_;
|
||||
my ($next_url, $max_page, $next_hit, $prev_hit, $left, $right, $upper, $lower, $first, $url, $last, $i);
|
||||
|
||||
# Return if there shouldn't be a speedbar.
|
||||
return unless ($numhits > $maxhits);
|
||||
|
||||
# Strip nh=\d out of the query string, as we need to append it on. Try and keep
|
||||
# the url looking nice (i.e. no double ;&, or extra ?.
|
||||
$script =~ s/[&;]nh=\d+([&;]?)/$1/;
|
||||
$script =~ s/\?nh=\d+[&;]?/\?/;
|
||||
($script =~ /\?/) or ($script .= "?");
|
||||
$script =~ s/&/&/g;
|
||||
$next_hit = $nh + 1;
|
||||
$prev_hit = $nh - 1;
|
||||
$maxhits ||= 25;
|
||||
$max_page = int ($numhits / $maxhits) + (($numhits % $maxhits) ? 1 : 0);
|
||||
|
||||
# First, set how many pages we have on the left and the right.
|
||||
$left = $nh; $right = int($numhits/$maxhits) - $nh;
|
||||
# Then work out what page number we can go above and below.
|
||||
($left > 7) ? ($lower = $left - 7) : ($lower = 1);
|
||||
($right > 7) ? ($upper = $nh + 7) : ($upper = int($numhits/$maxhits) + 1);
|
||||
# Finally, adjust those page numbers if we are near an endpoint.
|
||||
(7 - $nh >= 0) and ($upper = $upper + (8 - $nh));
|
||||
($nh > ($numhits/$maxhits - 7)) and ($lower = $lower - ($nh - int($numhits/$maxhits - 7) - 1));
|
||||
$url = "";
|
||||
# Then let's go through the pages and build the HTML.
|
||||
($nh > 1) and ($url .= qq~<a href="$script;nh=1">[<<]</a> ~);
|
||||
($nh > 1) and ($url .= qq~<a href="$script;nh=$prev_hit">[<]</a> ~);
|
||||
for ($i = 1; $i <= int($numhits/$maxhits) + 1; $i++) {
|
||||
if ($i < $lower) { $url .= " ... "; $i = ($lower-1); next; }
|
||||
if ($i > $upper) { $url .= " ... "; last; }
|
||||
($i == $nh) ?
|
||||
($url .= qq~$i ~) :
|
||||
($url .= qq~<a href="$script&nh=$i">$i</a> ~);
|
||||
if ($i * $maxhits == $numhits) { $nh == $i and $next_hit = $i; last; }
|
||||
}
|
||||
$url .= qq~<a href="$script;nh=$next_hit">[>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
||||
$url .= qq~<a href="$script;nh=$max_page">[>>]</a> ~ unless ($next_hit == $nh or ($nh * $maxhits > $numhits));
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub escape {
|
||||
# ---------------------------------------------------------------
|
||||
# Public wrapper to private method.
|
||||
#
|
||||
return _escape ($_[1]);
|
||||
}
|
||||
|
||||
# ================================================================================ #
|
||||
# SEARCH WIDGETS #
|
||||
# ================================================================================ #
|
||||
|
||||
sub _mk_search_opts {
|
||||
# ---------------------------------------------------------------
|
||||
# Create the search options boxes based on type.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opts = shift or return $self->error ("BADARGS", "FATAL", "No hash ref passed to form creator _mk_search_opts");
|
||||
my $name = exists $opts->{name} ? $opts->{name} : return $self->error ("BADARGS", "FATAL", "No form name passed to form creator _mk_search_opts");
|
||||
my $def = exists $opts->{def} ? $opts->{def} : return $self->error ("BADARGS", "FATAL", "No type hash passed to form creator _mk_search_opts");
|
||||
my $val = '';
|
||||
CASE: {
|
||||
exists $opts->{value} and $val = $opts->{value}, last CASE;
|
||||
exists $self->{input}->{"$name-opt"} and $val = $self->{input}->{"$name-opt"}, last CASE;
|
||||
$opts->{pk} and $val = '=', last CASE;
|
||||
$opts->{unique} and $val = '=', last CASE;
|
||||
}
|
||||
$val = '>' if $val eq '>';
|
||||
$val = '<' if $val eq '<';
|
||||
|
||||
my $type = $def->{type};
|
||||
|
||||
my ($hash, $so);
|
||||
CASE: {
|
||||
($type =~ /INT|FLOAT|DOUBLE|DECIMAL/i)
|
||||
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than' },
|
||||
$so = [ 'LIKE', '=', '<>', '>', '<' ],
|
||||
$val ||= '=', last CASE;
|
||||
($type =~ /CHAR/i)
|
||||
and $hash = { 'LIKE' => 'Like', '=' => 'Exact Match', '<>' => 'Not Equal', },
|
||||
$so = [ 'LIKE', '=', '<>' ], last CASE;
|
||||
($type =~ /DATE|TIME/i)
|
||||
and $hash = { '=' => 'Exact Match', '<>' => 'Not Equal', '>' => 'Greater Than', '<' => 'Less Than' },
|
||||
$so = [ '=', '>', '<', '<>' ], last CASE;
|
||||
}
|
||||
|
||||
if ($hash) {
|
||||
return $self->select( { name => "$name-opt", values => $hash, sort_order => $so, value => $val, def => $def, blank => 0 } );
|
||||
}
|
||||
else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# ================================================================================ #
|
||||
# UTILS #
|
||||
# ================================================================================ #
|
||||
|
||||
sub _escape {
|
||||
# ---------------------------------------------------------------
|
||||
# Escape HTML quotes and < and >.
|
||||
#
|
||||
my $t = shift;
|
||||
return unless $$t;
|
||||
$$t =~ s/&/&/g;
|
||||
$$t =~ s/"/"/g;
|
||||
$$t =~ s/</</g;
|
||||
$$t =~ s/>/>/g;
|
||||
}
|
||||
|
||||
sub _get_time {
|
||||
# ---------------------------------------------------------------
|
||||
# Return current time for timestamp field.
|
||||
#
|
||||
my ($self, $col) = @_;
|
||||
my ($sec,$min,$hr,$day,$mon,$yr) = (localtime())[0..5];
|
||||
my $val;
|
||||
$mon++; $yr = $yr + 1900;
|
||||
($sec < 10) and ($sec = "0$sec"); ($min < 10) and ($min = "0$min"); ($hr < 10) and ($hr = "0$hr");
|
||||
($day < 10) and ($day = "0$day"); ($mon < 10) and ($mon = "0$mon");
|
||||
CASE: {
|
||||
($col->{type} =~ /DATETIME|TIMESTAMP/) and ($val = "$yr-$mon-$day $hr:$min:$sec"), last CASE;
|
||||
($col->{type} =~ /DATE/) and ($val = "$yr-$mon-$day"), last CASE;
|
||||
($col->{type} =~ /YEAR/) and ($val = "$yr"), last CASE;
|
||||
}
|
||||
return $val;
|
||||
}
|
||||
|
||||
sub _get_multi {
|
||||
my ($self, $opts) = @_;
|
||||
my ($names, $values) = ([], []);
|
||||
$opts->{def} ||= $self->{db}->{schema}->{cols}->{$opts->{name}};
|
||||
|
||||
# Deep copy $opts->{def} => $def
|
||||
my $def = {};
|
||||
while (my ($k, $v) = each %{$opts->{def}}) {
|
||||
if (! ref $v) {
|
||||
$def->{$k} = $v;
|
||||
}
|
||||
elsif (ref $v eq 'HASH') {
|
||||
$def->{$k} = {};
|
||||
foreach my $k1 (keys %{$opts->{def}->{$k}}) { $def->{$k}->{$k1} = $opts->{def}->{$k}->{$k1}; }
|
||||
}
|
||||
elsif (ref $v eq 'ARRAY') {
|
||||
$def->{$k} = [];
|
||||
foreach my $v1 (@{$opts->{def}->{$k}}) { push @{$def->{$k}}, $v1; }
|
||||
}
|
||||
else { $def->{$k} = $v; }
|
||||
}
|
||||
if (
|
||||
(exists $def->{form_names}) and
|
||||
(ref ($def->{form_names}) eq 'ARRAY') and
|
||||
(@{$def->{form_names}})
|
||||
)
|
||||
{
|
||||
$names = $def->{form_names};
|
||||
}
|
||||
elsif (
|
||||
(exists $def->{values}) and
|
||||
(ref ($def->{values}) eq 'ARRAY') and
|
||||
(@{$def->{values}})
|
||||
)
|
||||
{
|
||||
$names = $def->{values};
|
||||
}
|
||||
|
||||
# Get the values.
|
||||
if (
|
||||
(exists $def->{form_values}) and
|
||||
(ref ($def->{form_values}) eq 'ARRAY') and
|
||||
(@{$def->{form_values}})
|
||||
)
|
||||
{
|
||||
$values = $def->{form_values};
|
||||
}
|
||||
elsif (
|
||||
(exists $def->{values}) and
|
||||
(ref ($def->{values}) eq 'ARRAY') and
|
||||
(@{$def->{values}})
|
||||
)
|
||||
{
|
||||
$values = $def->{values};
|
||||
}
|
||||
|
||||
# Can pass in a hash here.
|
||||
if (
|
||||
(exists $opts->{values}) and
|
||||
(ref ($opts->{values}) eq 'HASH') and
|
||||
(keys %{$opts->{values}})
|
||||
)
|
||||
{
|
||||
@{$names} = keys %{$opts->{values}};
|
||||
@{$values} = values %{$opts->{values}};
|
||||
}
|
||||
|
||||
@{$names} or @{$names} = @{$values};
|
||||
@{$values} or @{$values} = @{$names};
|
||||
|
||||
return ($names, $values);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
@ -0,0 +1,278 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: Relation.pm,v 1.18 2004/08/28 03:53:45 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML::Relation;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS/;
|
||||
use GT::SQL::Display::HTML;
|
||||
|
||||
@ISA = qw/GT::SQL::Display::HTML/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
code => {},
|
||||
mode => '',
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border=0 width=500',
|
||||
tr => '',
|
||||
td => 'valign=top align=left',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0,
|
||||
};
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my $self = shift;
|
||||
my $opts = shift;
|
||||
$self->reset_opts;
|
||||
$opts->{disp_form} = 0;
|
||||
$opts->{disp_html} = 1;
|
||||
return $self->_display ($opts || ());
|
||||
}
|
||||
|
||||
sub _display {
|
||||
# ---------------------------------------------------------------
|
||||
# Handles displaying of a form or a record.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash and primary key
|
||||
$self->{pk} = [$self->{db}->pk] unless $self->{pk};
|
||||
$self->{cols} = $self->{db}->ordered_columns;
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}}) if ($self->{pk});
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @ntables = values %{$self->{db}->{tables}};
|
||||
my (@tmp, @tables);
|
||||
for my $t (@ntables) {
|
||||
my @cols = $t->ordered_columns;
|
||||
my %fk = $t->fk;
|
||||
my %cols = $t->cols;
|
||||
my $name = $t->name;
|
||||
my $found = 0;
|
||||
COL: foreach my $col_name (@cols) {
|
||||
if (exists $self->{values}->{$col_name}) {
|
||||
$self->{values}->{$name . '.' . $col_name} = delete $self->{values}->{$col_name};
|
||||
}
|
||||
$self->{cols}->{$name . '.' . $col_name} = $cols{$col_name};
|
||||
FK: for (keys %fk) {
|
||||
if (exists $self->{db}->{tables}->{$_}) {
|
||||
if (exists $fk{$_}->{$col_name}) {
|
||||
$found = 1;
|
||||
last FK;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$found ? (push (@tmp, $t)) : (@tables = ($t));
|
||||
}
|
||||
push @tables, @tmp;
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Set the table widths depending on if we need a third column.
|
||||
my ($cwidth, $vwidth) = ('30%', '70%');
|
||||
if ($self->{search_opts}) { $cwidth = "30%"; $vwidth = "60%" }
|
||||
|
||||
for my $table (@tables) {
|
||||
$out .= $self->mk_table (
|
||||
table => $table,
|
||||
values => $values,
|
||||
cwidth => $cwidth,
|
||||
vwidth => $vwidth
|
||||
);
|
||||
}
|
||||
$out .= '<br>';
|
||||
|
||||
foreach (@{$self->{hide}}) {
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$_" : $_;
|
||||
my $val = $values->{$_};
|
||||
if (exists $self->{cols}->{$_}->{time_check} and $self->{cols}->{$_}->{time_check}) {
|
||||
$val ||= $self->_get_time ($self->{cols}->{$_});
|
||||
}
|
||||
defined $val or ($val = '');
|
||||
GT::SQL::Display::HTML::_escape(\$val);
|
||||
$out .= qq~<input type="hidden" name="$field_name" value="$val">~;
|
||||
}
|
||||
$self->{extra_table} and ($out .= "</td></tr></table>\n");
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub mk_table {
|
||||
my $self = shift;
|
||||
my %opt = @_;
|
||||
|
||||
my $out = '';
|
||||
$self->{extra_table} and ($out .= "<p><table border=1 cellpadding=0 cellspacing=0><tr><td>");
|
||||
my $cols = $opt{table}->cols;
|
||||
my $name = $opt{table}->name;
|
||||
|
||||
$out .= qq(
|
||||
<table $self->{table}>
|
||||
<tr><td colspan=3 bgcolor=navy>
|
||||
<FONT FACE="MS Sans Serif, arial,helvetica" size=1 COLOR="#FFFFFF">$name</font>
|
||||
</td></tr>
|
||||
);
|
||||
my @cols = $opt{table}->ordered_columns;
|
||||
my %fk = $opt{table}->fk;
|
||||
|
||||
COL: foreach my $col_name (@cols) {
|
||||
$out .= $self->mk_row (%opt, col_name => $col_name, fk => \%fk);
|
||||
}
|
||||
$out .= "</table>\n";
|
||||
$out .= "</table></p>\n" if $self->{extra_table};
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub mk_row {
|
||||
my $self = shift;
|
||||
my %opt = @_;
|
||||
my $out = '';
|
||||
for (keys %{$opt{fk}}) {
|
||||
if (exists $self->{db}->{tables}->{$_}) {
|
||||
(exists $opt{fk}->{$_}->{$opt{col_name}}) and return '';
|
||||
}
|
||||
}
|
||||
my $col = $opt{table}->name . '.' . $opt{col_name};
|
||||
|
||||
# Run any code refs that have been setup.
|
||||
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $opt{values});
|
||||
return '';
|
||||
}
|
||||
return '' if $self->_skip ($col);
|
||||
|
||||
# Set the form name (using increment for multiple if requested) and also the display name.
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = exists ($self->{cols}->{$col}->{form_display}) ? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $opt{values}->{$col};
|
||||
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
|
||||
|
||||
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and return '';
|
||||
$out .= "<tr $self->{tr}><td $self->{td} width='$opt{cwidth}'><font $self->{col_font}>$display_name</font></td><td $self->{td} width='$opt{vwidth}'><font $self->{val_font}>";
|
||||
|
||||
# Get the column display subroutine
|
||||
$out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value }, $opt{values}, $self );
|
||||
|
||||
$out .= "</font></td>";
|
||||
|
||||
# Display any search options if requested.
|
||||
if ($self->{search_opts}) {
|
||||
my $is_pk = 0;
|
||||
for (@{$self->{pk}}) {
|
||||
$is_pk = 1, last if ($_ eq $col);
|
||||
}
|
||||
|
||||
$out .= qq~<td $self->{td} width="10%"><font $self->{val_font}>~;
|
||||
$out .= $self->_mk_search_opts({
|
||||
name => $field_name,
|
||||
def => $self->{cols}->{$col},
|
||||
pk => $is_pk
|
||||
}) || ' ';
|
||||
$out .= "</font></td>";
|
||||
}
|
||||
$out .= "\n";
|
||||
return $out;
|
||||
|
||||
}
|
||||
|
||||
sub _get_defaults {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns default values for fields. Bases it on what's passed in,
|
||||
# cgi input, def file defaults, otherwise blank.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my @ntables = values %{$self->{db}->{tables}};
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $c = $self->{cols};
|
||||
my $values = {};
|
||||
foreach my $col (@cols) {
|
||||
my $value = '';
|
||||
if (exists $self->{values}->{$col}) { $value = $self->{values}->{$col} }
|
||||
elsif (exists $self->{input}->{$col}) { $value = $self->{input}->{$col} }
|
||||
elsif ($self->{defaults} and exists $c->{$col}->{default}) {
|
||||
if ($c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
(defined $c->{$col}->{default} and $c->{$col}->{default} =~ /0000/)
|
||||
? ($value = $self->_get_time($c->{$col}))
|
||||
: ($value = $c->{$col}->{default});
|
||||
}
|
||||
else {
|
||||
$value = $c->{$col}->{default};
|
||||
}
|
||||
}
|
||||
elsif ($self->{defaults} and $c->{$col}->{type} =~ /DATE|TIME|YEAR/) {
|
||||
$value = $self->_get_time($c->{$col});
|
||||
}
|
||||
$values->{$col} = $value;
|
||||
}
|
||||
return $values;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields.
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
|
||||
=cut
|
||||
@ -0,0 +1,299 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: Table.pm,v 1.29 2009/05/11 23:09:59 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# HTML module that provides a set of method to control your
|
||||
# user display in order to get rid of HTML coding inside CGI script.
|
||||
#
|
||||
|
||||
package GT::SQL::Display::HTML::Table;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $VERSION $ERROR_MESSAGE $ATTRIBS $DEBUG $FONT %SIZE_FORMS/;
|
||||
use GT::SQL::Display::HTML;
|
||||
|
||||
@ISA = qw/GT::SQL::Display::HTML/;
|
||||
$FONT = 'face="Tahoma,Arial,Helvetica" size=2';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.29 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
$ATTRIBS = {
|
||||
db => undef,
|
||||
input => undef,
|
||||
code => {},
|
||||
font => $FONT,
|
||||
hide_timestamp => 0,
|
||||
view_key => 0,
|
||||
defaults => 0,
|
||||
search_opts => 0,
|
||||
values => {},
|
||||
multiple => 0,
|
||||
table => 'border=0 width=500',
|
||||
tr => '',
|
||||
mode => '',
|
||||
td => 'valign=top align=left',
|
||||
extra_table => 1,
|
||||
col_font => $FONT,
|
||||
val_font => $FONT,
|
||||
hide => [],
|
||||
skip => [],
|
||||
view => [],
|
||||
disp_form => 1,
|
||||
disp_html => 0,
|
||||
file_field => 0,
|
||||
file_delete => 0,
|
||||
file_use_path => 0
|
||||
};
|
||||
|
||||
|
||||
sub display_row {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record row as html.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{disp_form} = 0;
|
||||
$opts->{disp_html} = 1;
|
||||
return $self->_display_row ($opts || ());
|
||||
}
|
||||
|
||||
sub display_row_cols {
|
||||
# ---------------------------------------------------------------
|
||||
# returns the <td></td> for each of the title names for columns
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash and primary key
|
||||
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
|
||||
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
my $script = GT::CGI->url();
|
||||
$script =~ s/[\&;]?sb=([^&;]*)//g;
|
||||
my $sb = $1;
|
||||
$script =~ s/[\&;]?so=(ASC|DESC)//g;
|
||||
my $so = $1;
|
||||
|
||||
foreach my $col (@cols) {
|
||||
$out .= qq!\n\t<td><font $self->{col_font}><b>!;
|
||||
$out .= qq!<a href="$script&sb=$col&so=! . ( ( ( $col eq $sb ) and $so eq 'ASC' ) ? 'DESC' : 'ASC' ) . qq!">!;
|
||||
$out .= exists $self->{db}->{schema}->{cols}->{$col}->{form_display} ? $self->{db}->{schema}->{cols}->{$col}->{form_display} : $col;
|
||||
$out .= ( ( $col eq $sb ) ? ( ($so eq 'ASC') ? " ^" : " v" ) : '' ) . "</a>";
|
||||
$out .= qq!</b></font></td>\n!;
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub _display_row {
|
||||
# ---------------------------------------------------------------
|
||||
# Handles displaying of a form or a record.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash and primary key
|
||||
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
|
||||
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
foreach my $col (@cols) {
|
||||
|
||||
# Run any code refs that have been setup.
|
||||
if (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values, $col);
|
||||
next;
|
||||
}
|
||||
next if $self->_skip ($col);
|
||||
|
||||
# Set the form name (using increment for multiple if requested) and also the display name.
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = exists $self->{cols}->{$col}->{form_display} ? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $values->{$col};
|
||||
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
|
||||
|
||||
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and next;
|
||||
|
||||
$out .= qq!\n\t<td valign=texttop><font $self->{col_font}>!;
|
||||
|
||||
# Get the column display subroutine
|
||||
$out .= $self->$disp( { name => $field_name, def => $self->{cols}->{$col}, value => $value });
|
||||
|
||||
$out .= qq!</font></td>\n!;
|
||||
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub display {
|
||||
# ---------------------------------------------------------------
|
||||
# Display a record as html.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{disp_form} = 0;
|
||||
$opts->{disp_html} = 1;
|
||||
return $self->_display ($opts || ());
|
||||
}
|
||||
|
||||
sub _display {
|
||||
# ---------------------------------------------------------------
|
||||
# Handles displaying of a form or a record.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# Initiate if we are passed in any arguments as options.
|
||||
if (@_) { $self->init (@_); }
|
||||
|
||||
# Get the column hash, primary keys, and unique columns
|
||||
$self->{cols} = $self->{db}->cols unless exists $self->{cols};
|
||||
$self->{pk} = [$self->{db}->pk] unless exists $self->{pk};
|
||||
|
||||
# Output
|
||||
my $out = '';
|
||||
|
||||
# Hide the primary keys.
|
||||
$self->{view_key} and push (@{$self->{view}}, @{$self->{pk}});
|
||||
|
||||
# Opening table.
|
||||
$self->{extra_table} and ($out .= "<table border=1 cellpadding=0 cellspacing=0><tr><td>");
|
||||
$out .= "<table $self->{table}>";
|
||||
|
||||
# Set the table widths depending on if we need a third column.
|
||||
my ($cwidth, $vwidth);
|
||||
if ($self->{search_opts}) { $cwidth = "30%"; $vwidth = "60%" }
|
||||
else { $cwidth = "30%"; $vwidth = "70%" }
|
||||
|
||||
# Calculate the form values.
|
||||
my $values = $self->_get_defaults;
|
||||
|
||||
# Now go through each column and print out a column row.
|
||||
my @cols = $self->{db}->ordered_columns;
|
||||
foreach my $col (@cols) {
|
||||
# Run any code refs that have been setup.
|
||||
if (ref $self->{code}->{$col} eq 'CODE') {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values, $col);
|
||||
next;
|
||||
}
|
||||
next if $self->_skip ($col);
|
||||
|
||||
# Set the form name (using increment for multiple if requested) and also the display name.
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = (exists $self->{cols}->{$col}->{form_display} and length $self->{cols}->{$col}->{form_display})
|
||||
? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $values->{$col};
|
||||
my $disp = $self->{disp_form} ? $self->_get_form_display ($col) : $self->_get_html_display ($col);
|
||||
|
||||
$disp eq 'hidden' and push (@{$self->{hide}}, $col) and next;
|
||||
$out .= "<tr $self->{tr}><td $self->{td} width='$cwidth'><font $self->{col_font}>$display_name</font></td><td $self->{td} width='$vwidth'><font $self->{val_font}>";
|
||||
|
||||
# Get the column display subroutine
|
||||
my $o = $self->$disp(
|
||||
{
|
||||
name => $field_name,
|
||||
def => $self->{cols}->{$col},
|
||||
value => (defined $value ? $value : '')
|
||||
},
|
||||
($values || {}),
|
||||
$self
|
||||
);
|
||||
$out .= $o if defined $o;
|
||||
|
||||
# Add edit/delete links next to the primary key in search results.
|
||||
if ($self->{mode} eq 'search_results' and @{$self->{pk}} == 1 and $col eq $self->{pk}->[0]) {
|
||||
my $url = GT::CGI->url({ query_string => 0 }) . '?';
|
||||
my @vals = GT::CGI->param('db');
|
||||
for my $val (@vals) {
|
||||
$url .= 'db=' . GT::CGI->escape($val) . ';';
|
||||
}
|
||||
chop $url;
|
||||
$out .= qq| <small><a href="$url;do=modify_form;modify=1;1-$col=$value">edit</a> <a href="$url;do=delete_search_results;$col-opt=%3D;$col=$value">delete</a></small>|;
|
||||
}
|
||||
$out .= "</font></td>";
|
||||
|
||||
# Display any search options if requested.
|
||||
if ($self->{search_opts}) {
|
||||
$out .= qq~<td $self->{td} width="10%"><font $self->{val_font}>~;
|
||||
$out .= $self->_mk_search_opts({
|
||||
name => $field_name,
|
||||
def => $self->{cols}->{$col},
|
||||
pk => $self->{db}->_is_pk($col),
|
||||
unique => $self->{db}->_is_unique($col)
|
||||
}) || ' ';
|
||||
$out .= "</font></td>";
|
||||
}
|
||||
$out .= "\n";
|
||||
}
|
||||
$out .= "</table>\n";
|
||||
|
||||
my %seen;
|
||||
foreach (@{$self->{hide}}) {
|
||||
next if $seen{$_}++;
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$_" : $_;
|
||||
my $val = $values->{$_};
|
||||
if (exists $self->{cols}->{$_}->{time_check} and $self->{cols}->{$_}->{time_check}) {
|
||||
$val ||= $self->_get_time ($self->{cols}->{$_});
|
||||
}
|
||||
defined $val or ($val = '');
|
||||
GT::SQL::Display::HTML::_escape(\$val);
|
||||
$out .= qq~<input type="hidden" name="$field_name" value="$val">~;
|
||||
}
|
||||
$self->{extra_table} and ($out .= "</td></tr></table>\n");
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
# Options for display forms/views:
|
||||
# hide_timestamp => 1 # Do not display timestamp fields.
|
||||
# search_opts => 1 # Add search options boxes.
|
||||
# multiple => 1 # Prepend $multiple- to column names.
|
||||
# defaults => 1 # Use .def defaults.
|
||||
# values => {} # hash ref of values to use (overrides input)
|
||||
# table => 'string' # table properties, defaults to 0 border.
|
||||
# tr => 'string' # table row properties, defaults to none.
|
||||
# td => 'string' # table cell properties, defaults to just aligns.
|
||||
# extra_table => 0 # disable wrap form in extra table for looks.
|
||||
# col_font => 'string' # font to use for columns, defaults to $FONT.
|
||||
# val_font => 'string' # font to use for values, defaults to $FONT.
|
||||
# hide => [] # display fields as hidden tags.
|
||||
# view => [] # display fields as html with hidden tags as well.
|
||||
# skip => [] # don't display array of column names.
|
||||
|
||||
=cut
|
||||
904
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver.pm
Normal file
904
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver.pm
Normal file
@ -0,0 +1,904 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Driver.pm,v 2.6 2005/11/03 01:38:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Overview: This implements a driver class.
|
||||
#
|
||||
|
||||
package GT::SQL::Driver;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::SQL::Table;
|
||||
use GT::AutoLoader;
|
||||
use GT::SQL::Driver::Types;
|
||||
use GT::SQL::Driver::debug;
|
||||
use Exporter();
|
||||
require GT::SQL::Driver::sth;
|
||||
use vars qw/%CONN @ISA $DEBUG $VERSION $ERROR_MESSAGE $ATTRIBS %QUERY_MAP/;
|
||||
|
||||
use constant PROTOCOL => 2;
|
||||
|
||||
$ATTRIBS = {
|
||||
name => '',
|
||||
schema => '',
|
||||
dbh => '',
|
||||
connect => {}
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 2.6 $ =~ /(\d+)\.(\d+)/;
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::debug/;
|
||||
|
||||
%QUERY_MAP = (
|
||||
# QUERY => METHOD (will be prefixed with '_prepare_' or '_execute_')
|
||||
CREATE => 'create',
|
||||
INSERT => 'insert',
|
||||
ALTER => 'alter',
|
||||
SELECT => 'select',
|
||||
UPDATE => 'update',
|
||||
DROP => 'drop',
|
||||
DELETE => 'delete',
|
||||
DESCRIBE => 'describe',
|
||||
'SHOW TABLES' => 'show_tables',
|
||||
'SHOW INDEX' => 'show_index'
|
||||
);
|
||||
|
||||
$DBI::errstr if 0;
|
||||
|
||||
sub load_driver {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Loads a sub-driver (i.e. GT::SQL::Driver::MYSQL, GT::SQL::Driver::PG, etc.),
|
||||
# and creates and returns a new driver object. The first argument should be
|
||||
# the name of the driver (e.g. 'PG'), and the remaining arguments are passed to
|
||||
# new() - which could well be handled by the driver.
|
||||
#
|
||||
my ($class, $driver, @opts) = @_;
|
||||
|
||||
# Old GT::SQL versions had an 'ODBC' driver that wasn't an ODBC driver, but an
|
||||
# MSSQL driver that used ODBC.
|
||||
$driver = 'MSSQL' if $driver eq 'ODBC';
|
||||
|
||||
my $pkg = "GT::SQL::Driver::$driver";
|
||||
my $lib_path = $INC{'GT/SQL/Driver.pm'};
|
||||
$lib_path =~ s|GT/SQL/Driver\.pm$||;
|
||||
{
|
||||
# Ensure that the driver is loaded from the same location as GT/SQL/Driver.pm
|
||||
local @INC = ($lib_path, @INC);
|
||||
require "GT/SQL/Driver/$driver.pm";
|
||||
}
|
||||
|
||||
my $protocol = $pkg->protocol_version;
|
||||
return $class->fatal(DRIVERPROTOCOL => PROTOCOL, $protocol) if $protocol != PROTOCOL;
|
||||
|
||||
return $pkg->new(@opts);
|
||||
}
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Generic new() method for drivers to inherit; load_driver() should be used
|
||||
# instead to get a driver object.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $self = bless {}, $class;
|
||||
my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); invalid parameter: '@_'");
|
||||
|
||||
# Otherwise we need to make sure we have a schema.
|
||||
$opts->{schema} and ref $opts->{schema} or return $self->fatal(BADARGS => "$class->new(HASH REF or HASH); must specify schema and name");
|
||||
|
||||
$self->{name} = $opts->{name};
|
||||
$self->{schema} = $opts->{schema};
|
||||
$self->{connect} = $opts->{connect};
|
||||
$self->{_debug} = $opts->{debug} || $DEBUG;
|
||||
$self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';
|
||||
$self->{dbh} = undef;
|
||||
$self->{hints} = { $self->hints };
|
||||
$self->debug("New driver object loaded from table: $self->{name}.") if ($self->{_debug} > 2);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
# This method is designed to be subclassed to provide "hints" for simple, small
|
||||
# differences between drivers, which simplifies the code over using a subclass.
|
||||
# It returns a hash of hints, with values of "1" unless otherwise indicated.
|
||||
# Currently supported hints are:
|
||||
# case_map # Corrects ->fetchrow_hashref column case when the database doesn't
|
||||
# prefix_indexes # Indexes will be prefixed with the table name (including the table's prefix)
|
||||
# fix_index_dbprefix # Look for erroneous (db_prefix)(index) when dropping indexes
|
||||
# now # Specifies an SQL value to use instead of NOW() (for 'time_check' columns, among other things)
|
||||
# bind # An array ref of: [\%BIND_HASH, ('COLUMNTYPE' => $bind_type, 'TYPE2' => $bind_type2, ...)] for drivers that need special placeholder binding for certain column types
|
||||
# ai # Contains a string to use for an AI column; or a code reference that is passed ($table, $column) and returns the string, or an array reference of queries to run to create the ai sequence after the column/table has been created
|
||||
# drop_pk_constraint # use ALTER TABLE ... DROP CONSTRAINT pkeyname to drop a primary key
|
||||
sub hints { () }
|
||||
# Removing the () breaks under 5.00404, as it will return @_ in list context
|
||||
|
||||
$COMPILE{protocol_version} = __LINE__ . <<'END_OF_SUB';
|
||||
sub protocol_version {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This checks the GT::SQL::Driver protocol, and dies if the versions aren't
|
||||
# equal. The protocol version only changes for major driver changes such as
|
||||
# the v2.000 version of this module, which had the drivers do their own queries
|
||||
# (as opposed to the previous hack of having drivers trying to return alternate
|
||||
# versions of MySQL's queries). All protocol v2 and above drivers are required
|
||||
# to override this - any driver that does not is, by definition, a protocol v1
|
||||
# driver.
|
||||
#
|
||||
# The current protocol version is defined by the PROTOCOL constant - but
|
||||
# drivers that haven't overridden protocol_version() are, by definition, v1.
|
||||
#
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub available_drivers {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a list of available GT::SQL::Driver::* drivers
|
||||
#
|
||||
my $driver_path = $INC{'GT/SQL/Driver.pm'};
|
||||
$driver_path =~ s/\.pm$//;
|
||||
my $dh = \do { local *DH; *DH };
|
||||
my @drivers;
|
||||
opendir $dh, $driver_path or return ();
|
||||
while (defined(my $driver = readdir $dh)) {
|
||||
# By convention, only all-uppercase modules are accepted as GT::SQL drivers
|
||||
next unless $driver =~ /^([A-Z_][A-Z0-9_]*)\.pm$/;
|
||||
push @drivers, $1;
|
||||
}
|
||||
@drivers;
|
||||
}
|
||||
|
||||
sub connect {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the current database handle.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{dbh} and return $self->{dbh};
|
||||
|
||||
eval { require DBI };
|
||||
if ($@) {
|
||||
return $self->warn(CANTCONNECT => "DBI module not installed. You must install the perl database module DBI from: http://www.perl.com/CPAN/modules/by-module/DBI");
|
||||
}
|
||||
|
||||
# Make sure we have a database, otherwise probably an error.
|
||||
exists $self->{connect}->{database} or return $self->fatal(CANTCONNECT => "No connection string passed to tbl->connect, make sure your table object got a connection hash.");
|
||||
keys %{$self->{schema}} or return $self->fatal(CANTCONNECT => "Unable to connect to database without a valid schema.");
|
||||
|
||||
my $dsn = $self->dsn($self->{connect});
|
||||
my $conn_key = "$dsn\0$self->{connect}->{login}\0$self->{connect}->{password}";
|
||||
if (defined $CONN{$conn_key}) {
|
||||
$self->{dbh} = $CONN{$conn_key};
|
||||
$self->debug("Using stored connection: $dsn") if ($self->{_debug} > 1);
|
||||
return $CONN{$conn_key};
|
||||
}
|
||||
|
||||
# Connect to the database.
|
||||
$self->debug("Connecting to database with: '$dsn', '$self->{connect}->{login}', '******'") if ($self->{_debug} > 1);
|
||||
my $res = eval {
|
||||
$CONN{$conn_key} = DBI->connect($dsn, $self->{connect}->{login}, $self->{connect}->{password}, { RaiseError => $self->{connect}->{RaiseError}, PrintError => $self->{connect}->{PrintError}, AutoCommit => 1 })
|
||||
or die "$DBI::errstr\n";
|
||||
1;
|
||||
};
|
||||
$res or return $self->warn(CANTCONNECT => "$@");
|
||||
|
||||
$self->{dbh} = $CONN{$conn_key};
|
||||
$self->debug("Connected successfully to database.") if $self->{_debug} > 1;
|
||||
|
||||
return $self->{dbh};
|
||||
}
|
||||
|
||||
$COMPILE{dsn} = __LINE__ . <<'END_OF_SUB';
|
||||
sub dsn {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates the data source name used by DBI to connect to the database.
|
||||
# Since this is database-dependant, this is just a stub.
|
||||
#
|
||||
require Carp;
|
||||
Carp::croak("Driver has no dsn()");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prepare_raw} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prepare_raw {
|
||||
# ---------------------------------------------------------------
|
||||
# Returns a raw sth object.
|
||||
# WARNING: MAKE SURE YOUR SQL IS PORTABLE AS NO ALTERATIONS WILL
|
||||
# BE MADE! ALSO YOU MUST MANUALLY CALL ->finish ON THESE!
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$self->debug("Preparing RAW query: $query") if $self->{_debug} > 1;
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query);
|
||||
$self->debug("RAW STH is prepared: $query") if $self->{_debug} > 1;
|
||||
return $sth;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{prepare} = __LINE__ . <<'END_OF_SUB';
|
||||
sub prepare {
|
||||
# ---------------------------------------------------------------
|
||||
# We can override whatever type of queries we need to alter by replacing
|
||||
# the _prepare_* functions.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if (! defined $query) {
|
||||
return $self->warn(CANTPREPARE => "", "Empty Query");
|
||||
}
|
||||
|
||||
# For any drivers that need hacked-in limit support (currently MS SQL and Oracle):
|
||||
delete @$self{qw/_limit _lim_offset _lim_rows/};
|
||||
|
||||
if (my $now = $self->{hints}->{now}) {
|
||||
$query =~ s/\bNOW\(\)/$now/g;
|
||||
}
|
||||
|
||||
if ($query =~ /^\s*SHOW\s+TABLES\s*(?:;\s*)?$/i) {
|
||||
$self->{do} = 'SHOW TABLES';
|
||||
}
|
||||
elsif ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+\w+\s*(?:;\s*)?$/i) {
|
||||
# See 'Driver-specific notes' below
|
||||
$self->{do} = 'SHOW INDEX';
|
||||
}
|
||||
else {
|
||||
$self->{do} = uc +($query =~ /(\w+)/)[0];
|
||||
}
|
||||
if (my $meth = $QUERY_MAP{$self->{do}}) {
|
||||
$meth = "_prepare_$meth";
|
||||
$query = $self->$meth($query) or return;
|
||||
}
|
||||
|
||||
$self->{query} = $query;
|
||||
$self->debug("Preparing query: $query") if $self->{_debug} > 1;
|
||||
|
||||
$self->{sth} = $self->{dbh}->prepare($query)
|
||||
or return $self->warn(CANTPREPARE => $query, $DBI::errstr);
|
||||
|
||||
my $pkg = ref($self) . '::sth';
|
||||
$self->debug("CREATING $pkg OBJECT") if $self->{_debug} > 2;
|
||||
return $pkg->new($self);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Define one generic prepare, and alias all the specific _prepare_* functions to it
|
||||
sub _generic_prepare { $_[1] }
|
||||
for (*_prepare_create, *_prepare_insert, *_prepare_alter, *_prepare_select, *_prepare_update, *_prepare_drop, *_prepare_delete, *_prepare_describe) {
|
||||
$_ = \&_generic_prepare;
|
||||
}
|
||||
# Driver-specific notes:
|
||||
# 'SHOW TABLES'
|
||||
# The driver should return single-column rows of non-system tables in the
|
||||
# database. The name of the column is not important, and users of SHOW TABLE
|
||||
# should not depend on it (i.e. do not use ->fetchrow_hashref)
|
||||
*_prepare_show_tables = \&_generic_prepare;
|
||||
# 'SHOW INDEX FROM table'
|
||||
# Drivers should return one row per column per index, having at least the keys:
|
||||
# - index_name: the name of the index
|
||||
# - index_column: the name of the column
|
||||
# - index_unique: 1 if the index is unique, 0 otherwise
|
||||
# - index_primary: 1 if the column is a primary key, 0 otherwise
|
||||
#
|
||||
# The rows must be grouped by index, and ordered by the position of the column
|
||||
# within said groupings.
|
||||
#
|
||||
# So, for a unique index named 'unique1' on columns 'col1', 'col2', 'col3', and
|
||||
# a normal index named 'index1' on 'col3', 'col4', and a primary key on
|
||||
# 'colpk', you should get (at a minimum; extra columns are permitted):
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | index_name | index_column | index_unique | index_primary |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | unique1 | col1 | 1 | 0 |
|
||||
# | unique1 | col2 | 1 | 0 |
|
||||
# | unique1 | col3 | 1 | 0 |
|
||||
# | index1 | col3 | 0 | 0 |
|
||||
# | index1 | col4 | 0 | 0 |
|
||||
# | PRIMARY | colpk | 1 | 1 |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# 'PRIMARY' above should be changed by drivers whose databases have named
|
||||
# primary keys, otherwise using 'PRIMARY' for the primary key is recommended.
|
||||
#
|
||||
# Any other information may be returned; users of this query mapping should
|
||||
# always use ->fetchrow_hashref, and access the above four keys for
|
||||
# portability.
|
||||
#
|
||||
# Note that index_primary results may overlap other indexes for some databases
|
||||
# - Oracle, in particular, will bind a primary key onto an existing index if
|
||||
# possible. In such a case, you'll get the index indicated normally, but some
|
||||
# of the columns may make up the primary key. For example, the following
|
||||
# result would indicate that there is one index on col1, col2, col3, and that
|
||||
# there is a primary key made up of (col1, col2):
|
||||
#
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | index_name | index_column | index_unique | index_primary |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
# | index1 | col1 | 0 | 1 |
|
||||
# | index1 | col2 | 0 | 1 |
|
||||
# | index1 | col3 | 0 | 0 |
|
||||
# +------------+--------------+--------------+---------------+
|
||||
#
|
||||
# Currently, results such as the above are known to occur in Oracle databases
|
||||
# where a primary key was added to an already-indexed column after creating the
|
||||
# table - other databases give primary keys an independant index.
|
||||
#
|
||||
# Although _prepare_show_index is defined here, no drivers actually satisfy the
|
||||
# above without some query result remapping, and as such all currently override
|
||||
# either this or _execute_show_index.
|
||||
*_prepare_show_index = \&_generic_prepare;
|
||||
|
||||
$COMPILE{extract_index_name} = __LINE__ . <<'END_OF_SUB';
|
||||
sub extract_index_name {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Takes an table name and database index name (which could be prefixed, if the
|
||||
# database uses prefixes) and returns the GT::SQL index name (i.e. without
|
||||
# prefix).
|
||||
my ($self, $table, $index) = @_;
|
||||
if ($self->{hints}->{prefix_indexes}) {
|
||||
$index =~ s/^\Q$table\E(?=.)//i;
|
||||
}
|
||||
$index;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub disconnect {
|
||||
# -------------------------------------------------------------------
|
||||
# Disconnect from the database.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{dbh} and $self->{dbh}->disconnect;
|
||||
}
|
||||
|
||||
sub reset_env {
|
||||
# -------------------------------------------------------------------
|
||||
# Remove all database connections that aren't still alive
|
||||
#
|
||||
@GT::SQL::Driver::debug::QUERY_STACK = ();
|
||||
for my $dsn (keys %CONN) {
|
||||
next if ($CONN{$dsn} and $CONN{$dsn}->ping);
|
||||
$CONN{$dsn}->disconnect if ($CONN{$dsn});
|
||||
delete $CONN{$dsn};
|
||||
}
|
||||
}
|
||||
|
||||
sub do {
|
||||
# -------------------------------------------------------------------
|
||||
# Do a query.
|
||||
#
|
||||
my $self = shift;
|
||||
($self->prepare(@_) or return)->execute;
|
||||
}
|
||||
|
||||
$COMPILE{do_raw_transaction} = __LINE__ . <<'END_OF_SUB';
|
||||
sub do_raw_transaction {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Do a series of queries as a single transaction - note that this is only
|
||||
# supported under DBI >= 1.20; older versions of DBI result in the queries
|
||||
# being performed without a transaction.
|
||||
# This subroutine should be passed a list of queries; the queries will be run
|
||||
# in order. Each query may optionally be an array reference where the first
|
||||
# element is the query, and remaining elements are placeholders to use when
|
||||
# executing the query. Furthermore, you may pass a reference to the string
|
||||
# or array reference to specify a non-critical query.
|
||||
#
|
||||
# For example:
|
||||
# $self->do_raw_transaction(
|
||||
# "QUERY1",
|
||||
# \["QUERY2 ?", $value],
|
||||
# \"QUERY3",
|
||||
# ["QUERY4 ?, ?", $value1, $value2]
|
||||
# );
|
||||
#
|
||||
# This will attempt to run the 4 queries, and will abort if query 1 or 4 do not
|
||||
# succeed.
|
||||
#
|
||||
# Also note that this is ONLY meant to be used by individual drivers as it
|
||||
# assumes the queries passed in are ready to run without any rewriting. As
|
||||
# such, any use outside of individual drivers should be considered an error.
|
||||
#
|
||||
# Returns '1' on success, undef on failure of any query (excepting non-critical
|
||||
# queries, see above).
|
||||
#
|
||||
my ($self, @queries) = @_;
|
||||
|
||||
my $transaction = $DBI::VERSION >= 1.20;
|
||||
$self->{dbh}->begin_work if $transaction;
|
||||
|
||||
$self->debug("Begin query transaction") if $self->{_debug};
|
||||
$self->debug("Transaction not possible; DBI version < 1.20") if $self->{_debug} and not $transaction;
|
||||
|
||||
my $time;
|
||||
$time = Time::HiRes::time() if $self->{_debug} and exists $INC{"Time/HiRes.pm"};
|
||||
for (@queries) {
|
||||
my $critical = not(ref eq 'SCALAR' or ref eq 'REF');
|
||||
my $q = $critical ? $_ : $$_;
|
||||
my ($query, @ph) = ref $q ? @$q : $q;
|
||||
if ($self->{_debug}) {
|
||||
my $debugquery = GT::SQL::Driver::debug->replace_placeholders($query, @ph);
|
||||
$self->debug("Executing query $debugquery");
|
||||
}
|
||||
my $did = $self->{dbh}->do($query, undef, @ph);
|
||||
if (!$did and $critical) {
|
||||
$self->warn(CANTEXECUTE => $query => $DBI::errstr);
|
||||
$self->debug("Critical query failed, transaction aborted; performing transaction rollback")
|
||||
if $self->{_debug} and $transaction;
|
||||
$self->{dbh}->rollback if $transaction;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
$self->debug("Transaction complete; committing") if $self->{_debug};
|
||||
$self->{dbh}->commit if $transaction;
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Transaction execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub quote {
|
||||
# -----------------------------------------------------------
|
||||
# This subroutines quotes (or not) a value.
|
||||
#
|
||||
my $val = pop;
|
||||
return 'NULL' if not defined $val;
|
||||
return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE';
|
||||
(values %CONN)[0]->quote($val);
|
||||
}
|
||||
|
||||
$COMPILE{create_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Creates a table.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->connect or return;
|
||||
|
||||
my $table = $self->{name};
|
||||
|
||||
# Figure out the order of the create, and then build the create statement.
|
||||
my %pos = map { $_ => $self->{schema}->{cols}->{$_}->{pos} } keys %{$self->{schema}->{cols}};
|
||||
my (@field_defs, $ai_queries);
|
||||
for my $field (sort { $pos{$a} <=> $pos{$b} } keys %{$self->{schema}->{cols}}) {
|
||||
my %field_def = map { defined $self->{schema}->{cols}->{$field}->{$_} ? ($_ => $self->{schema}->{cols}->{$field}->{$_}) : () } keys %{$self->{schema}->{cols}->{$field}};
|
||||
my $is_ai = $self->{schema}->{ai} && $field eq $self->{schema}->{ai};
|
||||
delete $field_def{default} if $is_ai;
|
||||
my $def = $field . ' ' . ($self->column_sql(\%field_def) or return);
|
||||
if ($is_ai) {
|
||||
my $ai = $self->{hints}->{ai} || 'AUTO_INCREMENT';
|
||||
$ai = $ai->($table, $field) if ref $ai eq 'CODE';
|
||||
if (ref $ai eq 'ARRAY') {
|
||||
$ai_queries = $ai;
|
||||
}
|
||||
else {
|
||||
$def .= " $ai";
|
||||
}
|
||||
}
|
||||
push @field_defs, $def;
|
||||
}
|
||||
|
||||
# Add the primary key.
|
||||
if (@{$self->{schema}->{pk}}) {
|
||||
push @field_defs, "PRIMARY KEY (" . join(",", @{$self->{schema}->{pk}}) . ")";
|
||||
}
|
||||
|
||||
# Create the table
|
||||
my $create_query = "\n\tCREATE TABLE $table (\n\t\t";
|
||||
$create_query .= join ",\n\t\t", @field_defs;
|
||||
$create_query .= "\n\t)";
|
||||
|
||||
$self->do($create_query) or return;
|
||||
|
||||
# If the database needs separate queries to set up the auto-increment, run them
|
||||
if ($ai_queries) {
|
||||
for (@$ai_queries) {
|
||||
$self->do($_);
|
||||
}
|
||||
}
|
||||
|
||||
# Create the table's indexes
|
||||
for my $type (qw/index unique/) {
|
||||
my $create_index = "create_$type";
|
||||
while (my ($index_name, $index) = each %{$self->{schema}->{$type}}) {
|
||||
$self->$create_index($table => $index_name => @$index) if @$index;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{column_sql} = __LINE__ . <<'END_OF_SUB';
|
||||
sub column_sql {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Converts a column definition into an SQL string used in the create table
|
||||
# statement, and (for some drivers) when adding a new column to a table.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
|
||||
ref $opts eq 'HASH' or return $self->fatal(BADARGS => '$obj->column_sql (HASH_REF)');
|
||||
$opts->{type} or return $self->fatal(BADARGS => 'Column definition does not have a SQL type defined');
|
||||
|
||||
my $pkg = ref($self) . '::Types';
|
||||
my $type = uc $opts->{type};
|
||||
|
||||
if ($pkg->can($type)) {
|
||||
$self->debug("Using driver specific SQL for type $opts->{type}") if $self->{_debug} > 1;
|
||||
}
|
||||
elsif (GT::SQL::Driver::Types->can($type)) {
|
||||
$pkg = 'GT::SQL::Driver::Types';
|
||||
}
|
||||
else {
|
||||
return $self->fatal(BADTYPE => $opts->{type});
|
||||
}
|
||||
$pkg->$type({%$opts});
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{insert} = __LINE__ . <<'END_OF_SUB';
|
||||
sub insert {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This subroutine, using a couple driver hints, handles insertions for every
|
||||
# driver currently supported.
|
||||
#
|
||||
my ($self, $input) = @_;
|
||||
|
||||
my (@names, @values, @placeholders, @binds);
|
||||
my %got;
|
||||
my $ai = $self->{schema}->{ai};
|
||||
my $bind = $self->{hints}->{bind};
|
||||
my $cols = $self->{schema}->{cols};
|
||||
while (my ($col, $val) = each %$input) {
|
||||
++$got{$col};
|
||||
next if $ai and $col eq $ai and !$val;
|
||||
push @names, $col;
|
||||
my $def = $cols->{$col};
|
||||
if ($def->{time_check} and (not defined $val or $val eq '' or $val eq 'NOW()')) {
|
||||
push @values, $self->{hints}->{now} || 'NOW()';
|
||||
}
|
||||
elsif ($def->{type} =~ /DATE/ and (not defined $val or $val eq '')) {
|
||||
push @values, 'NULL';
|
||||
}
|
||||
elsif (ref $val eq 'SCALAR' or ref $val eq 'LVALUE') {
|
||||
push @values, $$val;
|
||||
}
|
||||
else {
|
||||
push @placeholders, $val;
|
||||
push @values, '?';
|
||||
if ($bind and defined $val) {
|
||||
for (my $i = 1; $i < @$bind; $i += 2) {
|
||||
if ($def->{type} =~ /$bind->[$i]/) {
|
||||
push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Update any timestamp columns to current time.
|
||||
for my $col (keys %$cols) {
|
||||
next unless not $got{$col} and $cols->{$col}->{time_check};
|
||||
push @names, $col;
|
||||
push @values, $self->{hints}->{now} || 'NOW()';
|
||||
$got{$col} = 1;
|
||||
}
|
||||
|
||||
# Add an auto increment field if required
|
||||
if ($ai and not $input->{$ai}) {
|
||||
my @ai_insert = $self->ai_insert($ai);
|
||||
if (@ai_insert) {
|
||||
push @names, $ai_insert[0];
|
||||
push @values, $ai_insert[1];
|
||||
}
|
||||
}
|
||||
|
||||
# Fill in any missing defaults
|
||||
for my $col (keys %$cols) {
|
||||
next if $ai and $col eq $ai
|
||||
or $got{$col}
|
||||
or not exists $cols->{$col}->{default};
|
||||
my $val = $cols->{$col}->{default};
|
||||
push @names, $col;
|
||||
push @values, '?';
|
||||
|
||||
# If the column is numeric, make sure a '' becomes a null, due to
|
||||
# problems where old libraries or the table editor could have set the
|
||||
# default to '':
|
||||
if (defined $val and $val eq '' and $cols->{$col}->{type} =~ /^(?:INTEGER|REAL|FLOAT|DOUBLE|DECIMAL)$|INT$/) {
|
||||
$val = undef;
|
||||
}
|
||||
push @placeholders, $val;
|
||||
$got{$col} = 1;
|
||||
if ($bind and defined $val) {
|
||||
my $def = $cols->{$col};
|
||||
for (my $i = 1; $i < @$bind; $i += 2) {
|
||||
if ($def->{type} =~ /$bind->[$i]/) {
|
||||
push @binds, [scalar @placeholders, $col, $bind->[$i+1]];
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Create the SQL and statement handle.
|
||||
my $query = "INSERT INTO $self->{name} (";
|
||||
$query .= join ',', @names;
|
||||
$query .= ") VALUES (";
|
||||
$query .= join ',', @values;
|
||||
$query .= ")";
|
||||
|
||||
$bind->[0]->{$query} = \@binds if $bind;
|
||||
|
||||
my $sth = $self->prepare($query) or return;
|
||||
$sth->execute(@placeholders) or return;
|
||||
$sth;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub ai_insert {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a column name and value to use for the AI column when inserting a
|
||||
# row. If this returns an empty list, no value will be inserted. This will
|
||||
# only be called when the table has an auto-increment column, so checking is
|
||||
# not necessary. The sole argument passed in is the name of the column.
|
||||
#
|
||||
my ($self, $ai) = @_;
|
||||
return $ai, 'NULL';
|
||||
}
|
||||
|
||||
$COMPILE{insert_multiple} = __LINE__ . <<'END_OF_SUB';
|
||||
sub insert_multiple {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Performs a multiple-insertion. By default, this is simply done as multiple
|
||||
# executes on a single insertion, and as a single transaction if under
|
||||
# DBI >= 1.20.
|
||||
#
|
||||
my ($self, $cols, $args) = @_;
|
||||
$self->{dbh}->begin_work if $DBI::VERSION >= 1.20;
|
||||
my $count;
|
||||
for my $val (@$args) {
|
||||
my %set;
|
||||
for my $i (0 .. $#$cols) {
|
||||
$set{$cols->[$i]} = $val->[$i];
|
||||
}
|
||||
++$count if $self->insert(\%set);
|
||||
}
|
||||
$self->{dbh}->commit if $DBI::VERSION >= 1.20;
|
||||
$count;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub update {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $set, $where) = @_;
|
||||
|
||||
my $c = $self->{schema}->{cols};
|
||||
my %set;
|
||||
|
||||
for my $cond (@{$set->{cond}}) {
|
||||
if (ref $cond eq 'ARRAY') {
|
||||
$set{$cond->[0]}++ if exists $c->{$cond->[0]} and $c->{$cond->[0]}->{time_check};
|
||||
}
|
||||
}
|
||||
for my $col (keys %$c) {
|
||||
next unless not $set{$col} and $c->{$col}->{time_check};
|
||||
$set->add($col, '=', \($self->{hints}->{now} || 'NOW()'));
|
||||
}
|
||||
|
||||
my ($sql_set, $set_vals, $set_cols) = $set->sql(1);
|
||||
my ($sql_where, $where_vals, $where_cols) = $where->sql(1);
|
||||
my $i = 1;
|
||||
|
||||
# Set up binds, if necessary
|
||||
my @binds;
|
||||
my $bind = $self->{hints}->{bind};
|
||||
if ($bind) {
|
||||
for my $col (@$set_cols) {
|
||||
next unless exists $c->{$col};
|
||||
for (my $j = 1; $j < @$bind; $j += 2) {
|
||||
if ($c->{$col}->{type} =~ /$bind->[$j]/) {
|
||||
push @binds, [scalar $i, $col, $bind->[$j+1]];
|
||||
last;
|
||||
}
|
||||
}
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
|
||||
my $query = "UPDATE $self->{name} SET $sql_set";
|
||||
$query .= " WHERE $sql_where" if $sql_where;
|
||||
|
||||
$bind->[0]->{$query} = \@binds if $bind;
|
||||
|
||||
my $sth = $self->prepare($query) or return;
|
||||
$sth->execute(@$set_vals, @$where_vals) or return;
|
||||
$sth;
|
||||
}
|
||||
|
||||
sub delete {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $where) = @_;
|
||||
my ($sql_where, $where_vals) = $where ? $where->sql(1) : ();
|
||||
my $sql = "DELETE FROM $self->{name}";
|
||||
$sql .= " WHERE $sql_where" if $sql_where;
|
||||
|
||||
my $sth = $self->prepare($sql) or return;
|
||||
$sth->execute(@$where_vals) or return;
|
||||
$sth;
|
||||
}
|
||||
|
||||
sub select {
|
||||
# -------------------------------------------------------------------
|
||||
my ($self, $field_arr, $where, $opts) = @_;
|
||||
|
||||
my ($fields, $opt_clause) = ('', '');
|
||||
if (ref $field_arr and @$field_arr) {
|
||||
$fields = join ",", @$field_arr;
|
||||
}
|
||||
else {
|
||||
$fields = '*';
|
||||
}
|
||||
my ($sql_where, $where_vals) = $where->sql(1);
|
||||
$sql_where and ($sql_where = " WHERE $sql_where");
|
||||
if ($opts) {
|
||||
for my $opt (@$opts) {
|
||||
next if (! defined $opt);
|
||||
$opt_clause .= " $opt";
|
||||
}
|
||||
}
|
||||
my $sql = "SELECT $fields FROM " . $self->{name};
|
||||
$sql .= $sql_where if $sql_where;
|
||||
$sql .= $opt_clause if $opt_clause;
|
||||
my $sth = $self->prepare($sql) or return;
|
||||
$sth->execute(@$where_vals) or return;
|
||||
$sth;
|
||||
}
|
||||
|
||||
$COMPILE{drop_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops the table passed in.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
$self->do("DROP TABLE $table");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{column_exists} = __LINE__ . <<'END_OF_SUB';
|
||||
sub column_exists {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns true or false value depending on whether the column exists in the
|
||||
# table. This defaults to a DESCRIBE of the table, then looks for the column
|
||||
# in the DESCRIBE results - but many databases probably have a much more
|
||||
# efficient alternative.
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->prepare("DESCRIBE $table") or return;
|
||||
$sth->execute or return;
|
||||
my $found;
|
||||
while (my ($col) = $sth->fetchrow) {
|
||||
$found = 1, last if $col eq $column;
|
||||
}
|
||||
$found;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{add_column} = __LINE__ . <<'END_OF_SUB';
|
||||
sub add_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a column to a table.
|
||||
#
|
||||
my ($self, $table, $column, $def) = @_;
|
||||
$self->do("ALTER TABLE $table ADD $column $def");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{drop_column} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a column from a table.
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
$self->do("ALTER TABLE $table DROP $column");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{alter_column} = __LINE__ . <<'END_OF_SUB';
|
||||
sub alter_column {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Changes a column. Takes table name, column name, definition for the new
|
||||
# column (string), and the old column definition (hash ref). The new column
|
||||
# definition should already be set in the table object
|
||||
# ($self->{table}->{schema}->{cols}->{$column_name}).
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
$self->do("ALTER TABLE $table CHANGE $column $column $new_def");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{create_index} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds an index - checks driver hints for whether or not to prefix the index
|
||||
# with the prefixed table name.
|
||||
#
|
||||
my ($self, $table, $index_name, @index_cols) = @_;
|
||||
$index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
|
||||
$self->do("CREATE INDEX $index_name ON $table (" . join(",", @index_cols) . ")");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{create_unique} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_unique {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds a unique index to a table, using the prefixed table name as a prefix.
|
||||
#
|
||||
my ($self, $table, $unique_name, @unique_cols) = @_;
|
||||
$unique_name = $table . $unique_name if $self->{hints}->{prefix_indexes};
|
||||
$self->do("CREATE UNIQUE INDEX $unique_name ON $table (" . join(",", @unique_cols) . ")");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{drop_index} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Drops an index.
|
||||
#
|
||||
my ($self, $table, $index_name) = @_;
|
||||
$index_name = $table . $index_name if $self->{hints}->{prefix_indexes};
|
||||
my $dropped = $self->do("DROP INDEX $index_name");
|
||||
$dropped ||= $self->do("DROP INDEX $self->{connect}->{PREFIX}$index_name") if $self->{hints}->{fix_index_dbprefix};
|
||||
$dropped;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{create_pk} = __LINE__ . <<'END_OF_SUB';
|
||||
sub create_pk {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a primary key to a table.
|
||||
#
|
||||
my ($self, $table, @cols) = @_;
|
||||
$self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(",", @cols) . ")");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{drop_pk} = __LINE__ . <<'END_OF_SUB';
|
||||
sub drop_pk {
|
||||
# -------------------------------------------------------------------
|
||||
# Drop a primary key.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
my $do;
|
||||
if ($self->{hints}->{drop_pk_constraint}) {
|
||||
# To drop a primary key in ODBC or Pg, you drop the primary key
|
||||
# constraint, which implicitly drops the index implicitly created by a
|
||||
# primary key.
|
||||
my $sth = $self->prepare("SHOW INDEX FROM $table") or return;
|
||||
$sth->execute or return;
|
||||
|
||||
my $pk_constraint;
|
||||
while (my $index = $sth->fetchrow_hashref) {
|
||||
if ($index->{index_primary}) {
|
||||
$pk_constraint = $index->{index_name};
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
$pk_constraint or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table");
|
||||
|
||||
$do = "ALTER TABLE $table DROP CONSTRAINT $pk_constraint";
|
||||
}
|
||||
else {
|
||||
$do = "ALTER TABLE $table DROP PRIMARY KEY";
|
||||
}
|
||||
$self->do($do);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
522
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MSSQL.pm
Normal file
522
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MSSQL.pm
Normal file
@ -0,0 +1,522 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::MSSQL
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: MSSQL.pm,v 2.7 2005/12/03 00:54:11 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: MSSQL driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::MSSQL;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE %BINDS/;
|
||||
use DBI qw/:sql_types/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub connect {
|
||||
# ------------------------------------------------------------------
|
||||
# Need to set some session preferences.
|
||||
#
|
||||
my $self = shift;
|
||||
my $dbh = $self->SUPER::connect(@_) or return;
|
||||
|
||||
# Set max read properties for DBI
|
||||
$dbh->{LongReadLen} = 1_048_576;
|
||||
|
||||
# Newer DBD::ODBC sets this to 0 which can cause cast errors
|
||||
$dbh->{odbc_default_bind_type} = SQL_VARCHAR;
|
||||
|
||||
$dbh->do("SET QUOTED_IDENTIFIER ON");
|
||||
$dbh->do("SET ANSI_NULLS ON");
|
||||
$dbh->do("SET ANSI_PADDING OFF");
|
||||
$dbh->do("SET ANSI_WARNINGS OFF");
|
||||
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
sub dsn {
|
||||
# -------------------------------------------------------------------
|
||||
# Override the default create dsn, with our own. Creates DSN like:
|
||||
# DBI:ODBC:DSN
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
|
||||
$self->{driver} = $connect->{driver} = 'ODBC';
|
||||
|
||||
return "DBI:$connect->{driver}:$connect->{database}";
|
||||
}
|
||||
|
||||
sub hints {
|
||||
fix_index_dbprefix => 1,
|
||||
case_map => 1,
|
||||
bind => [
|
||||
\%BINDS,
|
||||
'TEXT' => DBI::SQL_LONGVARCHAR,
|
||||
'DATE|TIME' => DBI::SQL_VARCHAR
|
||||
],
|
||||
now => 'GETDATE()',
|
||||
ai => 'IDENTITY(1,1)',
|
||||
drop_pk_constraint => 1
|
||||
}
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Track limits as ODBC has no built-in limit support; this driver hacks it in.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
|
||||
my ($limit, $offset);
|
||||
|
||||
# Look for either PG or MySQL limits
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
|
||||
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
|
||||
or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
|
||||
|
||||
if ($limit) {
|
||||
$self->{_limit} = 1;
|
||||
$self->{_lim_offset} = $offset;
|
||||
my $top = $limit + $offset;
|
||||
$query =~ s/(SELECT(?:\s+DISTINCT)?)/$1 TOP $top/i;
|
||||
if (!$offset) {
|
||||
delete @$self{qw/_limit _lim_offset/};
|
||||
}
|
||||
}
|
||||
return $query;
|
||||
}
|
||||
|
||||
sub _prepare_describe {
|
||||
# -----------------------------------------------------------------------------
|
||||
# For compatibility with old code, 'DESCRIBE TABLE' is mapped to something that
|
||||
# looks something like a MySQL 'DESCRIBE TABLE' result.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /DESCRIBE\s+(\w+)/i) {
|
||||
return <<QUERY;
|
||||
SELECT
|
||||
c.name AS "Field",
|
||||
CASE
|
||||
WHEN t.name LIKE '%int' THEN t.name + '(' + CAST(t.prec AS VARCHAR) + ')'
|
||||
WHEN t.name LIKE '%char' THEN t.name + '(' + CAST(c.length AS VARCHAR) + ')'
|
||||
WHEN t.name = 'decimal' THEN t.name + '(' + CAST(c.prec AS VARCHAR) + ',' + CAST(c.scale AS VARCHAR) + ')'
|
||||
WHEN t.name = 'float' THEN 'double'
|
||||
ELSE t.name
|
||||
END AS "Type",
|
||||
ISNULL(c.collation, 'binary') AS "Collation",
|
||||
CASE WHEN c.isnullable = 1 THEN 'YES' ELSE '' END AS "Null",
|
||||
(
|
||||
SELECT TOP 1
|
||||
CASE
|
||||
WHEN m.text LIKE '(''%' THEN SUBSTRING(m.text, 3, LEN(m.text) - (CASE WHEN m.text LIKE '%'')' THEN 4 ELSE 2 END))
|
||||
WHEN m.text LIKE '(%' THEN SUBSTRING(m.text, 2, LEN(m.text) - (CASE WHEN m.text LIKE '%)' THEN 2 ELSE 1 END))
|
||||
ELSE m.text
|
||||
END
|
||||
FROM syscomments m, sysobjects d
|
||||
WHERE m.id = d.id AND d.xtype = 'D' AND d.info = c.colid AND d.parent_obj = o.id
|
||||
) AS "Default",
|
||||
|
||||
CASE WHEN c.status & 0x80 = 0x80 THEN 'auto_increment' ELSE '' END AS "Extra"
|
||||
FROM
|
||||
syscolumns c, systypes t, sysobjects o
|
||||
WHERE
|
||||
c.id = o.id AND
|
||||
o.name = '$1' AND
|
||||
o.type = 'U' AND
|
||||
c.xtype = t.xtype
|
||||
ORDER BY
|
||||
c.colid
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported DESCRIBE query");
|
||||
}
|
||||
# The following could be used above for "Key" - but it really isn't that useful
|
||||
# considering there's a working SHOW INDEX:
|
||||
# (
|
||||
# SELECT
|
||||
# CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END
|
||||
# FROM sysindexes i, sysindexkeys k
|
||||
# WHERE
|
||||
# i.indid = 1 AND i.id = o.id AND k.id = i.id AND k.indid = i.indid AND
|
||||
# k.colid = c.colid
|
||||
# ) AS "Key",
|
||||
}
|
||||
|
||||
sub column_exists {
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->{dbh}->prepare(<<EXISTS);
|
||||
SELECT
|
||||
COUNT(*)
|
||||
FROM syscolumns c, sysobjects o
|
||||
WHERE
|
||||
c.id = o.id AND
|
||||
o.type = 'U' AND
|
||||
o.name = ? AND
|
||||
c.name = ?
|
||||
EXISTS
|
||||
$sth->execute($table, $column);
|
||||
|
||||
return scalar $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub _prepare_show_tables {
|
||||
# -----------------------------------------------------------------------------
|
||||
# MS SQL's version of MySQL's 'SHOW TABLES'; there is also 'sp_tables', but
|
||||
# that returns more information (and more tables - it includes system tables)
|
||||
# than we want.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{do} = 'SELECT';
|
||||
"SELECT name as table_name FROM sysobjects WHERE xtype = 'U'";
|
||||
}
|
||||
|
||||
sub _prepare_show_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# See the 'Driver-specific notes' comment in GT::SQL::Driver
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
|
||||
$self->{do} = 'SELECT';
|
||||
return <<QUERY;
|
||||
SELECT
|
||||
sysindexes.name AS index_name,
|
||||
syscolumns.name AS index_column,
|
||||
INDEXPROPERTY(sysindexes.id, sysindexes.name, 'IsUnique') AS index_unique,
|
||||
CASE
|
||||
WHEN sysindexes.indid = 1 AND (
|
||||
SELECT COUNT(*) FROM sysconstraints
|
||||
WHERE sysconstraints.id = sysobjects.id AND sysconstraints.status & 7 = 1
|
||||
) > 0 THEN 1
|
||||
ELSE 0
|
||||
END AS index_primary
|
||||
FROM
|
||||
sysindexes, sysobjects, sysindexkeys, syscolumns
|
||||
WHERE
|
||||
sysindexes.indid >= 1 AND sysindexes.indid < 255 AND
|
||||
sysindexes.id = sysobjects.id AND sysindexes.id = sysindexkeys.id AND sysindexes.id = syscolumns.id AND
|
||||
sysindexkeys.colid = syscolumns.colid AND
|
||||
sysindexes.status = 0 AND
|
||||
sysindexes.indid = sysindexkeys.indid AND
|
||||
sysobjects.xtype = 'U' AND sysobjects.name = '$1'
|
||||
ORDER BY
|
||||
sysindexkeys.indid, sysindexkeys.keyno
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query");
|
||||
}
|
||||
}
|
||||
|
||||
# MS SQL shouldn't have the AI column in the insert list
|
||||
sub ai_insert { () }
|
||||
|
||||
# Returns a list of default constraints given a table and column
|
||||
sub _defaults {
|
||||
my ($self, $table_name, $column_name) = @_;
|
||||
my $query = <<" QUERY";
|
||||
SELECT o.name
|
||||
FROM sysconstraints d, sysobjects t, syscolumns c, sysobjects o
|
||||
WHERE d.status & 5 = 5 -- status with '5' bit set indicates a default constraint
|
||||
AND d.id = t.id -- constraint table to table
|
||||
AND c.id = t.id -- column's table to table
|
||||
AND d.colid = c.colid -- constraint column to column
|
||||
AND d.constid = o.id -- constraint id to object
|
||||
AND t.name = '$table_name' -- the table we're looking for
|
||||
AND c.name = '$column_name' -- the column we're looking for
|
||||
QUERY
|
||||
my $sth = $self->{dbh}->prepare($query)
|
||||
or return $self->warn(CANTPREPARE => $query, $DBI::errstr);
|
||||
$sth->execute()
|
||||
or return $self->warn(CANTEXECUTE => $query, $DBI::errstr);
|
||||
|
||||
my @defaults;
|
||||
while (my $default = $sth->fetchrow) {
|
||||
push @defaults, $default;
|
||||
}
|
||||
return @defaults;
|
||||
}
|
||||
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Generates the SQL to drop a column.
|
||||
#
|
||||
my ($self, $table, $column, $old_col) = @_;
|
||||
|
||||
my @queries;
|
||||
|
||||
# Delete any indexes on the column, as MSSQL does not do this automatically
|
||||
my $sth = $self->prepare("SHOW INDEX FROM $table");
|
||||
$sth->execute;
|
||||
my %drop_index;
|
||||
while (my $index = $sth->fetchrow_hashref) {
|
||||
if ($index->{index_column} eq $column) {
|
||||
$drop_index{$index->{index_name}}++;
|
||||
}
|
||||
}
|
||||
push @queries, map "DROP INDEX $table.$_", keys %drop_index;
|
||||
|
||||
for ($self->_defaults($table, $column)) {
|
||||
# Drop any default constraints
|
||||
push @queries, "ALTER TABLE $table DROP CONSTRAINT $_";
|
||||
}
|
||||
|
||||
push @queries, "ALTER TABLE $table DROP COLUMN $column";
|
||||
|
||||
$self->do_raw_transaction(@queries);
|
||||
}
|
||||
|
||||
sub alter_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Changes a column in a table.
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
|
||||
# make a copy so as not to clobber the original reference
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
|
||||
if ($col{type} =~ /TEXT$/i) {
|
||||
# You can't alter a TEXT column in MSSQL, so we have to create an
|
||||
# entirely new column, copy the data, drop the old one, then rename the
|
||||
# new one using sp_rename.
|
||||
my $tmpcol = "tempcol__" . time . "__" . ('a' .. 'z', 'A' .. 'Z')[rand 52];
|
||||
|
||||
# We don't have to worry about dropping indexes because TEXT's can't be indexed.
|
||||
my @constraints = $self->_defaults($table, $column);
|
||||
|
||||
# Added columns must have a default, which unfortunately cannot be a column, so
|
||||
# if the definition doesn't already have a default, add a fake one. We use ''
|
||||
# for the default - though not allowed by GT::SQL, it _is_ allowed by MSSQL.
|
||||
my $no_default;
|
||||
if (not defined $col{default}) {
|
||||
$col{default} = '';
|
||||
$new_def = $self->column_sql(\%col);
|
||||
$no_default = 1;
|
||||
}
|
||||
|
||||
# This cannot be done in one single transaction as the columns won't
|
||||
# completely exist yet, as far as MSSQL is concerned.
|
||||
$self->do("ALTER TABLE $table ADD $tmpcol $new_def") or return;
|
||||
|
||||
push @constraints, $self->_defaults($table, $tmpcol) if $no_default;
|
||||
|
||||
my @q = "UPDATE $table SET $tmpcol = $column";
|
||||
push @q, map "ALTER TABLE $table DROP CONSTRAINT $_", @constraints;
|
||||
push @q, "ALTER TABLE $table DROP COLUMN $column";
|
||||
|
||||
$self->do_raw_transaction(@q) or return;
|
||||
|
||||
$self->do("sp_rename '$table.$tmpcol', '$column'") or return;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# An ALTER COLUMN in MS SQL cannot contain a default, so if a default is
|
||||
# specified that isn't the same as the old one, we drop the default
|
||||
# constraint and add a new one.
|
||||
my $new_default = delete $col{default};
|
||||
my $old_default = $old_col->{default};
|
||||
|
||||
my $default_changed = (
|
||||
defined $new_default and defined $old_default and $new_default ne $old_default
|
||||
or
|
||||
defined $new_default ne defined $old_default
|
||||
);
|
||||
|
||||
my @queries;
|
||||
|
||||
if ($default_changed) {
|
||||
if (defined $old_default) {
|
||||
push @queries, map "ALTER TABLE $table DROP CONSTRAINT $_", $self->_defaults($table, $column);
|
||||
}
|
||||
if (defined $new_default) {
|
||||
push @queries, "ALTER TABLE $table ADD CONSTRAINT default_${table}_$column DEFAULT " . $self->quote($new_default) . " FOR $column";
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $new_default) {
|
||||
# Rewrite the column def without the DEFAULT (an ALTER COLUMN cannot contain a default in MSSQL)
|
||||
$new_def = $self->column_sql(\%col);
|
||||
}
|
||||
|
||||
push @queries, "ALTER TABLE $table ALTER COLUMN $column $new_def";
|
||||
|
||||
return @queries > 1
|
||||
? $self->do_raw_transaction(@queries)
|
||||
: $self->do($queries[0]);
|
||||
}
|
||||
|
||||
sub drop_index {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops an index. Versions of this module prior to 2.0 were quite broken -
|
||||
# first, the index naming was (database prefix)(index name) in some places, and
|
||||
# (prefixed table name)(index name) in others. Furthermore, no prefixing of
|
||||
# indexes is needed at all as, like MySQL, indexes are per-table. As such,
|
||||
# this driver now looks for all three types of index when attempting to remove
|
||||
# existing indexes.
|
||||
#
|
||||
my ($self, $table, $index_name) = @_;
|
||||
|
||||
return $self->do("DROP INDEX $table.$index_name")
|
||||
or $self->do("DROP INDEX $table.$table$index_name")
|
||||
or $self->do("DROP INDEX $table.$self->{connect}->{PREFIX}$index_name");
|
||||
}
|
||||
|
||||
sub extract_index_name {
|
||||
# -----------------------------------------------------------------------------
|
||||
my ($self, $table, $index) = @_;
|
||||
$index =~ s/^\Q$table\E(?=.)//i # broken (tablename)(index name) format
|
||||
or $index =~ s/^\Q$self->{connect}->{PREFIX}\E(?=.)//i; # broken (prefix)(index name) format;
|
||||
$index;
|
||||
}
|
||||
|
||||
|
||||
package GT::SQL::Driver::MSSQL::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
|
||||
use GT::SQL::Driver::sth;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Retrieves the current sequence.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{_insert_id} if $self->{_insert_id};
|
||||
|
||||
my $sth = $self->{dbh}->prepare('SELECT @@IDENTITY') or return $self->fatal(CANTPREPARE => 'SELECT @@IDENTITY', $DBI::errstr);
|
||||
$sth->execute or return $self->fatal(CANTEXECUTE => 'SELECT @@IDENTITY', $DBI::errstr);
|
||||
$self->{_insert_id} = $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub execute {
|
||||
# -------------------------------------------------------------------
|
||||
# Fetch off only rows we are interested in.
|
||||
#
|
||||
my $self = shift;
|
||||
if ($self->{_need_preparing}) {
|
||||
$self->{sth} = $self->{dbh}->prepare($self->{query}) or return $self->warn(CANTPREPARE => $self->{query}, $DBI::errstr);
|
||||
}
|
||||
if (my $binds = $GT::SQL::Driver::MSSQL::BINDS{$self->{query}}) {
|
||||
for my $bind (@$binds) {
|
||||
my ($index, $col, $type) = @$bind;
|
||||
$self->{sth}->bind_param($index, $_[$index-1], $type);
|
||||
}
|
||||
}
|
||||
else {
|
||||
# We need to look for any values longer than 8000 characters and bind_param them
|
||||
# to SQL_LONGVARCHAR's to avoid an implicit rebinding that results in a
|
||||
# "Can't rebind placeholder x" error. Actually, we look for 4000 because that's
|
||||
# the worst-case scenario for escaping being able to increase to 8000 characters.
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if (defined $_[$i] and length $_[$i] > 4000) {
|
||||
$self->{sth}->bind_param($i+1, $_[$i], DBI::SQL_LONGVARCHAR);
|
||||
}
|
||||
}
|
||||
}
|
||||
my $time;
|
||||
if ($self->{_debug}) {
|
||||
$self->last_query($self->{query}, @_);
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 1) {
|
||||
$stack = GT::Base->stack_trace(1,1);
|
||||
$stack =~ s/<br>/\n /g;
|
||||
$stack =~ s/ / /g;
|
||||
$stack = "\n $stack\n"
|
||||
}
|
||||
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
|
||||
$self->debug("Executing query: $query$stack");
|
||||
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
|
||||
}
|
||||
|
||||
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
$self->{_names} = $self->{_results} = $self->{_insert_id} = undef;
|
||||
|
||||
# Attempting to access ->{NAME} is not allowed for queries that don't actually
|
||||
# returning anything (such as 'ALTER TABLE foo ADD COLUMN a INT'); as such, try
|
||||
# to avoid them here. The eval is there just in case a query runs that isn't
|
||||
# caught.
|
||||
unless ($self->{do} =~ /^(?:ALTER|CREATE|INSERT|UPDATE|DROP|DELETE|SP_RENAME)$/) {
|
||||
eval {
|
||||
$self->{_names} = $self->{sth}->{NAME};
|
||||
};
|
||||
}
|
||||
|
||||
# Limit the results if needed.
|
||||
if ($self->{do} eq 'SELECT' or $self->{do} eq 'DESCRIBE') {
|
||||
my $none;
|
||||
if ($self->{_limit}) {
|
||||
my $begin = $self->{_lim_offset} || 0;
|
||||
for (1 .. $begin) {
|
||||
# Discard any leading rows that we don't care about
|
||||
$self->{sth}->fetchrow_arrayref or $none = 1, last;
|
||||
}
|
||||
}
|
||||
$self->{_results} = $none ? [] : $self->{sth}->fetchall_arrayref;
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
elsif ($self->{query} =~ /^\s*sp_/) {
|
||||
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
else {
|
||||
$self->{rows} = $self->{sth}->rows;
|
||||
}
|
||||
$self->{sth}->finish;
|
||||
$self->{_need_preparing} = 1;
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
return $rc;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
# DATA TYPE MAPPINGS
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
package GT::SQL::Driver::MSSQL::Types;
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use Carp qw/croak/;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
# MSSQL has a TINYINT type, however it is always unsigned, so only use it if
|
||||
# the column is _meant_ to be unsigned - otherwise use SMALLINT, which is
|
||||
# always signed.
|
||||
sub TINYINT {
|
||||
my ($class, $args) = @_;
|
||||
my $type = $args->{unsigned} ? 'TINYINT' : 'SMALLINT';
|
||||
$class->base($args, $type);
|
||||
}
|
||||
|
||||
# Though MSSQL supports a CHAR type, it can't be used because it doesn't trim
|
||||
# trailing spaces, and that would most likely break things designed to work
|
||||
# with the way 'CHAR's currently work.
|
||||
|
||||
sub DATE { $_[0]->base($_[1], 'DATETIME') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'DATETIME') }
|
||||
sub TIME { croak "MSSQL does not support 'TIME' columns" }
|
||||
sub YEAR { $_[0]->base($_[1], 'DATETIME') }
|
||||
|
||||
# MSSQL doesn't support BLOB's, but has binary 'IMAGE' and 'VARBINARY' types -
|
||||
# the one (rather large) caveat to these being that they require escaping and
|
||||
# unescaping of input and output.
|
||||
|
||||
1;
|
||||
226
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MYSQL.pm
Normal file
226
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/MYSQL.pm
Normal file
@ -0,0 +1,226 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::MYSQL
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: MYSQL.pm,v 2.1 2005/04/14 00:56:30 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: MySQL driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::MYSQL;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver;
|
||||
use DBD::mysql 1.19_03;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub dsn {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Creates the data source name used by DBI to connect to the database.
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
my $dsn;
|
||||
|
||||
$connect->{driver} ||= 'mysql';
|
||||
$connect->{host} ||= 'localhost';
|
||||
$self->{driver} = $connect->{driver};
|
||||
|
||||
$dsn = "DBI:$connect->{driver}:";
|
||||
$dsn .= join ';', map { $connect->{$_} ? "$_=$connect->{$_}" : () } qw/database host port/;
|
||||
return $dsn;
|
||||
}
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Prepares a query; rewrites PG-style LIMIT x OFFSET y into MySQL's confusing
|
||||
# LIMIT y, n
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/LIMIT $2, $1/i
|
||||
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/LIMIT $1, $2/i;
|
||||
$query;
|
||||
}
|
||||
|
||||
sub insert_multiple {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Performs a multiple-insertion. We have to watch the maximum query length,
|
||||
# performing multiple queries if necessary.
|
||||
#
|
||||
my ($self, $cols, $args) = @_;
|
||||
|
||||
my $has_ai;
|
||||
$has_ai = grep $_ eq $self->{schema}->{ai}, @$cols if $self->{schema}->{ai};
|
||||
|
||||
my $names = join ",", @$cols;
|
||||
$names .= ",$self->{schema}->{ai}" if $self->{schema}->{ai} and not $has_ai;
|
||||
|
||||
my $ret;
|
||||
my $values = '';
|
||||
for (@$args) {
|
||||
my $new_val;
|
||||
$new_val = "(" . join(",", map GT::SQL::Driver::quote($_), @$_);
|
||||
$new_val .= ",NULL" if $self->{schema}->{ai} and not $has_ai;
|
||||
$new_val .= ")";
|
||||
|
||||
if ($values and length($values) + length($new_val) > 1_000_000) {
|
||||
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
|
||||
$values = '';
|
||||
}
|
||||
$values .= "," if $values;
|
||||
$values .= $new_val;
|
||||
}
|
||||
if ($values) {
|
||||
++$ret if $self->do("INSERT INTO $self->{name} ($names) VALUES $values");
|
||||
}
|
||||
$ret;
|
||||
}
|
||||
|
||||
# If making a nullable TEXT column not null, make sure we update existing NULL
|
||||
# columns to get the default value.
|
||||
sub alter_column {
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
if ($col{type} =~ /TEXT$/i
|
||||
and $col{not_null}
|
||||
and not $old_col->{not_null}
|
||||
and defined $col{default}
|
||||
and not defined $old_col->{default}) {
|
||||
$self->{dbh}->do("UPDATE $table SET $column = ? WHERE $column IS NULL", undef, $col{default});
|
||||
}
|
||||
return $self->SUPER::alter_column(@_[1 .. $#_])
|
||||
}
|
||||
|
||||
sub create_index {
|
||||
my ($self, $table, $index_name, @index_cols) = @_;
|
||||
$self->do("ALTER TABLE $table ADD INDEX $index_name (" . join(',', @index_cols) . ")");
|
||||
}
|
||||
|
||||
sub create_unique {
|
||||
my ($self, $table, $index_name, @index_cols) = @_;
|
||||
$self->do("ALTER TABLE $table ADD UNIQUE $index_name (" . join(',', @index_cols) . ")");
|
||||
}
|
||||
|
||||
sub drop_index {
|
||||
my ($self, $table, $index_name) = @_;
|
||||
$self->do("ALTER TABLE $table DROP INDEX $index_name");
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::MYSQL::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver::sth;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Catch mysql's auto increment field.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{sth}->{mysql_insertid} || $self->{sth}->{insertid};
|
||||
}
|
||||
|
||||
sub rows { shift->{sth}->rows }
|
||||
|
||||
sub _execute_show_index {
|
||||
my $self = shift;
|
||||
$self->{sth}->execute or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
|
||||
my @results;
|
||||
|
||||
# Mysql columns are: Table Non_unique Key_name Seq_in_index Column_name Collation Cardinality Sub_part Packed Null Index_type Comment
|
||||
my @names = @{$self->row_names};
|
||||
# We need to add index_name, index_column, index_unique, index_primary (see GT::SQL::Driver)
|
||||
push @names, qw/index_name index_column index_unique index_primary/ unless $self->{_names};
|
||||
while (my $row = $self->{sth}->fetchrow_arrayref) {
|
||||
my %h = map { $names[$_] => $row->[$_] } 0 .. $#$row;
|
||||
push @results, [@$row, $h{Key_name}, $h{Column_name}, $h{Non_unique} ? 0 : 1, $h{Key_name} eq 'PRIMARY' ? 1 : 0];
|
||||
}
|
||||
|
||||
$self->{rows} = @results;
|
||||
$self->{_names} = \@names;
|
||||
$self->{_results} = \@results;
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::MYSQL::Types;
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
# Integers. MySQL supports non-standard unsigned and zerofill properties;
|
||||
# unsigned, though unportable, is supported here, however zerofill - whose
|
||||
# usefulness is dubious at best - is not.
|
||||
sub TINYINT { $_[0]->base($_[1], 'TINYINT', ['unsigned']) }
|
||||
sub SMALLINT { $_[0]->base($_[1], 'SMALLINT', ['unsigned']) }
|
||||
sub MEDIUMINT { $_[0]->base($_[1], 'MEDIUMINT', ['unsigned']) }
|
||||
sub INT { $_[0]->base($_[1], 'INT', ['unsigned']) }
|
||||
sub BIGINT { $_[0]->base($_[1], 'BIGINT', ['unsigned']) }
|
||||
|
||||
# Floats - MySQL's 'REAL' is really a 64-bit floating point number, while for
|
||||
# everything else 'REAL' is a 32-bit floating point number, so we override the
|
||||
# defaults here to FLOAT.
|
||||
sub FLOAT { $_[0]->base($_[1], 'FLOAT') }
|
||||
sub REAL { $_[0]->base($_[1], 'FLOAT') }
|
||||
|
||||
sub CHAR {
|
||||
my ($class, $args, $out) = @_;
|
||||
$args->{size} = 255 unless $args->{size} and $args->{size} <= 255;
|
||||
|
||||
$out ||= 'CHAR';
|
||||
$out .= "($args->{size})";
|
||||
$out .= ' BINARY' if $args->{binary}; # MySQL-only
|
||||
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub TEXT {
|
||||
my ($class, $args) = @_;
|
||||
my $type = 'LONGTEXT';
|
||||
delete $args->{default}; # MySQL is the only driver that doesn't support defaults on TEXT's
|
||||
if ($args->{size}) {
|
||||
if ($args->{size} < 256) {
|
||||
$type = 'TINYTEXT';
|
||||
}
|
||||
elsif ($args->{size} < 65536) {
|
||||
$type = 'TEXT';
|
||||
}
|
||||
elsif ($args->{size} < 16777216) {
|
||||
$type = 'MEDIUMTEXT';
|
||||
}
|
||||
}
|
||||
|
||||
$class->base($args, $type);
|
||||
}
|
||||
|
||||
# MySQL supports ENUM; the generic ENUM is mapped to a VARCHAR
|
||||
sub ENUM {
|
||||
my ($class, $args) = @_;
|
||||
@{$args->{'values'}} or return;
|
||||
my $out = 'ENUM(' . join(",", map GT::SQL::Driver->quote($_), @{$args->{values}}) . ')';
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
$out;
|
||||
}
|
||||
|
||||
sub BLOB {
|
||||
my ($class, $attrib, $blob) = @_;
|
||||
delete $attrib->{default};
|
||||
$class->base($attrib, $blob || 'BLOB');
|
||||
}
|
||||
|
||||
1;
|
||||
590
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/ORACLE.pm
Normal file
590
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/ORACLE.pm
Normal file
@ -0,0 +1,590 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::ORACLE
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: ORACLE.pm,v 2.2 2008/03/13 23:12:16 bao Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: Oracle 8+ driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::ORACLE;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $ERRORS %BINDS/;
|
||||
|
||||
use DBD::Oracle qw/:ora_types/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub connect {
|
||||
# ------------------------------------------------------------------
|
||||
# Need to set some session preferences.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# ORACLE_HOME must be set for the DBD::Oracle driver to function properly.
|
||||
return $self->warn('NOORACLEHOME') unless exists $ENV{ORACLE_HOME};
|
||||
|
||||
my $dbh = $self->SUPER::connect(@_) or return;
|
||||
|
||||
# Set the date format to same format as other drivers use.
|
||||
$dbh->do("ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS'")
|
||||
or return $self->fatal(NONLSDATE => $DBI::errstr);
|
||||
|
||||
# Set max read properties for DBI.
|
||||
$dbh->{LongReadLen} = 1_048_576;
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
sub dsn {
|
||||
# -------------------------------------------------------------------
|
||||
# Oracle DSN looks like:
|
||||
# DBI:Oracle:host=HOST;port=POST;sid=SID
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
|
||||
$connect->{driver} ||= 'Oracle';
|
||||
$connect->{host} ||= 'localhost';
|
||||
$self->{driver} = $connect->{driver};
|
||||
|
||||
my $dsn = "DBI:$connect->{driver}:";
|
||||
$dsn .= "host=$connect->{host}";
|
||||
$dsn .= ";port=$connect->{port}" if $connect->{port};
|
||||
$dsn .= ";sid=$connect->{database}";
|
||||
|
||||
return $dsn;
|
||||
}
|
||||
|
||||
sub hints {
|
||||
case_map => 1,
|
||||
prefix_indexes => 1,
|
||||
bind => [
|
||||
\%BINDS,
|
||||
'TEXT' => ORA_CLOB,
|
||||
'BLOB' => ORA_BLOB
|
||||
],
|
||||
now => 'SYSDATE',
|
||||
ai => sub {
|
||||
my ($table, $column) = @_;
|
||||
my $seq = "${table}_seq";
|
||||
my @q;
|
||||
push @q, \"DROP SEQUENCE $seq";
|
||||
push @q, "CREATE SEQUENCE $seq INCREMENT BY 1 START WITH 1 NOCYCLE";
|
||||
\@q;
|
||||
}
|
||||
}
|
||||
|
||||
sub prepare {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Clear our limit counters. Oracle does not have built-in limit support, so it
|
||||
# is handled here by fetching all the results that were asked for into _results
|
||||
# and our own fetchrow methods work off that.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
|
||||
# Oracle uses "SUBSTR" instead of "SUBSTRING"
|
||||
$query =~ s/\bSUBSTRING\(/SUBSTR(/gi;
|
||||
|
||||
$self->SUPER::prepare($query);
|
||||
}
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Need to store what the requested result set; no built in LIMIT support like
|
||||
# mysql.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
|
||||
my ($limit, $offset);
|
||||
|
||||
# Handle either PG or MySQL limits
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s+OFFSET\s+(\d+)/($limit, $offset) = ($1, $2); ''/ie
|
||||
or $query =~ s/\bOFFSET\s+(\d+)\s+LIMIT\s+(\d+)/($limit, $offset) = ($2, $1); ''/ie
|
||||
or $query =~ s/\bLIMIT\s+(\d+)\s*(?:,\s*(\d+))?/($limit, $offset) = ($2 || $1, $2 ? $1 : 0); ''/ie;
|
||||
if ($limit) {
|
||||
$self->{_limit} = 1;
|
||||
# using ROWNUM to limit rows instead.
|
||||
my $max_rows = $offset + $limit;
|
||||
$query = "SELECT * from (SELECT a.*, rownum rnum from ($query) a WHERE rownum <= $max_rows) where rnum > $offset";
|
||||
}
|
||||
|
||||
# LEFT OUTER JOIN is not supported, instead:
|
||||
# ... FROM Table1, Table2 WHERE col1 = col2(+) ...
|
||||
$query =~ s{FROM\s+(\w+)\s+LEFT OUTER JOIN\s+(\w+)\s+ON\s+([\w.]+)\s*=\s*([\w.]+)(\s+WHERE\s+)?}{
|
||||
my ($table1, $table2, $col1, $col2, $where) = ($1, $2, $3, $4, $5);
|
||||
my $from_where = "FROM $table1, $table2 WHERE ";
|
||||
$from_where .= index($col1, "$table1.") == 0
|
||||
? "$col1 = $col2(+)"
|
||||
: "$col2 = $col1(+)";
|
||||
$from_where .= " AND " if $where;
|
||||
$from_where;
|
||||
}ie;
|
||||
|
||||
$query;
|
||||
}
|
||||
|
||||
sub _prepare_describe {
|
||||
# ------------------------------------------------------------------
|
||||
# Oracle supports USER_TAB_COLUMNS to get information
|
||||
# about a table.
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /DESCRIBE\s+(\w+)/i) {
|
||||
return <<" QUERY";
|
||||
SELECT COLUMN_NAME, DATA_TYPE, DATA_LENGTH, DATA_PRECISION, DATA_SCALE, NULLABLE, DATA_DEFAULT
|
||||
FROM USER_TAB_COLUMNS
|
||||
WHERE TABLE_NAME = '\U$1\E'
|
||||
ORDER BY COLUMN_ID
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Cannot get properties from db_tab_columns");
|
||||
}
|
||||
}
|
||||
|
||||
sub column_exists {
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->{dbh}->prepare(<<EXISTS);
|
||||
SELECT COUNT(*)
|
||||
FROM USER_TAB_COLUMNS
|
||||
WHERE TABLE_NAME = ? AND COLUMN_NAME = ?
|
||||
EXISTS
|
||||
$sth->execute(uc $table, uc $column);
|
||||
|
||||
return scalar $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub _prepare_show_tables {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Oracle's equivelant to SHOW TABLES
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{do} = 'SELECT';
|
||||
'SELECT table_name FROM USER_TABLES ORDER BY table_name';
|
||||
}
|
||||
|
||||
sub _prepare_show_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Get an index list; see 'Driver-specific notes' comment in GT::SQL::Driver
|
||||
my ($self, $query) = @_;
|
||||
if ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
|
||||
# The below isn't quite perfect - Oracle 8 doesn't support CASE (9 does), so
|
||||
# the 'index_unique' still has to be mapped to a 1/0 value in execute(). Also
|
||||
# worth noting is that primary keys in Oracle don't always get their own index
|
||||
# - in particular, when adding a primary key to a table using a column that is
|
||||
# already indexed, the primary key will simply use the existing index instead
|
||||
# of creating a new one.
|
||||
return <<QUERY;
|
||||
SELECT
|
||||
ic.index_name AS "index_name",
|
||||
ic.column_name AS "index_column",
|
||||
(
|
||||
SELECT COUNT(*) FROM user_constraints c, user_cons_columns cc
|
||||
WHERE c.index_name = i.index_name AND c.constraint_name = cc.constraint_name
|
||||
AND c.constraint_type = 'P' AND cc.column_name = ic.column_name
|
||||
) "index_primary",
|
||||
uniqueness AS "index_unique"
|
||||
FROM
|
||||
user_ind_columns ic,
|
||||
user_indexes i
|
||||
WHERE
|
||||
ic.index_name = i.index_name AND
|
||||
LOWER(ic.table_name) = '\L$1\E'
|
||||
ORDER BY
|
||||
ic.index_name,
|
||||
ic.column_position
|
||||
QUERY
|
||||
}
|
||||
else {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
|
||||
}
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a table, including a sequence if necessary
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $seq = uc "${table}_seq";
|
||||
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '$seq'");
|
||||
$sth->execute();
|
||||
if (my $seq_name = $sth->fetchrow) {
|
||||
my $sth = $self->{dbh}->prepare("DROP SEQUENCE $seq");
|
||||
$sth->execute or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq", $GT::SQL::error);
|
||||
}
|
||||
return $self->SUPER::drop_table($table);
|
||||
}
|
||||
|
||||
sub ai_insert {
|
||||
my ($self, $ai) = @_;
|
||||
return $ai, "$self->{name}_seq.NEXTVAL";
|
||||
}
|
||||
|
||||
sub alter_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Changes a column. Takes table name, column name, and new column definition.
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
|
||||
# make a copy so the original reference doesn't get clobbered
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
|
||||
# If the default value was removed, then make sure that the default constraint
|
||||
# from the previous instance is deactivated.
|
||||
if (not exists $col{default} and defined $old_col->{default} and length $old_col->{default}) {
|
||||
$col{default} = \'NULL';
|
||||
}
|
||||
|
||||
# Oracle doesn't like being told to make an already NOT NULL column NOT NULL:
|
||||
if ($col{not_null} and $old_col->{not_null}) {
|
||||
delete $col{not_null};
|
||||
}
|
||||
|
||||
$new_def = $self->column_sql(\%col);
|
||||
|
||||
# But it needs an explicit NULL to drop the field's NOT NULL
|
||||
if (not $col{not_null} and $old_col->{not_null}) {
|
||||
$new_def .= ' NULL';
|
||||
}
|
||||
|
||||
# Oracle doesn't need the data type, and won't accept it on CLOB/BLOB columns
|
||||
$new_def =~ s/^[BC]LOB ?//;
|
||||
$new_def or return 1; # If the def is empty now, there really isn't anything to be done.
|
||||
|
||||
$self->do("ALTER TABLE $table MODIFY $column $new_def");
|
||||
}
|
||||
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a column
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
$self->do("ALTER TABLE $table DROP COLUMN $column");
|
||||
}
|
||||
|
||||
sub create_pk {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a primary key to a table.
|
||||
#
|
||||
my ($self, $table, @cols) = @_;
|
||||
$self->create_index($table, "${table}_pkey", @cols);
|
||||
$self->do("ALTER TABLE $table ADD CONSTRAINT ${table}_pkey PRIMARY KEY (" . join(",", @cols) . ")");
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::ORACLE::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $DEBUG/;
|
||||
use GT::SQL::Driver::sth;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Retrieves the current sequence.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->{_insert_id} if $self->{_insert_id};
|
||||
|
||||
my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
|
||||
$table ||= $self->{name};
|
||||
my $seq = $table . "_seq.CURRVAL";
|
||||
my $query = "SELECT $seq FROM $table";
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query, $DBI::errstr);
|
||||
$sth->execute or return $self->fatal(CANTEXECUTE => $query, $DBI::errstr);
|
||||
my ($id) = $sth->fetchrow_array;
|
||||
$self->{_insert_id} = $id;
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub execute {
|
||||
# -------------------------------------------------------------------
|
||||
# Fetch off only desired rows.
|
||||
#
|
||||
my $self = shift;
|
||||
my $time;
|
||||
if ($self->{_debug}) {
|
||||
$self->last_query($self->{query}, @_);
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 1) {
|
||||
$stack = GT::Base->stack_trace(1,1);
|
||||
$stack =~ s/<br>/\n /g;
|
||||
$stack =~ s/ / /g;
|
||||
$stack = "\n $stack\n"
|
||||
}
|
||||
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
|
||||
$self->debug("Executing query: $query$stack");
|
||||
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
|
||||
}
|
||||
if ($GT::SQL::Driver::ORACLE::BINDS{$self->{query}}) {
|
||||
for my $bind (@{$GT::SQL::Driver::ORACLE::BINDS{$self->{query}}}) {
|
||||
my ($index, $col, $type) = @$bind;
|
||||
$self->{sth}->bind_param($index, $_[$index - 1], { ora_type => $type, ora_field => $col });
|
||||
}
|
||||
}
|
||||
my $rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
$self->{_results} = [];
|
||||
$self->{_insert_id} = '';
|
||||
$self->{_names} = $self->{sth}->{NAME};
|
||||
if ($self->{do} eq 'SELECT') {
|
||||
$self->{_lim_cnt} = 0;
|
||||
if ($self->{_limit}) {
|
||||
while (my $rec = $self->{sth}->fetchrow_arrayref) {
|
||||
my @tmp = @$rec;
|
||||
pop @tmp; # get rid of the RNUM extra column
|
||||
push @{$self->{_results}}, [@tmp]; # Must copy as ref is reused in DBI.
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
||||
}
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
elsif ($self->{do} eq 'SHOW INDEX') {
|
||||
$self->{_names} = $self->{sth}->{NAME_lc};
|
||||
$self->{_results} = $self->{sth}->fetchall_arrayref;
|
||||
my $i = 0;
|
||||
for (@{$self->{_names}}) { last if $_ eq 'index_unique'; $i++ }
|
||||
for (@{$self->{_results}}) {
|
||||
$_->[$i] = uc($_->[$i]) eq 'UNIQUE' ? 1 : 0;
|
||||
}
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
}
|
||||
elsif ($self->{do} eq 'DESCRIBE') {
|
||||
$rc = $self->_fixup_describe();
|
||||
}
|
||||
else {
|
||||
$self->{rows} = $self->{sth}->rows;
|
||||
}
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
return $rc;
|
||||
}
|
||||
|
||||
sub _fixup_describe {
|
||||
# ---------------------------------------------------------------
|
||||
# Converts output of 'sp_columns tablename' into similiar results
|
||||
# of mysql's describe tablename.
|
||||
#
|
||||
my $self = shift;
|
||||
my @results;
|
||||
|
||||
# Mysql Cols are: Field, Type, Null, Key, Default, Extra
|
||||
my $table = uc $self->{name};
|
||||
while (my $col = $self->{sth}->fetchrow_hashref) {
|
||||
my ($table, $field, $type, $size, $prec, $scale) = @$col{qw/TABLE_NAME COLUMN_NAME DATA_TYPE DATA_LENGTH DATA_PRECISION DATA_SCALE/};
|
||||
my $null = $col->{NULLABLE} eq 'Y';
|
||||
my $default = (not defined $col->{DATA_DEFAULT} or $col->{DATA_DEFAULT} =~ /^''\s*/) ? '' : $col->{DATA_DEFAULT};
|
||||
|
||||
$size = length $default if length $default > $size;
|
||||
|
||||
if ($type =~ /VARCHAR2|CHAR/) {
|
||||
$type = "varchar($size)";
|
||||
}
|
||||
elsif ($type =~ /NUMBER/ and !$scale) {
|
||||
if ($prec) {
|
||||
$type =
|
||||
$prec >= 11 ? 'bigint' :
|
||||
$prec >= 9 ? 'int' :
|
||||
$prec >= 6 ? 'mediumint' :
|
||||
$prec >= 4 ? 'smallint' :
|
||||
'tinyint';
|
||||
}
|
||||
else {
|
||||
$type = 'bigint';
|
||||
}
|
||||
}
|
||||
elsif ($type =~ /NUMBER/ and length $prec and length $scale) {
|
||||
$type = "decimal($prec, $scale)";
|
||||
}
|
||||
elsif ($type =~ /FLOAT/) {
|
||||
$type = (!$prec or $prec > 23) ? 'double' : 'real';
|
||||
}
|
||||
elsif ($type =~ /LONG|CLOB|NCLOB/) {
|
||||
$type = 'text';
|
||||
}
|
||||
elsif ($type =~ /DATE/) {
|
||||
$type = 'datetime';
|
||||
}
|
||||
|
||||
$type = lc $type;
|
||||
$default =~ s,^NULL\s*,,;
|
||||
$default =~ s,^\(?'(.*)'\)?\s*$,$1,;
|
||||
$null = $null ? 'YES' : '';
|
||||
push @results, [$field, $type, $null, '', $default, ''];
|
||||
}
|
||||
( $#results < 0 ) and return;
|
||||
|
||||
# Fetch the Primary key
|
||||
my $que_pk = <<" QUERY";
|
||||
SELECT COL.COLUMN_NAME
|
||||
FROM USER_CONS_COLUMNS COL, USER_CONSTRAINTS CON
|
||||
WHERE COL.TABLE_NAME = '\U$table\E'
|
||||
AND COL.TABLE_NAME = CON.TABLE_NAME
|
||||
AND COL.CONSTRAINT_NAME = CON.CONSTRAINT_NAME
|
||||
AND CON.CONSTRAINT_TYPE='P'
|
||||
QUERY
|
||||
my $sth_pk = $self->{dbh}->prepare($que_pk);
|
||||
$sth_pk->execute;
|
||||
my $indexes = {};
|
||||
while ( my $col = $sth_pk->fetchrow_array ) {
|
||||
$indexes->{$col} = "PRI";
|
||||
}
|
||||
$sth_pk->finish;
|
||||
|
||||
# Fetch the index information.
|
||||
my $que_idx = <<" QUERY";
|
||||
SELECT *
|
||||
FROM USER_INDEXES IND, USER_IND_COLUMNS COL
|
||||
WHERE IND.TABLE_NAME = '\U$table\E'
|
||||
AND IND.TABLE_NAME = COL.TABLE_NAME
|
||||
AND IND.INDEX_NAME = COL.INDEX_NAME
|
||||
QUERY
|
||||
|
||||
my $sth_idx = $self->{dbh}->prepare($que_idx);
|
||||
$sth_idx->execute;
|
||||
while ( my $col = $sth_idx->fetchrow_hashref ) {
|
||||
my $key = $col->{UNIQUENESS} =~ /UNIQUE/ ? 'UNIQUE' : 'MUL';
|
||||
exists $indexes->{$col->{COLUMN_NAME}} or $indexes->{$col->{COLUMN_NAME}} = $key;
|
||||
}
|
||||
|
||||
for my $result (@results) {
|
||||
if (defined $indexes->{$result->[0]}) {
|
||||
$result->[3] = $indexes->{$result->[0]};
|
||||
if ($result->[1] =~ /int/) { # Set extra
|
||||
my $sth = $self->{dbh}->prepare("SELECT SEQUENCE_NAME FROM USER_SEQUENCES WHERE SEQUENCE_NAME = '\U$table\E_SEQ'");
|
||||
$sth->execute;
|
||||
$result->[5] = 'auto_increment' if $sth->fetchrow;
|
||||
$sth->finish;
|
||||
}
|
||||
}
|
||||
}
|
||||
$sth_idx->finish;
|
||||
$self->{_results} = \@results;
|
||||
$self->{_names} = [qw/Field Type Null Key Default Extra/];
|
||||
$self->{rows} = @{$self->{_results}};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub finish {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
delete $GT::SQL::Driver::ORACLE::BINDS{$self->{query}};
|
||||
$self->SUPER::finish;
|
||||
}
|
||||
|
||||
$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _fetchrow_hashref {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Handles row fetching for driver that can't use the default ->fetchrow_hashref
|
||||
# due to needing column case mapping ($sth->{hints}->{case_map}), or special
|
||||
# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit
|
||||
# handling).
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my %case_map; # returnedname => ReturnedName, but only for columns that use upper case
|
||||
if ($self->{hints}->{case_map}) {
|
||||
if (exists $self->{schema}->{cols}) {
|
||||
my $cols = $self->{schema}->{cols};
|
||||
%case_map = map { lc $_ => $_ } keys %$cols;
|
||||
}
|
||||
else {
|
||||
for my $table (keys %{$self->{schema}}) {
|
||||
for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) {
|
||||
$case_map{lc $col} = $col;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->{_results}) {
|
||||
my $arr = shift @{$self->{_results}} or return;
|
||||
|
||||
my $i;
|
||||
my %selected = map { lc $_ => $i++ } @{$self->{_names}};
|
||||
my %hash;
|
||||
|
||||
for my $lc_col (keys %selected) {
|
||||
next if $lc_col eq 'rnum';
|
||||
if (exists $case_map{$lc_col}) {
|
||||
$hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}];
|
||||
}
|
||||
else {
|
||||
$hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}];
|
||||
}
|
||||
}
|
||||
return \%hash;
|
||||
}
|
||||
else {
|
||||
my $h = $self->{sth}->fetchrow_hashref or return;
|
||||
for (keys %$h) {
|
||||
$h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_};
|
||||
}
|
||||
return $h;
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# DATA TYPE MAPPINGS
|
||||
# -----------------------------------------------------------------------------
|
||||
|
||||
package GT::SQL::Driver::ORACLE::Types;
|
||||
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use Carp qw/croak/;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
# Quoting table and/or column names gives case-sensitivity to the table and
|
||||
# column names in Oracle - however, because this needs to be compatible with
|
||||
# older versions of this driver that didn't properly handle table/column case,
|
||||
# we can't use that to our advantage, as all the old unquoted tables/columns
|
||||
# would be upper-case - TABLE or COLUMN will be the name in the database, and
|
||||
# "Table" or "column" would not exist. It would, however, still be nice to
|
||||
# support this at some point:
|
||||
# sub base {
|
||||
# my ($class, $args, $name, $attribs) = @_;
|
||||
# $class->SUPER::base($args, qq{"$name"}, $attribs);
|
||||
# }
|
||||
|
||||
sub TINYINT { $_[0]->base($_[1], 'NUMBER(3)') }
|
||||
sub SMALLINT { $_[0]->base($_[1], 'NUMBER(5)') }
|
||||
sub MEDIUMINT { $_[0]->base($_[1], 'NUMBER(8)') }
|
||||
sub INT { $_[0]->base($_[1], 'NUMBER(10)') }
|
||||
sub BIGINT { $_[0]->base($_[1], 'NUMBER(19)') }
|
||||
sub REAL { $_[0]->base($_[1], 'FLOAT(23)') }
|
||||
sub DOUBLE { $_[0]->base($_[1], 'FLOAT(52)') }
|
||||
|
||||
sub DATETIME { $_[0]->base($_[1], 'DATE') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'DATE') }
|
||||
sub TIME { croak "Oracle does not support 'TIME' columns\n" }
|
||||
sub YEAR { croak "Oracle does not support 'YEAR' columns\n" }
|
||||
|
||||
sub CHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
|
||||
sub VARCHAR { $_[0]->SUPER::CHAR($_[1], 'VARCHAR2') }
|
||||
sub TEXT { $_[0]->base($_[1], 'CLOB') }
|
||||
sub BLOB { delete $_[1]->{default}; $_[0]->base($_[1], 'BLOB') }
|
||||
|
||||
1;
|
||||
661
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/PG.pm
Normal file
661
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/PG.pm
Normal file
@ -0,0 +1,661 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::PG
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: PG.pm,v 2.3 2005/10/06 00:05:51 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description: PostgreSQL driver for GT::SQL
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::PG;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
use DBI();
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver/;
|
||||
|
||||
sub protocol_version { 2 }
|
||||
|
||||
sub connect {
|
||||
my $self = shift;
|
||||
my $dbh = $self->SUPER::connect(@_) or return;
|
||||
|
||||
# This is really a hack to get things working somewhat accurately - ideally
|
||||
# all data should be in UTF8, but GT::SQL and our products do not yet have
|
||||
# any provision for such, and inserting iso8859-1 data into a unicode table
|
||||
# causes fatal errors about invalid utf8 sequences. So, we set it to
|
||||
# latin1 here in the hopes that it won't break too much, and let the
|
||||
# application deal with it. There are still inherent problems here,
|
||||
# however - if the database is latin5, for example, setting this to latin1
|
||||
# would make postgresql attempt to convert from latin1 -> latin5 on input
|
||||
# and convert back on output, which is a potentially lossy conversion.
|
||||
$dbh->do("SET NAMES 'LATIN1'");
|
||||
|
||||
return $dbh;
|
||||
}
|
||||
|
||||
sub dsn {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Creates a postgres-specific DSN, such as:
|
||||
# DBI:Pg:dbname=database;host=some_hostname
|
||||
# host is omitted if set to 'localhost', so that 'localhost' can be used for a
|
||||
# non-network connection. If you really want to connect to localhost, use
|
||||
# 127.0.0.1.
|
||||
#
|
||||
my ($self, $connect) = @_;
|
||||
|
||||
$connect->{driver} ||= 'Pg';
|
||||
$connect->{host} ||= 'localhost';
|
||||
$self->{driver} = $connect->{driver};
|
||||
|
||||
my $dsn = "DBI:$connect->{driver}:";
|
||||
$dsn .= "dbname=$connect->{database}";
|
||||
$dsn .= ";host=$connect->{host}" unless $connect->{host} eq 'localhost';
|
||||
$dsn .= ";port=$connect->{port}" if $connect->{port};
|
||||
|
||||
return $dsn;
|
||||
}
|
||||
|
||||
sub hints {
|
||||
prefix_indexes => 1,
|
||||
fix_index_dbprefix => 1,
|
||||
case_map => 1,
|
||||
ai => sub {
|
||||
my ($table, $column) = @_;
|
||||
my $seq = "${table}_seq";
|
||||
my @q;
|
||||
push @q, \"DROP SEQUENCE $seq";
|
||||
push @q, "CREATE SEQUENCE $seq INCREMENT 1 START 1";
|
||||
\@q;
|
||||
},
|
||||
drop_pk_constraint => 1
|
||||
}
|
||||
|
||||
$COMPILE{_version} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _version {
|
||||
my $self = shift;
|
||||
return $self->{pg_version} if $self->{pg_version};
|
||||
my $ver = $self->{dbh}->get_info(18); # SQL_DBMS_VERSION
|
||||
if ($ver) {
|
||||
local $^W;
|
||||
$ver = sprintf "%.2f", $ver;
|
||||
}
|
||||
return $self->{pg_version} = $ver;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _prepare_select {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Rewrite MySQL-style LIMIT y,x into PG's nicer LIMIT x OFFSET y format
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$query =~ s/\bLIMIT\s+(\d+)\s*,\s*(\d+)/LIMIT $2 OFFSET $1/i;
|
||||
$query;
|
||||
}
|
||||
|
||||
sub _prepare_describe {
|
||||
# ------------------------------------------------------------------
|
||||
# Postgres-specific describe code
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
$query =~ /DESCRIBE\s*(\w+)/i
|
||||
or return $self->warn(CANTPREPARE => $query, "Invalid describe query: $query");
|
||||
|
||||
# atttypmod contains the scale and precision, but has to be extracted using bit operations:
|
||||
my $prec_bits = 2**26-2**15-1; # bits 16 through 26 give the precision (given a max prec of 1000)
|
||||
my $scale_bits = 2**10-1; # bits 1 through 10 give the scale + 4 (given a max scale of 1000)
|
||||
|
||||
<<QUERY
|
||||
SELECT
|
||||
a.attname as "Field",
|
||||
CASE
|
||||
WHEN t.typname = 'int4' THEN 'int(10)'
|
||||
WHEN t.typname = 'int2' THEN 'smallint(5)'
|
||||
WHEN t.typname = 'int8' THEN 'bigint(19)'
|
||||
WHEN t.typname = 'float4' THEN 'real'
|
||||
WHEN t.typname = 'float8' THEN 'double'
|
||||
WHEN t.typname = 'bpchar' THEN 'char(' || (a.atttypmod - 4) || ')'
|
||||
WHEN t.typname = 'varchar' THEN 'varchar(' || (a.atttypmod - 4) || ')'
|
||||
WHEN t.typname = 'numeric' THEN 'decimal(' || ((atttypmod & $prec_bits)>>16) || ',' || ((a.atttypmod & $scale_bits)-4) || ')'
|
||||
ELSE t.typname
|
||||
END AS "Type",
|
||||
CASE WHEN a.attnotnull = 't' THEN '' ELSE 'YES' END AS "Null",
|
||||
(
|
||||
SELECT
|
||||
CASE
|
||||
WHEN adsrc SIMILAR TO '''%''::[a-zA-Z0-9]+' THEN substring(adsrc from '''#"%#"''::[a-zA-Z0-9]+' for '#')
|
||||
WHEN adsrc SIMILAR TO '[0-9.e+-]+' THEN adsrc
|
||||
ELSE NULL
|
||||
END
|
||||
FROM pg_attrdef
|
||||
WHERE adrelid = c.relfilenode AND adnum = a.attnum
|
||||
) AS "Default",
|
||||
(
|
||||
SELECT
|
||||
CASE WHEN d.adsrc LIKE 'nextval(%)' THEN 'auto_increment' ELSE '' END
|
||||
FROM pg_attrdef d
|
||||
WHERE d.adrelid = c.relfilenode AND adnum = a.attnum
|
||||
) AS "Extra"
|
||||
FROM
|
||||
pg_class c, pg_attribute a, pg_type t
|
||||
WHERE
|
||||
a.atttypid = t.oid AND a.attrelid = c.oid AND
|
||||
relkind = 'r' AND
|
||||
a.attnum > 0 AND
|
||||
c.relname = '\L$1\E'
|
||||
ORDER BY
|
||||
a.attnum
|
||||
QUERY
|
||||
|
||||
# The following could be used above for Key - but it's left off because SHOW
|
||||
# INDEX is much more useful:
|
||||
# (
|
||||
# SELECT CASE WHEN COUNT(*) >= 1 THEN 'PRI' ELSE '' END
|
||||
# FROM pg_index keyi, pg_class keyc, pg_attribute keya
|
||||
# WHERE keyi.indexrelid = keyc.oid AND keya.attrelid = keyc.oid and keyi.indrelid = c.oid
|
||||
# and indisprimary = 't' and keya.attname = a.attname
|
||||
# ) AS "Key",
|
||||
}
|
||||
|
||||
sub column_exists {
|
||||
my ($self, $table, $column) = @_;
|
||||
my $sth = $self->{dbh}->prepare(<<EXISTS);
|
||||
SELECT
|
||||
COUNT(*)
|
||||
FROM
|
||||
pg_class c, pg_attribute a
|
||||
WHERE
|
||||
a.attrelid = c.oid AND
|
||||
c.relkind = 'r' AND a.attnum > 0 AND
|
||||
c.relname = ? AND a.attname = ?
|
||||
EXISTS
|
||||
$sth->execute(lc $table, lc $column);
|
||||
|
||||
return scalar $sth->fetchrow;
|
||||
}
|
||||
|
||||
sub _prepare_show_tables {
|
||||
# -----------------------------------------------------------------------------
|
||||
# pg-specific 'SHOW TABLES'-equivelant
|
||||
#
|
||||
<<' QUERY';
|
||||
SELECT relname AS tables
|
||||
FROM pg_class
|
||||
WHERE relkind = 'r' AND NOT (relname LIKE 'pg_%' OR relname LIKE 'sql_%')
|
||||
ORDER BY relname
|
||||
QUERY
|
||||
}
|
||||
|
||||
sub _prepare_show_index {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Get index list
|
||||
#
|
||||
my ($self, $query) = @_;
|
||||
unless ($query =~ /^\s*SHOW\s+INDEX\s+FROM\s+(\w+)\s*$/i) {
|
||||
return $self->warn(CANTPREPARE => $query, "Invalid/unsupported SHOW INDEX query: $query");
|
||||
}
|
||||
<<" QUERY";
|
||||
SELECT
|
||||
c.relname AS index_name,
|
||||
attname AS index_column,
|
||||
CASE WHEN indisunique = 't' THEN 1 ELSE 0 END AS index_unique,
|
||||
CASE WHEN indisprimary = 't' THEN 1 ELSE 0 END AS index_primary
|
||||
FROM
|
||||
pg_index i,
|
||||
pg_class c,
|
||||
pg_class t,
|
||||
pg_attribute a
|
||||
WHERE
|
||||
i.indexrelid = c.oid AND
|
||||
a.attrelid = c.oid AND
|
||||
i.indrelid = t.oid AND
|
||||
t.relname = '\L$1\E'
|
||||
ORDER BY
|
||||
i.indexrelid, a.attnum
|
||||
QUERY
|
||||
}
|
||||
|
||||
sub drop_table {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Drops the table passed in - drops a sequence if needed. Takes a second
|
||||
# argument that, if true, causes the sequence _not_ to be dropped - used when
|
||||
# the table is being recreated.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $sth = $self->{dbh}->prepare("SELECT relname FROM pg_class WHERE relkind = 'S' AND relname = '\L$table\E_seq'");
|
||||
$sth->execute();
|
||||
if (my $seq_name = $sth->fetchrow) {
|
||||
$self->do("DROP SEQUENCE $seq_name")
|
||||
or $self->warn(CANTEXECUTE => "DROP SEQUENCE $seq_name", $GT::SQL::error);
|
||||
}
|
||||
return $self->SUPER::drop_table($table);
|
||||
}
|
||||
|
||||
sub drop_column {
|
||||
# -------------------------------------------------------------------
|
||||
# Drops a column from a table.
|
||||
#
|
||||
my ($self, $table, $column) = @_;
|
||||
|
||||
my $ver = $self->_version();
|
||||
|
||||
# Postgresql 7.3 and above support ALTER TABLE $table DROP $column
|
||||
return $self->SUPER::drop_column($table, $column) if $ver and $ver >= 7.03;
|
||||
|
||||
$self->_recreate_table();
|
||||
}
|
||||
|
||||
$COMPILE{_recreate_table} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _recreate_table {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds/removes/changes a column, but very expensively as it involves recreating
|
||||
# and copying the entire table. Takes argument pairs, currently:
|
||||
#
|
||||
# with => 'adding_this_column' # optional
|
||||
#
|
||||
# Keep in mind that the various columns depend on the {cols} hash of the table
|
||||
# having been updated to reflect the change.
|
||||
#
|
||||
# We absolutely require DBI 1.20 in this subroutine for transaction support.
|
||||
# However, we won't get here if using PG >= 7.3, so you can have either an
|
||||
# outdated PG, or an outdated DBI, but not both.
|
||||
#
|
||||
my ($self, %opts) = @_;
|
||||
|
||||
DBI->require_version(1.20);
|
||||
my $ver = $self->_version;
|
||||
|
||||
my $table = $self->{name} or $self->fatal(BADARGS => 'No table specified');
|
||||
|
||||
my $cols = $self->{schema}->{cols};
|
||||
my %pos = map { $_ => $cols->{$_}->{pos} } keys %$cols;
|
||||
|
||||
my (@copy_cols, @select_cols);
|
||||
for (keys %$cols) {
|
||||
push @copy_cols, "$_ " . $self->column_sql($cols->{$_});
|
||||
push @select_cols, $_;
|
||||
}
|
||||
|
||||
if ($opts{with}) { # a column was added, so we can't select it from the old table
|
||||
@select_cols = grep $_ ne $opts{with}, @select_cols;
|
||||
}
|
||||
|
||||
$self->{dbh}->begin_work;
|
||||
|
||||
my $temptable = "GTTemp" . substr(time, -4) . int rand 10000;
|
||||
my $select_cols = join ', ', @select_cols;
|
||||
my $lock = "LOCK TABLE $table";
|
||||
my $createtemp = "CREATE TABLE $temptable AS SELECT * FROM $table";
|
||||
|
||||
my $insert = "INSERT INTO $table ( $select_cols ) SELECT $select_cols FROM $temptable";
|
||||
my $drop_temp = "DROP TABLE $temptable";
|
||||
|
||||
for my $precreate ($lock, $createtemp) {
|
||||
unless ($self->{dbh}->do($precreate)) {
|
||||
$self->warn(CANTEXECUTE => $precreate => $DBI::errstr);
|
||||
$self->{dbh}->rollback;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
unless ($self->drop_table($table)) {
|
||||
$self->{dbh}->rollback;
|
||||
return undef;
|
||||
}
|
||||
|
||||
unless ($self->create_table) {
|
||||
$self->{dbh}->rollback;
|
||||
return undef;
|
||||
}
|
||||
|
||||
for my $postcreate ($insert, $drop_temp) {
|
||||
unless ($self->{dbh}->do($postcreate)) {
|
||||
$self->warn(CANTEXECUTE => $postcreate => $DBI::errstr);
|
||||
$self->{dbh}->rollback;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
$self->{dbh}->commit;
|
||||
|
||||
return 1;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub alter_column {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Changes a column in a table. The actual path done depends on multiple
|
||||
# things, including your version of postgres. The following are supported
|
||||
# _without_ recreating the table; anything more complicated requires the table
|
||||
# be recreated via _recreate_table().
|
||||
#
|
||||
# - changing/dropping a default, with >= 7.0 (doesn't require DBI >= 1.20,
|
||||
# everything else does)
|
||||
# - adding/dropping a not null contraint, with >= 7.3
|
||||
# - any other changes, with >= 7.3, by adding a new column, copying data into
|
||||
# it, dropping the old column
|
||||
#
|
||||
# Anything else calls _recreate_table(), which also requires DBI 1.20, but is
|
||||
# much more involved as the table has to be dropped and recreated.
|
||||
#
|
||||
my ($self, $table, $column, $new_def, $old_col) = @_;
|
||||
|
||||
my $ver = $self->_version;
|
||||
return $self->_recreate_table() if $ver < 7;
|
||||
|
||||
my $cols = $self->{schema}->{cols};
|
||||
my $new_col = $cols->{$column};
|
||||
|
||||
my @onoff = qw/not_null/; # true/false attributes
|
||||
my @changeable = qw/default size scale precision/; # changeable attributes
|
||||
my %add = map { ($new_col->{$_} and not $old_col->{$_}) ? ($_ => 1) : () } @onoff;
|
||||
my %rem = map { ($old_col->{$_} and not $new_col->{$_}) ? ($_ => 1) : () } @onoff;
|
||||
my %change = map { (
|
||||
exists $new_col->{$_} and exists $old_col->{$_} # exists in both old and new
|
||||
and (
|
||||
defined($new_col->{$_}) ne defined($old_col->{$_}) # one is undef, the other isn't
|
||||
or
|
||||
defined $new_col->{$_} and defined $old_col->{$_} and $new_col->{$_} ne $old_col->{$_} # both are defined, but !=
|
||||
)
|
||||
) ? ($_ => 1) : () } @changeable;
|
||||
|
||||
{
|
||||
my %add_changeable = map { (exists $new_col->{$_} and not exists $old_col->{$_}) ? ($_ => 1) : () } @changeable;
|
||||
my %rem_changeable = map { (exists $old_col->{$_} and not exists $new_col->{$_}) ? ($_ => 1) : () } @changeable;
|
||||
%add = (%add, %add_changeable);
|
||||
%rem = (%rem, %rem_changeable);
|
||||
}
|
||||
|
||||
if ($ver < 7.03) {
|
||||
# In 7.0 - 7.2, defaults can be added/dropped/changed, but anything
|
||||
# more complicated needs a table recreation
|
||||
if (
|
||||
keys %change == 1 and exists $change{default} and not keys %add and not keys %rem # Changed a default
|
||||
or keys %add == 1 and exists $add{default} and not keys %change and not keys %rem # Added a default
|
||||
or keys %rem == 1 and exists $rem{default} and not keys %change and not keys %add # Dropped a default
|
||||
) {
|
||||
my $query = "ALTER TABLE $table ALTER COLUMN $column ";
|
||||
my $ph;
|
||||
if ($add{default} or $change{default}) {
|
||||
$query .= "SET DEFAULT ?";
|
||||
$ph = $new_col->{default};
|
||||
}
|
||||
else {
|
||||
$query .= "DROP DEFAULT";
|
||||
}
|
||||
$self->{dbh}->do($query, defined $ph ? (undef, $ph) : ())
|
||||
or return $self->warn(CANTEXECUTE => $query => $DBI::errstr);
|
||||
return 1;
|
||||
}
|
||||
return $self->_recreate_table();
|
||||
}
|
||||
|
||||
# PG 7.3 or later
|
||||
|
||||
if (
|
||||
keys %rem == 1 and $rem{not_null} and not keys %add and not keys %change # DROP NOT NULL
|
||||
or keys %add == 1 and $add{not_null} and not keys %rem and not keys %change # SET NOT NULL
|
||||
) {
|
||||
# All we're doing is changing a not_null constraint
|
||||
my $query = "ALTER TABLE $table ALTER COLUMN $column ";
|
||||
$query .= $rem{not_null} ? 'DROP' : 'SET';
|
||||
$query .= ' NOT NULL';
|
||||
$self->{dbh}->do($query)
|
||||
or return $self->warn(CANTEXECUTE => $query => $DBI::errstr);
|
||||
return 1;
|
||||
}
|
||||
|
||||
if (keys(%change) - ($change{default} ? 1 : 0) - (($ver >= 8 and $change{type}) ? 1 : 0) == 0 # No changes other than 'default' (and type, for PG >= 8)
|
||||
and keys(%add) - ($add{default} ? 1 : 0) - ($add{not_null} ? 1 : 0) == 0 # No adds other than default or not_null
|
||||
and keys(%rem) - ($rem{default} ? 1 : 0) - ($rem{not_null} ? 1 : 0) == 0 # No rems other than default or not_null
|
||||
) {
|
||||
my @query;
|
||||
# Change type (PG 8+ only)
|
||||
if ($ver >= 8 and $change{type}) {
|
||||
push @query, "ALTER TABLE $table ALTER COLUMN $column TYPE $new_col->{type}";
|
||||
}
|
||||
|
||||
# Change default
|
||||
if ($add{default} or $change{default}) {
|
||||
push @query, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $new_col->{default}];
|
||||
}
|
||||
elsif ($rem{default}) {
|
||||
push @query, "ALTER TABLE $table ALTER COLUMN $column DROP DEFAULT";
|
||||
}
|
||||
|
||||
# Change not_null
|
||||
if ($rem{not_null}) {
|
||||
push @query, "ALTER TABLE $table ALTER COLUMN $column DROP NOT NULL";
|
||||
}
|
||||
elsif ($add{not_null}) {
|
||||
if ($add{default}) {
|
||||
push @query, ["UPDATE $table SET $column = ? WHERE $column IS NULL", $new_col->{default}];
|
||||
}
|
||||
push @query, "ALTER TABLE $table ALTER COLUMN $column SET NOT NULL";
|
||||
}
|
||||
|
||||
return $self->do_raw_transaction(@query);
|
||||
}
|
||||
|
||||
# We've got more complex changes than PG's ALTER COLUMN can handle; we need
|
||||
# to add a new column, copy the data, drop the old column, and rename the
|
||||
# new one to the old name.
|
||||
my (@queries, %index, %unique);
|
||||
|
||||
push @queries, "LOCK TABLE $table";
|
||||
my %add_def = %$new_col;
|
||||
my $not_null = delete $add_def{not_null};
|
||||
my $default = delete $add_def{default};
|
||||
my $add_def = $self->column_sql(\%add_def);
|
||||
my $tmpcol = 'GTTemp' . substr(time, -4) . int(rand 10000);
|
||||
push @queries, "ALTER TABLE $table ADD COLUMN $tmpcol $add_def";
|
||||
push @queries, "UPDATE $table SET $tmpcol = $column";
|
||||
push @queries, ["UPDATE $table SET $tmpcol = ? WHERE $tmpcol IS NULL", $default] if $add{not_null} and defined $default;
|
||||
push @queries, ["ALTER TABLE $table ALTER COLUMN $tmpcol SET DEFAULT ?", $default] if defined $default;
|
||||
push @queries, "ALTER TABLE $table ALTER COLUMN $tmpcol SET NOT NULL" if $not_null;
|
||||
push @queries, "ALTER TABLE $table DROP COLUMN $column";
|
||||
push @queries, "ALTER TABLE $table RENAME COLUMN $tmpcol TO $column";
|
||||
|
||||
for my $type (qw/index unique/) {
|
||||
while (my ($index, $columns) = each %{$new_col->{$type}}) {
|
||||
my $recreate;
|
||||
for (@$columns) {
|
||||
if ($_ eq $column) {
|
||||
$recreate = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
next unless $recreate;
|
||||
if ($type eq 'index') {
|
||||
$index{$index} = $columns;
|
||||
}
|
||||
else {
|
||||
$unique{$index} = $columns;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$self->do_raw_transaction(@queries);
|
||||
|
||||
while (my ($index, $columns) = each %index) {
|
||||
$self->create_index($table, $index, @$columns);
|
||||
}
|
||||
while (my ($index, $columns) = each %unique) {
|
||||
$self->create_unique($table, $index, @$columns);
|
||||
}
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
sub add_column {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Adds a new column to the table.
|
||||
#
|
||||
my ($self, $table, $column, $def) = @_;
|
||||
|
||||
# make a copy so the original reference doesn't get clobbered
|
||||
my %col = %{$self->{schema}->{cols}->{$column}};
|
||||
|
||||
# Defaults and not_null have to be set _after_ adding the column.
|
||||
my $default = delete $col{default};
|
||||
my $not_null = delete $col{not_null};
|
||||
|
||||
my $ver = $self->_version;
|
||||
|
||||
return $self->_recreate_table(with => $column)
|
||||
if $ver < 7 and defined $default or $ver < 7.03 and $not_null;
|
||||
|
||||
my @queries;
|
||||
|
||||
if (defined $default or $not_null) {
|
||||
$def = $self->column_sql(\%col);
|
||||
}
|
||||
|
||||
push @queries, ["ALTER TABLE $table ADD $column $def"];
|
||||
|
||||
push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET DEFAULT ?", $default] if defined $default;
|
||||
push @queries, ["UPDATE $table SET $column = ?", $default] if defined $default and $not_null;
|
||||
push @queries, ["ALTER TABLE $table ALTER COLUMN $column SET NOT NULL"] if $not_null;
|
||||
|
||||
$self->do_raw_transaction(@queries);
|
||||
}
|
||||
|
||||
sub create_pk {
|
||||
my ($self, $table, @cols) = @_;
|
||||
my $ver = $self->_version;
|
||||
if ($ver < 7.2) {
|
||||
return $self->do("ALTER TABLE $table ADD PRIMARY KEY (" . join(',', @cols) . ")");
|
||||
}
|
||||
else {
|
||||
# ALTER TABLE ... ADD PRIMARY KEY (...) was added in PG 7.2 - on prior
|
||||
# versions we have to recreate the entire table.
|
||||
return $self->_recreate_table();
|
||||
}
|
||||
}
|
||||
|
||||
sub drop_pk {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Drop a primary key. Look for the primary key, then call drop_index with it.
|
||||
#
|
||||
my ($self, $table) = @_;
|
||||
|
||||
my $sth = $self->prepare("SHOW INDEX FROM $table") or return;
|
||||
$sth->execute or return;
|
||||
my $pk_name;
|
||||
while (my $index = $sth->fetchrow_hashref) {
|
||||
if ($index->{index_primary}) {
|
||||
$pk_name = $index->{index_name};
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
$pk_name or return $self->warn(CANTEXECUTE => "ALTER TABLE $table DROP PRIMARY KEY" => "No primary key found for $table");
|
||||
|
||||
$self->do("ALTER TABLE $table DROP CONSTRAINT $pk_name");
|
||||
}
|
||||
|
||||
sub ai_insert {
|
||||
my ($self, $ai) = @_;
|
||||
return $ai, "NEXTVAL('$self->{name}_seq')";
|
||||
}
|
||||
|
||||
sub insert_multiple {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Performs multiple insertions in a single transaction, for much better speed.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# ->begin_work and ->commit were not added until 1.20
|
||||
return $self->SUPER::insert_multiple(@_) if $DBI::VERSION < 1.20;
|
||||
|
||||
$self->{dbh}->begin_work;
|
||||
my ($cols, $args) = @_;
|
||||
|
||||
my $names = join ",", @$cols, $self->{schema}->{ai} || ();
|
||||
|
||||
my $ret;
|
||||
my $ai_insert = $self->{schema}->{ai} ? "NEXTVAL('$self->{name}_seq')" : undef;
|
||||
|
||||
my $query = "INSERT INTO $self->{name} ($names) VALUES (" . join(',', ('?') x @$cols, $ai_insert || ()) . ')';
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->warn(CANTPREPARE => $query);
|
||||
for (@$args) {
|
||||
if ($sth->execute(@$_)) {
|
||||
++$ret;
|
||||
}
|
||||
else {
|
||||
$self->warn(CANTEXECUTE => $query);
|
||||
}
|
||||
}
|
||||
$self->{dbh}->commit;
|
||||
$ret;
|
||||
}
|
||||
|
||||
sub quote {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This subroutines quotes (or not) a value. Postgres can't handle any text
|
||||
# fields containing null characters, so this has to go beyond the ordinary
|
||||
# quote() in GT::SQL::Driver by stripping out null characters.
|
||||
#
|
||||
my $val = pop;
|
||||
return 'NULL' if not defined $val;
|
||||
return $$val if ref $val eq 'SCALAR' or ref $val eq 'LVALUE';
|
||||
$val =~ y/\x00//d;
|
||||
(values %GT::SQL::Driver::CONN)[0]->quote($val);
|
||||
}
|
||||
|
||||
package GT::SQL::Driver::PG::sth;
|
||||
# ====================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $ERROR_MESSAGE/;
|
||||
use GT::SQL::Driver;
|
||||
use GT::AutoLoader;
|
||||
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = qw/GT::SQL::Driver::sth/;
|
||||
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Retrieves the current sequence.
|
||||
#
|
||||
my $self = shift;
|
||||
my ($table) = $self->{query} =~ /\s*insert\s*into\s*(\w+)/i;
|
||||
$table ||= $self->{name};
|
||||
|
||||
my $query = "SELECT CURRVAL('${table}_seq')";
|
||||
my $sth = $self->{dbh}->prepare($query) or return $self->fatal(CANTPREPARE => $query => $DBI::errstr);
|
||||
$sth->execute or return $self->fatal(CANTEXECUTE => $query => $DBI::errstr);
|
||||
my $id = $sth->fetchrow;
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
# DATA TYPE MAPPINGS
|
||||
# ------------------------------------------------------------------------------------------------ #
|
||||
package GT::SQL::Driver::PG::Types;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::SQL::Driver::Types;
|
||||
use Carp qw/croak/;
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::SQL::Driver::Types';
|
||||
|
||||
sub DATETIME { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP WITHOUT TIME ZONE') }
|
||||
sub TIME { $_[0]->base($_[1], 'TIME WITHOUT TIME ZONE') }
|
||||
sub YEAR { croak "PostgreSQL does not support 'YEAR' columns" }
|
||||
|
||||
# Postgres doesn't have BLOB's, but has a binary 'BYTEA' type - the one (big)
|
||||
# caveat to this type, however, is that it requires escaping for any input, and
|
||||
# unescaping for any output.
|
||||
|
||||
1;
|
||||
191
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/Types.pm
Normal file
191
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/Types.pm
Normal file
@ -0,0 +1,191 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::Types
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Types.pm,v 2.1 2004/09/07 20:56:59 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements subroutines for each type to convert into SQL string.
|
||||
# See GT::SQL::Types for documentation
|
||||
#
|
||||
# Supported types are:
|
||||
# TINYINT SMALLINT MEDIUMINT INT INTEGER BIGINT - 8, 16, 24, 32, 32, 64 bits
|
||||
# REAL FLOAT DOUBLE - 32, 32, 64 bits
|
||||
# DECIMAL - decimal precision
|
||||
# DATE DATETIME TIMESTAMP TIME YEAR - for storing dates/times/etc.
|
||||
# CHAR VARCHAR - 1-255 characters, CHAR typically takes a fixed amount of space
|
||||
# TEXT - up to 2GB-1 text data; takes a 'size' parameter which /may/ change to smaller type
|
||||
# TINYTEXT SMALLTEXT MEDIUMTEXT LONGTEXT - TEXT with 255, 64KB-1, 16MB-1, 2GB-1 size values, respectively
|
||||
# TINYBLOB BLOB MEDIUMBLOB LONGBLOB - Heavily deprecrated, somewhat-binary data types with 255, 65535, 16777215, 2GB sizes
|
||||
# ENUM - MySQL-only type, implemented as CHAR by everything else; discouraged for portability reasons.
|
||||
# FILE - GT::SQL pseudo-type
|
||||
|
||||
package GT::SQL::Driver::Types;
|
||||
use vars qw/$VERSION @EXPORT_OK $ERROR_MESSAGE @ISA/;
|
||||
use strict;
|
||||
use Exporter();
|
||||
use GT::Base();
|
||||
|
||||
*import = \&Exporter::import;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
@ISA = 'GT::Base';
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/;
|
||||
@EXPORT_OK = qw/base/;
|
||||
|
||||
sub base {
|
||||
# ------------------------------------------------------------------
|
||||
# Base function takes care of most of the types that don't require
|
||||
# much special formatting.
|
||||
#
|
||||
my ($class, $args, $name, $attribs) = @_;
|
||||
$attribs ||= [];
|
||||
my $out = $name;
|
||||
for my $attrib (@$attribs) {
|
||||
$out .= ' ' . $attrib if $args->{$attrib};
|
||||
}
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
$out;
|
||||
}
|
||||
|
||||
# Integers. None of the following are supported by Oracle, which can only
|
||||
# define integer types by the number of digits supported (see
|
||||
# GT/SQL/Driver/ORACLE.pm), and TINYINT and MEDIUMINT are only supported by
|
||||
# MySQL (though MS SQL will use it's unsigned TINYINT type if the unsigned
|
||||
# attribute is also passed in). All int types are signed - an 'unsigned'
|
||||
# column attribute can be used to /suggest/ that the integer type be unsigned -
|
||||
# but it is only for some databases and/or INT types, and so not guaranteed.
|
||||
sub TINYINT { $_[0]->base($_[1], 'SMALLINT') } # 8-bit int
|
||||
sub SMALLINT { $_[0]->base($_[1], 'SMALLINT') } # 16-bit int
|
||||
sub MEDIUMINT { $_[0]->base($_[1], 'INT') } # 24-bit int
|
||||
sub INT { $_[0]->base($_[1], 'INT') } # 32-bit int
|
||||
sub BIGINT { $_[0]->base($_[1], 'BIGINT') } # 64-bit int
|
||||
|
||||
sub INTEGER { $_[0]->INT($_[1]) } # alias for INT, above
|
||||
|
||||
# Floating point numbers
|
||||
sub DOUBLE { $_[0]->base($_[1], 'DOUBLE PRECISION') } # 64-bit float (52 bit precision)
|
||||
sub REAL { $_[0]->base($_[1], 'REAL') } # 32-bit float (23 bit precision), despite what MySQL thinks
|
||||
sub FLOAT { $_[0]->REAL($_[1]) } # alias for REAL
|
||||
|
||||
sub DECIMAL {
|
||||
# ------------------------------------------------------------------
|
||||
# Takes care of DECIMAL's precision.
|
||||
#
|
||||
my ($class, $args, $out, $attribs) = @_;
|
||||
$out ||= 'DECIMAL';
|
||||
$attribs ||= [];
|
||||
|
||||
# 'scale' and 'precision' are the proper names, but a prior version used
|
||||
# the unfortunate 'display' and 'decimal' names, which have no relevant
|
||||
# meaning in SQL.
|
||||
my $scale = defined $args->{scale} ? $args->{scale} : defined $args->{decimal} ? $args->{decimal} : undef;
|
||||
my $precision = defined $args->{precision} ? $args->{precision} : defined $args->{display} ? $args->{display} : undef;
|
||||
|
||||
$scale ||= 0;
|
||||
$precision ||= 10;
|
||||
|
||||
$out .= "($precision, $scale)";
|
||||
|
||||
for my $attrib (@$attribs) {
|
||||
$out .= ' ' . $attrib if $args->{$attrib};
|
||||
}
|
||||
defined $args->{default} and $out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default});
|
||||
$args->{not_null} and $out .= ' NOT NULL';
|
||||
return $out;
|
||||
}
|
||||
|
||||
# Dates - just about every database seems to do things differently here.
|
||||
sub DATE { $_[0]->base($_[1], 'DATE') }
|
||||
sub DATETIME { $_[0]->base($_[1], 'DATETIME') }
|
||||
sub TIMESTAMP { $_[0]->base($_[1], 'TIMESTAMP') }
|
||||
sub TIME { $_[0]->base($_[1], 'TIME') }
|
||||
sub YEAR { $_[0]->base($_[1], 'YEAR') }
|
||||
|
||||
# Everything (even Oracle) supports CHAR for sizes from 1 to at least 255.
|
||||
# Everything except Oracle handles VARCHAR's - Oracle, having deprecated
|
||||
# VARCHAR's, uses VARCHAR2's. However, only MySQL supports the 'BINARY'
|
||||
# attribute to turn this into a "binary" char (meaning, really,
|
||||
# case-insensitive, not binary) - for everything else, a "binary" argument is
|
||||
# simply ignored.
|
||||
sub CHAR {
|
||||
my ($class, $args, $out) = @_;
|
||||
# Important the set the size before calling BINARY, because BINARY's
|
||||
# behaviour is different for sizes <= 255.
|
||||
$args->{size} = 255 unless $args->{size} and $args->{size} <= 255;
|
||||
|
||||
# See the CHAR notes in GT::SQL::Types regarding why we default to VARCHAR
|
||||
$out ||= 'VARCHAR';
|
||||
$out .= "($args->{size})";
|
||||
|
||||
$out .= ' DEFAULT ' . GT::SQL::Driver->quote($args->{default}) if defined $args->{default};
|
||||
$out .= ' NOT NULL' if $args->{not_null};
|
||||
return $out;
|
||||
}
|
||||
sub VARCHAR { $_[0]->CHAR($_[1], 'VARCHAR') }
|
||||
|
||||
# By default, all TEXT types are mapped to 'TEXT'; drivers can override this to
|
||||
# provide different types based on the 'size' attribute.
|
||||
sub TEXT {
|
||||
my ($class, $attrib) = @_;
|
||||
$class->base($attrib, 'TEXT')
|
||||
}
|
||||
|
||||
# .+TEXT is for compatibility with old code, and should be considered
|
||||
# deprecated. Takes the args hash and the size desired.
|
||||
sub _OLD_TEXT {
|
||||
my ($class, $args, $size) = @_;
|
||||
$args = {$args ? %$args : ()};
|
||||
$args->{size} = $size unless $args->{size} and $args->{size} < $size;
|
||||
$class->TEXT($args);
|
||||
}
|
||||
sub TINYTEXT { $_[0]->_OLD_TEXT($_[1] => 255) }
|
||||
sub SMALLTEXT { $_[0]->_OLD_TEXT($_[1] => 65535) }
|
||||
sub MEDIUMTEXT { $_[0]->_OLD_TEXT($_[1] => 16777215) }
|
||||
sub LONGTEXT { $_[0]->_OLD_TEXT($_[1] => 2147483647) }
|
||||
|
||||
# The BLOB* columns below are heavily deprecated - they're still here just in
|
||||
# case someone is still using them. Storing binary data inside an SQL row is
|
||||
# generally a poor idea; a much better approach is to store a pointer to the
|
||||
# data (such as a filename) in the database, and the actual data in a file.
|
||||
#
|
||||
# As such, the default behaviour is to fatal if BLOB's are used - only drivers
|
||||
# that supported BLOB's prior to protocol v2 should override this. Should a
|
||||
# binary type be desired in the future, a 'BINARY' pseudo-type is recommended.
|
||||
sub BLOB {
|
||||
my ($driver) = $_[0] =~ /([^:]+)$/;
|
||||
$driver = $driver eq 'PG' ? 'Postgres' : $driver eq 'ORACLE' ? 'Oracle' : $driver eq 'MYSQL' ? 'MySQL' : $driver;
|
||||
$_[0]->fatal(DRIVERTYPE => $driver => 'BLOB')
|
||||
}
|
||||
sub TINYBLOB { $_[0]->BLOB($_[1], 'TINYBLOB') }
|
||||
sub MEDIUMBLOB { $_[0]->BLOB($_[1], 'MEDIUMBLOB') }
|
||||
sub LONGBLOB { $_[0]->BLOB($_[1], 'LONGBLOB') }
|
||||
|
||||
# Enums - a non-standard SQL type implemented only by MySQL - the default
|
||||
# implementation is to implement it as a CHAR (or TEXT if the longest value is
|
||||
# more than 255 characters - but in that case, are you really sure you want to
|
||||
# use this type?)
|
||||
sub ENUM {
|
||||
my ($class, $args) = @_;
|
||||
my $max = 0;
|
||||
@{$args->{'values'}} or return;
|
||||
for my $val (@{$args->{'values'}}) {
|
||||
my $len = length $val;
|
||||
$max = $len if $len > $max;
|
||||
}
|
||||
my $meth = $max > 255 ? 'TEXT' : 'CHAR';
|
||||
$class->$meth({ size => $max, default => $args->{default}, not_null => $args->{not_null} });
|
||||
}
|
||||
|
||||
# File handling
|
||||
sub FILE {
|
||||
my ($class, $args) = @_;
|
||||
$class->VARCHAR({ binary => 1, size => $args->{size}, not_null => $args->{not_null} });
|
||||
}
|
||||
|
||||
1;
|
||||
189
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/debug.pm
Normal file
189
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/debug.pm
Normal file
@ -0,0 +1,189 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::debug
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: debug.pm,v 2.1 2007/12/18 23:13:41 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# GT::SQL::Driver debugging module
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::debug;
|
||||
use strict;
|
||||
|
||||
use strict;
|
||||
use GT::AutoLoader;
|
||||
use vars qw/$LAST_QUERY @QUERY_STACK @STACK_TRACE $QUERY_STACK_SIZE @ISA/;
|
||||
@ISA = qw(GT::Base);
|
||||
$QUERY_STACK_SIZE = 100;
|
||||
|
||||
$COMPILE{last_query} = __LINE__ . <<'END_OF_SUB';
|
||||
sub last_query {
|
||||
# -------------------------------------------------------------------
|
||||
# Get, or set the last query.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->error('NEEDDEBUG', 'WARN') if (! $self->{_debug});
|
||||
|
||||
@_ > 0 or return $LAST_QUERY || '';
|
||||
|
||||
$LAST_QUERY = shift;
|
||||
$LAST_QUERY = GT::SQL::Driver::debug->replace_placeholders($LAST_QUERY, @_) if (@_);
|
||||
|
||||
# Display stack traces if requested via debug level.
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 2) {
|
||||
($stack, $LAST_QUERY) = js_stack(3, $LAST_QUERY);
|
||||
}
|
||||
elsif ($self->{_debug} > 1) {
|
||||
package DB;
|
||||
my $i = 2;
|
||||
my $ls = defined $ENV{REQUEST_METHOD} ? '<br>' : "\n";
|
||||
my $spc = defined $ENV{REQUEST_METHOD} ? ' ' : ' ';
|
||||
while (my ($file, $line, $sub, $args) = (caller($i++))[1,2,3,4]) {
|
||||
my @args;
|
||||
for (@DB::args) {
|
||||
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
|
||||
my $print = $@ ? \$_ : $_;
|
||||
push @args, defined $print ? $print : '[undef]';
|
||||
}
|
||||
if (@args) {
|
||||
my $args = join ", ", @args;
|
||||
$args =~ s/\n\s*\n/\n/g;
|
||||
$args =~ s/\n/\n$spc$spc$spc$spc/g;
|
||||
$stack .= qq!$sub called at $file line $line with arguments $ls$spc$spc ($args).$ls!;
|
||||
}
|
||||
else {
|
||||
$stack .= qq!$sub called at $file line $line with no arguments.$ls!;
|
||||
}
|
||||
}
|
||||
}
|
||||
push @QUERY_STACK, $LAST_QUERY;
|
||||
push @STACK_TRACE, "<blockquote>\n" . $stack . "\n</blockquote>\n" if ($self->{_debug} and $stack);
|
||||
|
||||
# Pesistance such as Mod_Perl
|
||||
@QUERY_STACK > $QUERY_STACK_SIZE and shift @QUERY_STACK;
|
||||
@STACK_TRACE > $QUERY_STACK_SIZE and shift @STACK_TRACE;
|
||||
|
||||
return $LAST_QUERY || '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{js_stack} = __LINE__ . <<'END_OF_SUB';
|
||||
sub js_stack {
|
||||
# -------------------------------------------------------------------
|
||||
# Create a nicely formatted javascript browser that (unfortunately)
|
||||
# only works in ie, netscape sucks.
|
||||
#
|
||||
my ($sp, $title) = @_;
|
||||
|
||||
my $nb = @QUERY_STACK;
|
||||
my ($stack, $dump_out);
|
||||
{
|
||||
package DB;
|
||||
require GT::Dumper;
|
||||
my $i = 0;
|
||||
|
||||
while (my ($file, $line, $sub, $args) = (caller($sp++))[1,2,3,4]) {
|
||||
if (@DB::args) {
|
||||
$args = "with arguments<br> ";
|
||||
my @args;
|
||||
for (@DB::args) {
|
||||
eval { my $a = $_ }; # workaround for a reference that doesn't think it's a reference
|
||||
my $print = $@ ? \$_ : $_;
|
||||
my $arg = defined $print ? $print : '[undef]';
|
||||
|
||||
$args .= "<a href='#a$nb$i'>$arg</a>, ";
|
||||
my $dump = GT::Dumper::Dumper($arg);
|
||||
$dump_out .= qq~
|
||||
<a name="a$nb$i"></a>
|
||||
<a href="#top">Top</a>
|
||||
<pre>$dump</pre>
|
||||
~;
|
||||
$i++;
|
||||
}
|
||||
chop $args; chop $args;
|
||||
}
|
||||
else {
|
||||
$args = "with no arguments";
|
||||
}
|
||||
$stack .= qq!<li>$sub called at $file line $line $args.<br></li>\n!;
|
||||
}
|
||||
}
|
||||
$stack =~ s/\\/\\\\/g;
|
||||
$stack =~ s/[\n\r]+/\\n/g;
|
||||
$stack =~ s/'/\\'/g;
|
||||
$stack =~ s,script,sc'+'ript,g;
|
||||
|
||||
$dump_out =~ s/\\/\\\\/g;
|
||||
$dump_out =~ s/[\n\r]+/\\n/g;
|
||||
|
||||
$dump_out =~ s/'/\\'/g;
|
||||
$dump_out =~ s,script,sc'+'ript,g;
|
||||
|
||||
my $var = <<HTML;
|
||||
<script language="JavaScript">
|
||||
function my$nb () {
|
||||
msg = window.open('','my$nb','resizable=yes,width=700,height=500,scrollbars=yes');
|
||||
msg.document.write('<html><body><a name="top"></a>STACK TRACE<BR><OL>$stack</OL>$dump_out</BODY></HTML>');
|
||||
msg.document.close();
|
||||
}
|
||||
HTML
|
||||
my $link = qq!<a href="javascript:my$nb();">$title</a><br>!;
|
||||
|
||||
return $var, $link;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{quick_quote} = __LINE__ . <<'END_OF_SUB';
|
||||
sub quick_quote {
|
||||
# -------------------------------------------------------------------
|
||||
# Quick quote to replace ' with \'.
|
||||
#
|
||||
my $str = shift;
|
||||
defined $str and ($str eq "") and return "''";
|
||||
$str =~ s/'/\\'/g;
|
||||
return $str;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{replace_placeholders} = __LINE__ . <<'END_OF_SUB';
|
||||
sub replace_placeholders {
|
||||
# -------------------------------------------------------------------
|
||||
# Replace question marks with the actual values
|
||||
#
|
||||
my ($self, $query, @args) = @_;
|
||||
if (@args > 0) {
|
||||
my @vals = split /('(?:[^']+|''|\\')')/, $query;
|
||||
# Keep track of where we are in each of the @vals strings so that strings with
|
||||
# '?'s in them that aren't placeholders don't incorrectly get replaced with
|
||||
# values.
|
||||
my @vals_idx;
|
||||
VALUE: for my $val (@args) {
|
||||
SUBSTRING: for my $i (0 .. $#vals) {
|
||||
next SUBSTRING if $i % 2;
|
||||
$vals_idx[$i] ||= 0;
|
||||
$vals_idx[$i] = index($vals[$i], '?', $vals_idx[$i]);
|
||||
if ($vals_idx[$i] >= 0) {
|
||||
$val = defined $val ? ($val =~ /\D/ ? "'" . quick_quote($val) . "'" : $val) : 'NULL';
|
||||
substr($vals[$i], $vals_idx[$i], 1, $val);
|
||||
$vals_idx[$i] += length $val;
|
||||
next VALUE;
|
||||
}
|
||||
else {
|
||||
$vals_idx[$i] = 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
$query = join '', @vals;
|
||||
}
|
||||
return $query;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
296
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/sth.pm
Normal file
296
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Driver/sth.pm
Normal file
@ -0,0 +1,296 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::sth
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: sth.pm,v 2.4 2007/03/21 21:28:47 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
# Generic statement handle wrapper
|
||||
#
|
||||
|
||||
package GT::SQL::Driver::sth;
|
||||
use strict;
|
||||
use GT::Base;
|
||||
use GT::AutoLoader(NEXT => '_AUTOLOAD');
|
||||
require GT::SQL::Driver;
|
||||
use GT::SQL::Driver::debug;
|
||||
use vars qw(@ISA $AUTOLOAD $DEBUG $ERROR_MESSAGE);
|
||||
|
||||
$DEBUG = 0;
|
||||
@ISA = qw/GT::SQL::Driver::debug/;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
|
||||
# Get rid of a 'used only once' warnings
|
||||
$DBI::errstr if 0;
|
||||
|
||||
sub new {
|
||||
# --------------------------------------------------------
|
||||
# Create a new driver sth.
|
||||
#
|
||||
my $this = shift;
|
||||
my $class = ref $this || $this;
|
||||
my $opts = {};
|
||||
my $self = bless {}, $class;
|
||||
|
||||
if (@_ == 1 and ref $_[0]) { $opts = shift }
|
||||
elsif (@_ and @_ % 2 == 0) { $opts = {@_} }
|
||||
else { return $self->fatal(BADARGS => "$class->new(HASH_REF or HASH)") }
|
||||
|
||||
$self->{_debug} = $opts->{_debug} || $DEBUG;
|
||||
$self->{_err_pkg} = $opts->{_err_pkg} || 'GT::SQL';
|
||||
|
||||
# Drivers can set this to handle name case changing for fetchrow_hashref
|
||||
$self->{hints} = $opts->{hints} || {};
|
||||
|
||||
for (qw/dbh do query sth schema name _limit _lim_rows _lim_offset/) {
|
||||
$self->{$_} = $opts->{$_} if exists $opts->{$_};
|
||||
}
|
||||
$self->debug("OBJECT CREATED") if ($self->{_debug} > 2);
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{execute} = __LINE__ . <<'END_OF_SUB';
|
||||
sub execute {
|
||||
# --------------------------------------------------------
|
||||
# Execute the query.
|
||||
#
|
||||
my $self = shift;
|
||||
my $do = $self->{do};
|
||||
my $rc;
|
||||
|
||||
# Debugging, stack trace is printed if debug >= 2.
|
||||
my $time;
|
||||
if ($self->{_debug}) {
|
||||
$self->last_query($self->{query}, @_);
|
||||
my $stack = '';
|
||||
if ($self->{_debug} > 1) {
|
||||
$stack = GT::Base->stack_trace(1,1);
|
||||
$stack =~ s/<br>/\n /g;
|
||||
$stack =~ s/ / /g;
|
||||
$stack = "\n $stack\n"
|
||||
}
|
||||
my $query = GT::SQL::Driver::debug->replace_placeholders($self->{query}, @_);
|
||||
$self->debug("Executing query: $query$stack");
|
||||
$time = Time::HiRes::time() if exists $INC{"Time/HiRes.pm"};
|
||||
}
|
||||
if (my $meth = $GT::SQL::Driver::QUERY_MAP{$do}) {
|
||||
$meth = "_execute_$meth";
|
||||
$rc = $self->$meth(@_) or return;
|
||||
}
|
||||
else {
|
||||
$rc = $self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
}
|
||||
|
||||
if ($self->{_debug} and exists $INC{"Time/HiRes.pm"}) {
|
||||
my $elapsed = Time::HiRes::time() - $time;
|
||||
$self->debug(sprintf("Query execution took: %.6fs", $elapsed));
|
||||
}
|
||||
|
||||
$rc;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
# Define one generic execute, and alias all the specific _execute_* functions to it
|
||||
sub _generic_execute {
|
||||
my $self = shift;
|
||||
$self->{sth}->execute(@_) or return $self->warn(CANTEXECUTE => $self->{query}, $DBI::errstr);
|
||||
}
|
||||
for (*_execute_create, *_execute_insert, *_execute_alter, *_execute_select, *_execute_update, *_execute_drop, *_execute_delete, *_execute_describe, *_execute_show_tables, *_execute_show_index) {
|
||||
$_ = \&_generic_execute;
|
||||
}
|
||||
|
||||
sub rows {
|
||||
my $self = shift;
|
||||
return $self->{_rows} if exists $self->{_rows};
|
||||
return $self->{rows} if exists $self->{rows};
|
||||
$self->{sth}->rows;
|
||||
}
|
||||
|
||||
sub fetchrow_arrayref {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->{_results} or return $self->{sth}->fetchrow_arrayref;
|
||||
return shift @{$self->{_results}};
|
||||
}
|
||||
|
||||
sub fetchrow_array {
|
||||
# -----------------------------------------------------------------------------
|
||||
# When called in scalar context, returns either the first or last row, as per
|
||||
# DBI, so avoid using in scalar context when fetching more than one row.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{_results} or return $self->{sth}->fetchrow_array;
|
||||
my $arr = shift @{$self->{_results}};
|
||||
return $arr ? wantarray ? @$arr : $arr->[0] : ();
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# Alias for fetchrow_array (DBI code comments this as an "old" alias, and DBI's
|
||||
# documentation no longer mentions it at all).
|
||||
*fetchrow = \&fetchrow_array; *fetchrow if 0;
|
||||
|
||||
sub fetchrow_hashref {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->_fetchrow_hashref() if $self->{hints}->{case_map} or $self->{_results};
|
||||
$self->{sth}->fetchrow_hashref;
|
||||
}
|
||||
|
||||
$COMPILE{_fetchrow_hashref} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _fetchrow_hashref {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Handles row fetching for driver that can't use the default ->fetchrow_hashref
|
||||
# due to needing column case mapping ($sth->{hints}->{case_map}), or special
|
||||
# result handling (e.g. PG's DESCRIBE handling, Oracle & ODBC's limit
|
||||
# handling).
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my %case_map; # returnedname => ReturnedName, but only for columns that use upper case
|
||||
if ($self->{hints}->{case_map}) {
|
||||
if (exists $self->{schema}->{cols}) {
|
||||
my $cols = $self->{schema}->{cols};
|
||||
%case_map = map { lc $_ => $_ } keys %$cols;
|
||||
}
|
||||
else {
|
||||
for my $table (keys %{$self->{schema}}) {
|
||||
for my $col (keys %{$self->{schema}->{$table}->{schema}->{cols}}) {
|
||||
$case_map{lc $col} = $col;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($self->{_results}) {
|
||||
my $arr = shift @{$self->{_results}} or return;
|
||||
|
||||
my $i;
|
||||
my %selected = map { lc $_ => $i++ } @{$self->{_names}};
|
||||
my %hash;
|
||||
|
||||
for my $lc_col (keys %selected) {
|
||||
if (exists $case_map{$lc_col}) {
|
||||
$hash{$case_map{$lc_col}} = $arr->[$selected{$lc_col}];
|
||||
}
|
||||
else {
|
||||
$hash{$self->{_names}->[$selected{$lc_col}]} = $arr->[$selected{$lc_col}];
|
||||
}
|
||||
}
|
||||
return \%hash;
|
||||
}
|
||||
else {
|
||||
my $h = $self->{sth}->fetchrow_hashref or return;
|
||||
for (keys %$h) {
|
||||
$h->{$case_map{lc $_}} = delete $h->{lc $_} if exists $case_map{lc $_};
|
||||
}
|
||||
return $h;
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub fetchall_arrayref {
|
||||
# ---------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{sth}->fetchall_arrayref(@_) unless $self->{_results};
|
||||
|
||||
my $opt = shift;
|
||||
if ($opt and ref $opt eq 'HASH') {
|
||||
my @ret;
|
||||
while (my $row = $self->fetchrow_hashref) {
|
||||
for (keys %$row) {
|
||||
delete $row->{$_} unless exists $opt->{$_};
|
||||
}
|
||||
push @ret, $row;
|
||||
}
|
||||
return \@ret;
|
||||
}
|
||||
|
||||
my $results = $self->{_results};
|
||||
$self->{_results} = [];
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub fetchall_list { map @$_, @{shift->fetchall_arrayref} }
|
||||
|
||||
sub fetchall_hashref {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This is very different from DBI's fetchall_hashref - this is actually
|
||||
# equivelant to DBI's ->fetchall_arrayref({})
|
||||
#
|
||||
my $self = shift;
|
||||
my @results;
|
||||
while (my $hash = $self->fetchrow_hashref) {
|
||||
push @results, $hash;
|
||||
}
|
||||
return \@results;
|
||||
}
|
||||
|
||||
sub row_names {
|
||||
my $self = shift;
|
||||
$self->{_names} || $self->{sth}->{NAME};
|
||||
}
|
||||
|
||||
$COMPILE{insert_id} = __LINE__ . <<'END_OF_SUB';
|
||||
sub insert_id {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the value of the last record inserted.
|
||||
#
|
||||
return $_[0]->{sth}->{insertid};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub DESTROY {
|
||||
# -------------------------------------------------------------------
|
||||
# Calls finish on the row when it is destroyed.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->debug("OBJECT DESTROYED") if $self->{_debug} > 2;
|
||||
$self->{sth}->finish if ref $self->{sth} and $self->{sth}->can("finish");
|
||||
}
|
||||
|
||||
sub _AUTOLOAD {
|
||||
# -------------------------------------------------------------------
|
||||
# Autoloads any unknown methods to the DBI::st object.
|
||||
#
|
||||
my ($self, @param) = @_;
|
||||
my ($attrib) = $AUTOLOAD =~ /::([^:]+)$/;
|
||||
|
||||
if (exists $DBI::st::{$attrib}) {
|
||||
local *code = $DBI::st::{$attrib};
|
||||
if (*code{CODE}) {
|
||||
$self->debug("Calling DBI::st::$attrib") if $self->{_debug} > 1;
|
||||
return code($self->{sth}, @param);
|
||||
}
|
||||
}
|
||||
|
||||
$GT::SQL::Driver::debug::AUTOLOAD = $AUTOLOAD;
|
||||
goto >::SQL::Driver::debug::AUTOLOAD;
|
||||
}
|
||||
|
||||
sub debug {
|
||||
# -------------------------------------------------------------------
|
||||
# DBI::st has a debug that autoload is catching.
|
||||
#
|
||||
my $self = shift;
|
||||
my $i = 1;
|
||||
my ($package, $file, $line, $sub);
|
||||
while (($package, $file, $line) = caller($i++)) {
|
||||
last if index($package, 'GT::SQL') != 0;
|
||||
}
|
||||
while ($sub = (caller($i++))[3]) {
|
||||
last if index($sub, 'GT::SQL') != 0;
|
||||
}
|
||||
my $msg = $_[0];
|
||||
$msg .= " from $sub" if $sub;
|
||||
$msg .= " at $file" if $file;
|
||||
$msg .= " line $line" if $line;
|
||||
$msg .= "\n";
|
||||
return $self->SUPER::debug($msg);
|
||||
}
|
||||
|
||||
1;
|
||||
1082
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Editor.pm
Normal file
1082
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Editor.pm
Normal file
File diff suppressed because it is too large
Load Diff
1132
site/slowtwitch.com/cgi-bin/articles/GT/SQL/File.pm
Normal file
1132
site/slowtwitch.com/cgi-bin/articles/GT/SQL/File.pm
Normal file
File diff suppressed because it is too large
Load Diff
149
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Monitor.pm
Normal file
149
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Monitor.pm
Normal file
@ -0,0 +1,149 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Monitor
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Monitor.pm,v 1.7 2008/12/05 01:28:49 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::SQL::Monitor;
|
||||
use strict;
|
||||
use vars qw/@EXPORT_OK $CSS/;
|
||||
use Carp qw/croak/;
|
||||
use GT::CGI qw/:escape/;
|
||||
require Exporter;
|
||||
@EXPORT_OK = qw/query/;
|
||||
|
||||
use constant CSS => <<'CSS';
|
||||
<style type="text/css">
|
||||
.sql_monitor td {
|
||||
border-bottom: 1px solid rgb(128, 128, 128);
|
||||
border-right: 1px solid rgb(128, 128, 128);
|
||||
padding: 2px;
|
||||
}
|
||||
.sql_monitor th {
|
||||
border-bottom: 2px solid rgb(128, 128, 128);
|
||||
border-right: 1px solid rgb(128, 128, 128);
|
||||
padding: 2px;
|
||||
}
|
||||
table.sql_monitor {
|
||||
border-collapse: collapse;
|
||||
border-left: 2px solid rgb(128, 128, 128);
|
||||
border-top: 2px solid rgb(128, 128, 128);
|
||||
border-bottom: 2px solid rgb(128, 128, 128);
|
||||
border-right: 2px solid rgb(128, 128, 128);
|
||||
}
|
||||
.sql_monitor pre {
|
||||
margin-bottom: 0px;
|
||||
margin-top: 0px;
|
||||
}
|
||||
</style>
|
||||
CSS
|
||||
|
||||
|
||||
sub query {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Handles the 'SQL Monitor' function of various Gossamer Threads products.
|
||||
# Takes a hash of options:
|
||||
# table - any GT::SQL table object
|
||||
# style - the style to use - 'tab', 'text' or 'html'; defaults to 'text'
|
||||
# html - ('tab' or 'text' mode) whether values should be HTML escaped and the whole thing surrounded by a <pre> tag
|
||||
# query - the query to run
|
||||
# css - if defined, the value will be used for the CSS in 'html' style; otherwise _css() is used
|
||||
# Returned is a hash reference containing:
|
||||
# db_prefix - the database prefix currently in use
|
||||
# style - the value of the 'style' option
|
||||
# query - the query performed
|
||||
# rows - the number of rows returned by the query, or possibly the number of rows affected
|
||||
# results - a scalar reference to the result of the query, if a SELECT/SHOW/sp_*
|
||||
# error - set to 1 if an error occurred
|
||||
# error_connect - set to an error message if the database connection failed
|
||||
# error_prepare - set to an error message if the prepare failed
|
||||
# error_execute - set to an error message if the execute failed
|
||||
#
|
||||
my %opts = @_;
|
||||
|
||||
$opts{table} and $opts{query} or croak "query() called without table and/or query options";
|
||||
|
||||
$opts{table}->connect or return { error => 1, error_connect => $GT::SQL::error };
|
||||
|
||||
my %ret = (
|
||||
db_prefix => $opts{table}->{connect}->{PREFIX},
|
||||
style => $opts{style},
|
||||
query => $opts{query}
|
||||
);
|
||||
|
||||
my $sth = $opts{table}->prepare($opts{query}) or return { %ret, error => 1, error_prepare => $GT::SQL::error };
|
||||
my $rv = $sth->execute or return { %ret, error => 1, error_execute => $GT::SQL::error };
|
||||
|
||||
my $names = $sth->row_names;
|
||||
|
||||
$ret{rows} = $sth->rows || 0;
|
||||
|
||||
if ($opts{query} =~ /^\s*(SELECT|DESCRIBE|SHOW|EXPLAIN|sp_)/i) {
|
||||
my $table = '';
|
||||
my $data = $sth->fetchall_arrayref;
|
||||
if ($opts{style} and $opts{style} eq 'html') {
|
||||
$table .= defined $opts{css} ? $opts{css} : CSS;
|
||||
$table .= qq|<table class="sql_monitor">\n|;
|
||||
$table .= " <tr>\n";
|
||||
$table .= join '', map ' <th><pre>' . html_escape($_) . "</pre></th>\n",
|
||||
@$names;
|
||||
$table .= " </tr>\n";
|
||||
for (@$data) {
|
||||
$table .= " <tr>\n";
|
||||
for (@$_) {
|
||||
my $val = html_escape($_);
|
||||
$val .= "<br />" unless $val =~ /\S/;
|
||||
$table .= qq| <td><pre>$val</pre></td>\n|;
|
||||
}
|
||||
$table .= " </tr>\n";
|
||||
}
|
||||
$table .= "</table>";
|
||||
}
|
||||
elsif ($opts{style} and $opts{style} eq 'tabs') {
|
||||
$table = $opts{html} ? '<pre>' : '';
|
||||
for (@$data) {
|
||||
my @foo = map html_escape($_), @$_;
|
||||
$table .= join("\t", $opts{html} ? (map defined $_ ? html_escape($_) : '', @$_) : @$_) . "\n";
|
||||
}
|
||||
$table .= "</pre>" if $opts{html};
|
||||
}
|
||||
else { # style = 'text'
|
||||
my @max_width = (0) x @$names;
|
||||
for ($names, @$data) {
|
||||
for my $i (0 .. $#$_) {
|
||||
my $width = length $_->[$i];
|
||||
$max_width[$i] = $width if $width > $max_width[$i];
|
||||
}
|
||||
}
|
||||
$table = join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n";
|
||||
$table .= '|';
|
||||
for my $i (0 .. $#$names) {
|
||||
$table .= sprintf " %-$max_width[$i]s |", $names->[$i];
|
||||
}
|
||||
$table .= "\n";
|
||||
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n";
|
||||
for (@$data) {
|
||||
$table .= '|';
|
||||
for my $i (0 .. $#$names) {
|
||||
$table .= sprintf " %-$max_width[$i]s |", $_->[$i];
|
||||
}
|
||||
$table .= "\n";
|
||||
}
|
||||
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . "\n";
|
||||
$table = "<pre>" . html_escape($table) . "</pre>" if $opts{html};
|
||||
}
|
||||
$ret{results} = \$table;
|
||||
}
|
||||
else {
|
||||
$ret{results} = "Rows affected: $ret{rows}";
|
||||
}
|
||||
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
1897
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Relation.pm
Normal file
1897
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Relation.pm
Normal file
File diff suppressed because it is too large
Load Diff
585
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search.pm
Normal file
585
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search.pm
Normal file
@ -0,0 +1,585 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Search.pm,v 1.62 2008/09/23 23:55:26 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# highlevel class for searching, works with GT::SQL::Indexer
|
||||
#
|
||||
|
||||
package GT::SQL::Search;
|
||||
#--------------------------------------------------------------------------------
|
||||
|
||||
# pragmas
|
||||
use strict;
|
||||
use vars qw/@ISA $ERRORS $ERROR_MESSAGE $VERSION/;
|
||||
|
||||
# includes
|
||||
use GT::Base;
|
||||
use GT::AutoLoader;
|
||||
|
||||
# variables
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.62 $ =~ /(\d+)\.(\d+)/;
|
||||
@ISA = qw(GT::Base);
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$ERRORS = {
|
||||
UNKNOWNDRIVER => 'Unknown driver requested: %s',
|
||||
NOTABLE => 'Cannot find reference to table object'
|
||||
};
|
||||
|
||||
sub load_search {
|
||||
#--------------------------------------------------------------------------------
|
||||
# checks if there is driver for this current database and if so, loads that
|
||||
# instead (since it would be faster)
|
||||
#
|
||||
my $class = shift;
|
||||
my $opts = ref $_[0] ? $_[0] : {@_};
|
||||
$opts->{mode} = 'Search';
|
||||
my $driver = $class->load_driver( $opts ) or return;
|
||||
my $pkg = "GT::SQL::Search::${driver}::Search";
|
||||
return $pkg->load(@_);
|
||||
}
|
||||
|
||||
sub load_indexer {
|
||||
#--------------------------------------------------------------------------------
|
||||
# checks if there is driver for this current database and if so, loads that
|
||||
# instead (since it would be faster)
|
||||
#
|
||||
my $class = shift;
|
||||
my $opts = ref $_[0] ? $_[0] : {@_};
|
||||
$opts->{mode} = 'Indexer';
|
||||
my $driver = $class->load_driver( $opts ) or return;
|
||||
my $pkg = "GT::SQL::Search::${driver}::Indexer";
|
||||
|
||||
return $pkg->load(@_);
|
||||
}
|
||||
|
||||
sub driver_ok {
|
||||
#--------------------------------------------------------------------------------
|
||||
# checks to see if a particular driver is allowed on this system
|
||||
#
|
||||
my $class = shift;
|
||||
my $driver = uc shift or return;
|
||||
my $opts = ref $_[0] ? $_[0] : {@_};
|
||||
my $mode = $opts->{mode} || 'Indexer';
|
||||
my $tbl = $opts->{table} or return GT::SQL::Search->error( 'NOTABLE', 'FATAL' );
|
||||
my $pkg = 'GT::SQL::Search::' . $driver . '::' . $mode;
|
||||
|
||||
eval { require "GT/SQL/Search/$driver/$mode.pm" };
|
||||
$@ and return GT::SQL::Search->error('UNKNOWNDRIVER', 'WARN', $driver);
|
||||
return $pkg->can('ok') ? $pkg->ok($tbl) : 1;
|
||||
}
|
||||
|
||||
sub load_driver {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Loads a driver into memory.
|
||||
#
|
||||
my $class = shift;
|
||||
my $opts = ref $_[0] ? $_[0] : {@_};
|
||||
my $tbl = $opts->{table};
|
||||
my $mode = $opts->{mode} || 'Indexer';
|
||||
my $driver = uc($opts->{driver} || $tbl->{schema}->{search_driver} || 'NONINDEXED');
|
||||
|
||||
require "GT/SQL/Search/$driver/$mode.pm";
|
||||
return $driver;
|
||||
}
|
||||
|
||||
sub available_drivers {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns a list of available drivers.
|
||||
#
|
||||
my $class = shift;
|
||||
|
||||
(my $path = $INC{'GT/SQL/Search.pm'}) =~ s/\.pm$//;
|
||||
opendir DHANDLE, $path or return $class->fatal(CANTOPENDIR => $path, "$!");
|
||||
my @arr;
|
||||
for my $driver_name (readdir DHANDLE) {
|
||||
next if $driver_name =~ y/a-z//;
|
||||
next if $driver_name eq 'LUCENE';
|
||||
-f "$path/$driver_name/Search.pm" and -r _ or next;
|
||||
-f "$path/$driver_name/Indexer.pm" and -r _ or next;
|
||||
my $loaded = eval {
|
||||
require "GT/SQL/Search/$driver_name/Search.pm";
|
||||
require "GT/SQL/Search/$driver_name/Indexer.pm";
|
||||
};
|
||||
push @arr, $driver_name if $loaded;
|
||||
}
|
||||
closedir DHANDLE;
|
||||
return wantarray ? @arr : \@arr;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::SQL::Search - internal driver for searching
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This implements the query string based searching scheme for GT::SQL. Driver
|
||||
based, it is designed to take advantage of the different indexing schemes
|
||||
available on different database engines.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Instead of describing how Search.pm is interfaced* this will describe how a
|
||||
driver should be structured and how a new driver can be implemented.
|
||||
|
||||
* as it is never accessed directly by the programmer as it was designed to be
|
||||
called through the functions GT::SQL::Table::query and GT::SQL::Table::query_sth
|
||||
|
||||
=head2 Drivers
|
||||
|
||||
A driver has two parts. The Indexer and the Search packages are the most
|
||||
important. Howserver, for any driver in the search, there must exist a directory
|
||||
with the name of the driver in ALL CAPS. For exampel, MYSQL for MySQL, POSTGRES
|
||||
for Postgres. Within each driver directory, The Indexer and Search portions of
|
||||
the driver contains all the information required for initializing the database
|
||||
table and searching the database.
|
||||
|
||||
The Indexing package of the driver handles all the data that is manipulated in
|
||||
the database and also the initializes and the database for indexing.
|
||||
|
||||
The Search package handles the queries and retrieves results for the eventual
|
||||
consumption by the calling program.
|
||||
|
||||
Drivers are simply subclasses of the base driver module, GT::SQL::Search::Base
|
||||
and operate by overriding certain key functions.
|
||||
|
||||
The next few sections will cover how to create a search driver, and assumes a
|
||||
fair bit of familiarity with GT::SQL.
|
||||
|
||||
=head2 Structure of an Indexing Driver
|
||||
|
||||
The following is an absolutely simple skeleton driver that does nothing and but
|
||||
called "CUSTOM". Found in the CUSTOM directory, this is the search package, and
|
||||
would be call Search.pm in the GT/SQL/Search/CUSTOM library directory.
|
||||
|
||||
package GT::SQL::Search::CUSTOM::Search;
|
||||
#------------------------------------------
|
||||
use strict;
|
||||
use vars qw/ @ISA /;
|
||||
use GT::SQL::Search::Base::Search;
|
||||
@ISA = qw( GT::SQL::Search::Base::Search );
|
||||
|
||||
sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Search->new(@_) };
|
||||
|
||||
# overrides would go here
|
||||
|
||||
1;
|
||||
|
||||
For the indexer, another file, Indexer.pm would be found in the
|
||||
GT/SQL/Search/CUSTOM directory.
|
||||
|
||||
package GT::SQL::Search::CUSTOM::Indexer;
|
||||
#------------------------------------------
|
||||
|
||||
use strict;
|
||||
use vars qw/ @ISA /;
|
||||
use GT::SQL::Search::Base;
|
||||
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
|
||||
|
||||
sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) };
|
||||
|
||||
# overrides would go here
|
||||
|
||||
1;
|
||||
|
||||
The almost empty subs that immediately return with a value are functions that
|
||||
can be overridden to do special tasks. More will be detailed later.
|
||||
|
||||
The Driver has been split into two packages. The original package name,
|
||||
GT::SQL::Search::Nothing, houses the Search package.
|
||||
GT::SQL::Search::Nothing::Indexer is the Indexing portion of the seach system.
|
||||
"::Indexer" must be appended to the orginial search name for the indexer.
|
||||
|
||||
Each of the override functions are triggered at points just before and after a
|
||||
major event occurs in GT::SQL. Depending on the type of actions you require, you
|
||||
pick and chose which events you'd like your driver to attach to.
|
||||
|
||||
=head2 Structure of Indexing Driver
|
||||
|
||||
The Indexer is responsible for creating all the indexes, maintaining them and
|
||||
when the table is dropped, removing all the associated indexes.
|
||||
|
||||
The following header must be defined for the Indexer.
|
||||
GT::SQL::Search::Base::Indexer is the superclass that our driver inherits from.
|
||||
|
||||
package GT::SQL::Search::CUSTOM::Indexer;
|
||||
#------------------------------------------
|
||||
|
||||
use strict;
|
||||
use vars qw/ @ISA /;
|
||||
use GT::Base;
|
||||
use GT::SQL::Search::Base::Indexer;
|
||||
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
|
||||
|
||||
In addition to the header, the following function must be defined.
|
||||
GT::SQL::Search::Driver::Indexer::load creates the new object and allows for
|
||||
special preinitialization that must occur. You can also create another driver
|
||||
silently (such as defaulting to INTERNAL after a version check fails).
|
||||
|
||||
sub load { my $package_name = shift; return GT::SQL::Search::CUSTOM::Indexer->new(@_) };
|
||||
|
||||
Finally, there are the overrides. None of the override functions need be defined
|
||||
in your driver. Any calls made to undefined methods will silently fallback to
|
||||
the superclass driver's methods. When a method has been overridden, the function
|
||||
must return a true value when it is successful, otherwise the action will fail
|
||||
and an error generated.
|
||||
|
||||
Whenever a object is created it will receive one property $self->{table} which
|
||||
is the table that is being worked upon. This property is available in all the
|
||||
method calls and is required for methods such as _create_table and
|
||||
_drop_search_driver methods.
|
||||
|
||||
When a table is first created or when a table is destroyed the following two
|
||||
functions are called. They are not passed any special values, however, these are
|
||||
all class methods and $self->{table} will be a reference to the current table in
|
||||
use.
|
||||
|
||||
This set of overrides are used by GT::SQL::Creator when the ::create method is
|
||||
called. They are called just prior and then after the create table sql query has
|
||||
been executed.
|
||||
|
||||
=over 2
|
||||
|
||||
=item pre_create_table
|
||||
|
||||
=item post_create_table
|
||||
|
||||
These functions receive no special parameters. They will receive the data to the
|
||||
table in the $self->{table} property.
|
||||
|
||||
=back
|
||||
|
||||
This next set of functions take place in GT::SQL::Editor.
|
||||
|
||||
=over 2
|
||||
|
||||
=item drop_search_driver
|
||||
|
||||
This method receives no special parameters but is responsible for removing all
|
||||
indexes and "things" associated with the indexing schema.
|
||||
|
||||
=item add_search_driver
|
||||
|
||||
Receives no extra parameters. Creates all indexes and does all actions required
|
||||
to initialize indexing scheme.
|
||||
|
||||
=item pre_add_column
|
||||
|
||||
=item post_add_column
|
||||
|
||||
The previous two functions are called just before and after a new column is
|
||||
added.
|
||||
|
||||
pre_add_column accepts $name (of column), $col (hashref of column attributes).
|
||||
The method will only be called if the column has a weight associated with it.
|
||||
The function must return a non-zero value if successful. Note that the returned
|
||||
value will be passed into the post_add_column so temporary values can be passed
|
||||
through if required.
|
||||
|
||||
post_add_column accepts $name (of column), $col (hashref of column attributes),
|
||||
$results (of pre_add_column). This method is called just after the column has
|
||||
been inserted into the database.
|
||||
|
||||
=item pre_delete_column
|
||||
|
||||
=item post_delete_column
|
||||
|
||||
These previous functions are called just before and after the sql for a old
|
||||
column is deleted. They must remove all objects and "things" associated with a
|
||||
particular column's index.
|
||||
|
||||
pre_delete_column accepts $name (of column), $col (hashref of column
|
||||
attributes). The method will only be called if the column has a weight
|
||||
associated with it. The function must return a non-zero value if successful.
|
||||
Note that the returned value will be passed into the post_delete_column so
|
||||
temporary values can be passed through if required.
|
||||
|
||||
post_delete_column accepts $name (of column), $col (hashref of column
|
||||
attributes), $results (of pre_add_column). This method is called just after the
|
||||
column has been dropped from the database.
|
||||
|
||||
=item pre_drop_table
|
||||
|
||||
=item post_drop_table
|
||||
|
||||
The two previous methods are used before and after the table is dropped. The
|
||||
methods must remove any tables or "things" related to indexing from the table.
|
||||
|
||||
pre_drop_table receives no arguments. It can find a copy of the current table
|
||||
and columns associated in $self->{table}.
|
||||
|
||||
post_drop_table receives one argument, which is the result of the
|
||||
pre_drop_table.
|
||||
|
||||
=back
|
||||
|
||||
The following set of functions take place in GT::SQL::Table
|
||||
|
||||
=over 2
|
||||
|
||||
=item pre_add_record
|
||||
|
||||
=item post_add_record
|
||||
|
||||
Called just before and after an insert occurs. These functions take the record
|
||||
and indexes them as required.
|
||||
|
||||
pre_add_record will receive one argument, $rec, hashref, which is the record
|
||||
that will be inserted into the database. Table information can be found by
|
||||
accessing $self->{table} Much like the other functions, on success the result
|
||||
will be cached and fed into the post_add_record function.
|
||||
|
||||
post_add_record receives $rec, a hashref to describing the new result, the $sth
|
||||
of the insert query, and the result of the pre_add_record method. The result
|
||||
from $sth->insert_id if there is a ai field will be the new unique primary key.
|
||||
|
||||
=item pre_update_record
|
||||
|
||||
=item post_update_record
|
||||
|
||||
Intercepts the update request before and just after the sql query is executed.
|
||||
This override has the potential of being rather messy. More than one record can
|
||||
be modified in this action and the indexer must work a lot to ensure the
|
||||
database is up to snuff.
|
||||
|
||||
pre_update_record receives two parameters, $set_cond, $where_cond. $set_cond is
|
||||
a hashref containing the new values that must be set, and $where_cond is a
|
||||
GT::SQL::Condition object selecting records to update. The result once again, is
|
||||
cached and if undef is considered an error.
|
||||
|
||||
post_update_record takes the same parameters as pre_update_record, except one
|
||||
extra paremeter, the result of pre_update_record.
|
||||
|
||||
=item pre_delete_record
|
||||
|
||||
=item post_delete_record
|
||||
|
||||
Called just before and after the deletion request for records are called.
|
||||
|
||||
pre_delete_record, has only one parameter, $where, a GT::SQL::Condition object
|
||||
telling which records to delete. The results of this method are passed to
|
||||
post_delete_record.
|
||||
|
||||
post_delete_record, has one addition parameter to pre_delete_record and like
|
||||
most post_ methods, is the result of the pre_delete_record method.
|
||||
|
||||
=item pre_delete_all_records
|
||||
|
||||
=item post_delete_all_records
|
||||
|
||||
These two functions are quite simple, but they are different from drop search
|
||||
driver in that though the records are all dropped, the framework for all the
|
||||
indexing is not dropped as well.
|
||||
|
||||
Neither function is passed any special data, except for post_delete_all_records
|
||||
which receives the rsults of the pre_delete_all_records method.
|
||||
|
||||
=item reindex_all
|
||||
|
||||
This function is sometimes called by the user to refresh the index. The
|
||||
motivation for this, in the case of the INTERNAL driver, is sometimes due to
|
||||
outside manipulation of the database tables, the index can become
|
||||
non-representative of the data in the tables. This method is to force the
|
||||
indexing system to fix errors that have passed.
|
||||
|
||||
=item ok
|
||||
|
||||
This function is called by GT::SQL::Search as a package method,
|
||||
GT::SQL::Search::EXAMPLE::Indexer->ok( $table ); and is passed a table object
|
||||
reference. What this function must do is to return a true or false value that
|
||||
tells the search system if this driver can be used. The MYSQL driver has a good
|
||||
example for this, it tests to ensure that the mysql database system version is
|
||||
at least 3.23.23.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Structure of a Search Driver
|
||||
|
||||
The Searcher is responsible for only one thing, to return results from a query
|
||||
search. You can override the parser, however, subclassing the following methods
|
||||
will have full parsing for all things such as +/-, string parsing and substring
|
||||
matching.
|
||||
|
||||
The structures passed into the methods get a little complicated so beware!
|
||||
|
||||
ALL the following functions receive two parameters, the first is a search
|
||||
parameters detailing the words/phrases to search for, the second parameter is
|
||||
the current result set of IDs => scores.
|
||||
|
||||
There are two types of search parameters, one for words and the other for
|
||||
phrases. The structure is a little messy so I'll detail them here.
|
||||
|
||||
For words, the structure is like the following:
|
||||
|
||||
$word_search = {
|
||||
'word' => {
|
||||
substring => '1', # set to 1 if this is substring match
|
||||
phrase => 0, # not a phrase
|
||||
keyword => 1, # is a keyword
|
||||
mode => '', # can also be must, cannot to mean +/-
|
||||
},
|
||||
'word2' => ...
|
||||
}
|
||||
|
||||
For phrases the structure will become:
|
||||
|
||||
$phrase_search => {
|
||||
'phrase' => {
|
||||
substring => undef # never required
|
||||
phrase => [
|
||||
'word1',
|
||||
'word2',
|
||||
'word3',
|
||||
...
|
||||
], # for searching by indiv word if required
|
||||
keyword => 0, # not a keyword
|
||||
mode => '' # can also be must, cannot
|
||||
},
|
||||
'phrase2' => ...
|
||||
}
|
||||
|
||||
Based on these structures, hopefully it will be easy enough to build whatever is
|
||||
required to grab the appropriate records.
|
||||
|
||||
Finally, the second item passed in will be a hash filled with ID => score values
|
||||
of search results. They look something like this:
|
||||
|
||||
$results = {
|
||||
1 => 56,
|
||||
2 => 31,
|
||||
4 => 6
|
||||
}
|
||||
|
||||
It is important for all the methods to take the results and return the results,
|
||||
as the result set will be daisychained down like a set to be operated on by
|
||||
various searching schemes.
|
||||
|
||||
At the end of the query, the results in this set will be sorted and returned to
|
||||
the user as an sth.
|
||||
|
||||
Operations on this set are preformed by the following five methods.
|
||||
|
||||
=over 2
|
||||
|
||||
=item _query
|
||||
|
||||
This method is called just after all the query string has been parsed and put
|
||||
into their proper buckets. This method is overridden by the INTERNAL driver to
|
||||
decide it wants to switch to the NONINDEX driver for better performance.
|
||||
|
||||
Two parameters are passed in, ( $input, $buckets ). $input is a hash that
|
||||
contains all the form/cgi parameters passed to the $tbl->query function and
|
||||
$buckets is s the structure that is created after the query string is parsed.
|
||||
You may also call $self->SUPER::_query( $input, $buckets ) to pass the request
|
||||
along normally.
|
||||
|
||||
You must return undef or an STH from this function.
|
||||
|
||||
=item _union_query
|
||||
|
||||
This method takes a $word_search and does a simple match query. If it finds
|
||||
records with any of the words included, it will append the results to the list.
|
||||
Passed in is the $results and it must return the altered results set.
|
||||
|
||||
This method must also implement substring searching.
|
||||
|
||||
=item _phrase_query
|
||||
|
||||
Just like the union_query, however it searches based on phrases.
|
||||
|
||||
=item _phrase_intersect_query
|
||||
|
||||
This takes a $phrase_search and a $result as parameters. This method must look
|
||||
to find results that are found within the current result set that have the
|
||||
passed phrases as well. However, if there are no results found, this method can
|
||||
look for more results.
|
||||
|
||||
=item _intersect_query
|
||||
|
||||
Takes two parameters, a $word_search, and $results. Just like the
|
||||
_phrase_intersect query, if there are results already, tries to whittle away the
|
||||
result set. If there are no results, tries to look for results that have all the
|
||||
keywords in a record.
|
||||
|
||||
This method must also implement substring searching.
|
||||
|
||||
=item _disjoin_query
|
||||
|
||||
Takes two parameters, a $word_search, and $results. This will look through the
|
||||
result set and remove all matches to any of the keywords.
|
||||
|
||||
This method must also implement substring searching.
|
||||
|
||||
=item _phrase_disjoin_query
|
||||
|
||||
Two parameters, $phrase_search and $results are passed to this method. This does
|
||||
the exact same thing as _disjoin_query but it looks for phrases.
|
||||
|
||||
=item query
|
||||
|
||||
If you choose to override this method, you will have full control of the query.
|
||||
|
||||
This method accepts a $CGI or a $HASH object and performs the following
|
||||
|
||||
Options:
|
||||
- paging
|
||||
mh : max hits
|
||||
nh : number hit (or page of hits)
|
||||
sb : column to sort by (default is by score)
|
||||
|
||||
- searching
|
||||
ww : whole word
|
||||
ma : 1 => OR match, 0 => AND match, undefined => QUERY
|
||||
substring : search for substrings of words
|
||||
bool : 'and' => and search, 'or' => or search, '' => regular query
|
||||
query : the string of things to ask for
|
||||
|
||||
- filtering
|
||||
field_name : value # Find all rows with field_name = value
|
||||
field_name : ">value" # Find all rows with field_name > value.
|
||||
field_name : "<value" # Find all rows with field_name < value.
|
||||
field_name-gt : value # Find all rows with field_name > value.
|
||||
field_name-lt : value # Find all rows with field_name < value.
|
||||
|
||||
The function must return a STH object. However, you may find useful the
|
||||
GT::SQL::Search::STH object, which will automatically handle mh, nh, and
|
||||
alternative sorting requests. All you will have to do is
|
||||
|
||||
sub query { ... your code ... return $self->sth( $results ); }
|
||||
|
||||
Where results is a hashref containing primarykeyvalue => scorevalues.
|
||||
|
||||
=item alternate_driver_query
|
||||
|
||||
There is no reason to override this method, however, if you would like to use
|
||||
another driver's search instead of the current, this method will let you do so.
|
||||
|
||||
Accepting 2 parameters, ( $drivername, $input ), where $drivername is the name
|
||||
of the driver you'd like to use and $input is the parameters passed to the
|
||||
method. Returned is an $sth value (undef if an error has occurred). This method
|
||||
was used in the INTERNAL driver to shunt to NONINDEXED if it found the search
|
||||
would take too long.
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: Search.pm,v 1.62 2008/09/23 23:55:26 brewt Exp $
|
||||
|
||||
=cut
|
||||
@ -0,0 +1,82 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::Base::Common
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Common.pm,v 1.8 2004/10/13 21:45:02 aki Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base classes upon which all search drivers are based
|
||||
#
|
||||
package GT::SQL::Search::Base::Common;
|
||||
|
||||
use strict;
|
||||
use Exporter;
|
||||
use vars qw/ @ISA @EXPORT $STOPWORDS /;
|
||||
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT = qw( &_tokenize &_check_word $STOPWORDS );
|
||||
|
||||
$STOPWORDS = { map { $_ => 1 } qw/
|
||||
of about or all several also she among since an some and such are than
|
||||
as that at the be them because there been these between they both this
|
||||
but those by to do toward during towards each upon either for from was
|
||||
had were has what have when he where her which his while however with if
|
||||
within in would into you your is it its many more most must on re it
|
||||
test not above add am pm jan january feb february mar march apr april
|
||||
may jun june jul july aug august sep sept september oct october nov
|
||||
november dec december find & > < we http com www inc other
|
||||
including
|
||||
/ };
|
||||
|
||||
sub _tokenize {
|
||||
#--------------------------------------------------------------------------------
|
||||
# takes a strings and chops it up into little bits
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
my ( @words, $i, %rejected, $word, $code );
|
||||
|
||||
# split on any non-word (includes accents) characters
|
||||
@words = split /[^\w\x80-\xFF\-]+/, lc $text;
|
||||
$self->debug_dumper( "Words: ", \@words ) if ($self->{_debug});
|
||||
|
||||
# drop all words that are too small, etc.
|
||||
$i = 0;
|
||||
while ( $i <= $#words ) {
|
||||
$word = $words[ $i ];
|
||||
if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or
|
||||
(length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or
|
||||
(length($word) > $self->{max_word_size} and $code = 'TOOBIG')) {
|
||||
splice( @words, $i, 1 );
|
||||
$rejected{$word} = $self->{'rejections'}->{$code};
|
||||
}
|
||||
else {
|
||||
$i++; # Words ok.
|
||||
}
|
||||
}
|
||||
$self->debug_dumper( "Accepted Words: ", \@words ) if ($self->{_debug});
|
||||
$self->debug_dumper( "Rejected Words: ", \%rejected ) if ($self->{_debug});
|
||||
|
||||
return ( \@words, \%rejected );
|
||||
}
|
||||
|
||||
sub _check_word {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns an error code if it is an invalid word, otherwise returns nothing.
|
||||
#
|
||||
my $self = shift;
|
||||
my $word = shift;
|
||||
my $code;
|
||||
if ((exists $self->{stopwords}{$word} and ($code = 'STOPWORD')) or
|
||||
(length($word) < $self->{min_word_size} and $code = 'TOOSMALL' ) or
|
||||
(length($word) > $self->{max_word_size} and $code = 'TOOBIG')) {
|
||||
return $code;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,78 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::Base::Indexer
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Indexer.pm,v 1.4 2004/01/13 01:35:19 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
# Description:
|
||||
#
|
||||
#
|
||||
|
||||
package GT::SQL::Search::Base::Indexer;
|
||||
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
|
||||
use GT::Base;
|
||||
use GT::SQL::Search::Base::Common;
|
||||
|
||||
#--------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
|
||||
@ISA = qw/GT::Base GT::SQL::Search::Base::Common/;
|
||||
$ATTRIBS = {
|
||||
driver => undef,
|
||||
stopwords => $STOPWORDS,
|
||||
rejections => {
|
||||
STOPWORD => "is a stopword",
|
||||
TOOSMALL => "is too small a word",
|
||||
TOOBIG => "is too big a word"
|
||||
},
|
||||
table => '',
|
||||
init => 0,
|
||||
debug => 0,
|
||||
min_word_size => 3,
|
||||
max_word_size => 50,
|
||||
};
|
||||
|
||||
sub drop_search_driver { 1 }
|
||||
sub add_search_driver { 1 }
|
||||
|
||||
# found in GT::SQL::Creator
|
||||
sub pre_create_table { 1 }
|
||||
sub post_create_table { 1 }
|
||||
|
||||
# GT::SQL::Editor
|
||||
sub pre_add_column { 1 }
|
||||
sub post_add_column { 1 }
|
||||
|
||||
sub pre_delete_column { 1 }
|
||||
sub post_delete_column { 1 }
|
||||
|
||||
sub pre_drop_table { 1 }
|
||||
sub post_drop_table { 1 }
|
||||
|
||||
# GT::SQL::Table
|
||||
sub pre_add_record { 1 }
|
||||
sub post_add_record { 1 }
|
||||
|
||||
sub pre_update_record { 1 }
|
||||
sub post_update_record { 1 }
|
||||
|
||||
sub pre_delete_record { 1 }
|
||||
sub post_delete_record { 1 }
|
||||
|
||||
sub pre_delete_all_records { 1 }
|
||||
sub post_delete_all_records { 1 }
|
||||
|
||||
sub driver_ok { 1 }
|
||||
|
||||
sub reindex_all { 1 }
|
||||
|
||||
1;
|
||||
287
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/STH.pm
Normal file
287
site/slowtwitch.com/cgi-bin/articles/GT/SQL/Search/Base/STH.pm
Normal file
@ -0,0 +1,287 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::STH
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: STH.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::SQL::Search::STH;
|
||||
#--------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG $ERRORS $ERROR_MESSAGE /;
|
||||
use GT::Base;
|
||||
|
||||
@ISA = ('GT::Base');
|
||||
$ATTRIBS = {
|
||||
'_debug' => 0,
|
||||
'sth' => undef,
|
||||
'results' => {},
|
||||
'db' => undef,
|
||||
'table' => undef,
|
||||
'index' => 0,
|
||||
'order' => [],
|
||||
'sb' => 'score',
|
||||
'so' => '',
|
||||
'score_col' => 'SCORE',
|
||||
'score_sort'=> 0,
|
||||
'nh' => 0,
|
||||
'mh' => 0
|
||||
};
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$ERRORS = {
|
||||
BADSB => 'Invalid character found in so: "%s"',
|
||||
};
|
||||
|
||||
sub init {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
# setup the options
|
||||
$self->set(@_);
|
||||
|
||||
# correct a few of the values
|
||||
--$self->{nh} if $self->{nh};
|
||||
|
||||
my $sth;
|
||||
my $results = $self->{results};
|
||||
$self->{rows} = scalar( $results ? keys %{$results} : 0 );
|
||||
|
||||
# if we have asked to have sorting by another column (non score), create the part of the query that handles taht
|
||||
$self->debug( "Setting up sorting for GT::SQL::Search::STH" ) if ($self->{_debug});
|
||||
my $sb;
|
||||
|
||||
# clean up the sort by columns.
|
||||
unless ($self->{'score_sort'}) {
|
||||
$sb = GT::SQL::Search::Base::Search->clean_sb($self->{sb}, $self->{so});
|
||||
}
|
||||
|
||||
# setup the max hits and the offsets
|
||||
$self->{index} = $self->{nh} * $self->{mh} || 0;
|
||||
$self->{max_index} = $self->{index} + $self->{mh} - 1; # index + mh is the first record which should not be returned.
|
||||
|
||||
if ( $self->{max_index} > $self->{rows} ) {
|
||||
$self->{max_index} = $self->{rows};
|
||||
$self->{rows} = $self->{rows} - $self->{index};
|
||||
$self->{rows} < 0 ? $self->{rows} = 0 : 0;
|
||||
}
|
||||
|
||||
else {
|
||||
$self->{rows} = $self->{mh};
|
||||
}
|
||||
|
||||
# if we are sorting by another column, handle that
|
||||
if ( $sb and (keys %{$self->{results}})) {
|
||||
my ( $table, $pk ) = $self->_table_info();
|
||||
my ( $query, $where, $st, $limit );
|
||||
|
||||
$where = qq!$pk in(! . join( ",", keys %{$self->{results}}) . ')';
|
||||
$self->{mh} and $limit = qq!LIMIT $self->{index}, $self->{rows}!;
|
||||
$query = qq!
|
||||
SELECT $pk
|
||||
FROM $table
|
||||
WHERE $where
|
||||
$sb
|
||||
$limit
|
||||
!;
|
||||
$self->debug( "Row fetch query: $query" ) if ($self->{_debug});
|
||||
$sth = $self->{table}->{driver}->prepare( $query );
|
||||
$sth->execute();
|
||||
|
||||
# fix the counts
|
||||
$self->{index} = 0;
|
||||
$self->{max_hits} = $self->{rows};
|
||||
|
||||
# now return them
|
||||
my $order = $sth->fetchall_arrayref();
|
||||
$sth->finish();
|
||||
|
||||
$self->{'order'} = [ map { $_->[0] } @{$order} ];
|
||||
}
|
||||
else {
|
||||
$self->{'order'} = [ sort {
|
||||
( $results->{$b} || return 0 ) <=> ( $results->{$a} || 0 )
|
||||
} keys %{$results} ];
|
||||
$self->debug_dumper( "Results will be presented in the following order: ", $self->{'order'} ) if ($self->{_debug});
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub cache_results {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $results = $self->{'results'};
|
||||
my ($sth, @records, $i, %horder, @order, $in_list);
|
||||
my $table = $self->{table};
|
||||
my $tname = $table->name();
|
||||
my ($pk) = $self->{table}->pk;
|
||||
|
||||
use GT::SQL::Condition;
|
||||
|
||||
# we know what we're doing here so shut off warns (complains about uninit'd values in range
|
||||
# if thee aren't enough elements in the order array)
|
||||
my $w = $^W; $^W = 0;
|
||||
@order = grep $_, @{$self->{'order'} || []}[$self->{index}..$self->{max_index}] or return [];
|
||||
$^W = $w;
|
||||
|
||||
$i = 0; %horder = ( map { ( $_ => $i++) } @order );
|
||||
$in_list = join ( ",", @order );
|
||||
my $query = qq|
|
||||
SELECT *
|
||||
FROM
|
||||
$tname
|
||||
WHERE
|
||||
$pk IN($in_list)
|
||||
|;
|
||||
|
||||
# the following is left commented out as...
|
||||
# if $tbl->select is used $table->hits() will not
|
||||
# return an accurate count of the number of all the hits. instead, will return
|
||||
# a value up to mh. $tbl->hits() is important because the value is used
|
||||
# in toolbar calculations
|
||||
#
|
||||
# $sth = $table->select( GT::SQL::Condition->new( $pk, 'IN', \"($in_list)" ) );
|
||||
$sth = $table->do_query( $query );
|
||||
|
||||
while ( my $href = $sth->fetchrow_hashref() ) {
|
||||
$records[$horder{$href->{$pk}}] = \%$href
|
||||
}
|
||||
|
||||
return \@records;
|
||||
|
||||
}
|
||||
|
||||
sub fetchrow_array {
|
||||
#--------------------------------------------------------------------------------
|
||||
return @{ $_[0]->fetchrow_arrayref() || [] };
|
||||
}
|
||||
|
||||
sub fetchrow_arrayref {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $records = $self->{cache} ||= $self->cache_results;
|
||||
my $href = shift @$records or return;
|
||||
return $self->_hash_to_array($href);
|
||||
}
|
||||
|
||||
sub fetchrow_hashref {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
my $results = $self->{'results'};
|
||||
my $records = $self->{cache} ||= $self->cache_results;
|
||||
my $table = $self->{table};
|
||||
my ($pk) = $self->{table}->pk;
|
||||
|
||||
my $href = shift @$records or return;
|
||||
|
||||
$href->{$self->{'score_col'}} = ( $self->{score} = $results->{$href->{$pk}} );
|
||||
|
||||
return $href;
|
||||
|
||||
}
|
||||
|
||||
sub fetchall_hashref {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my @results;
|
||||
while (my $res = $self->fetchrow_hashref) {
|
||||
push @results, $res;
|
||||
}
|
||||
return \@results;
|
||||
}
|
||||
|
||||
sub fetchall_list {
|
||||
#--------------------------------------------------------------------------------
|
||||
return { map { @$_ } @{shift->fetchall_arrayref} }
|
||||
}
|
||||
|
||||
sub fetchall_arrayref {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
|
||||
$self->{order} or return [];
|
||||
my $results = $self->{results};
|
||||
my ($pk) = $self->{table}->pk;
|
||||
my $scol = $self->{score_col};
|
||||
|
||||
|
||||
if (!$self->{allref_cache}) {
|
||||
$self->{allref_cache} ||= $self->cache_results;
|
||||
|
||||
for my $i ( 0 .. $#{$self->{allref_cache}} ) {
|
||||
my $element = $self->{allref_cache}->[$i];
|
||||
if ( $_[0] eq 'HASH' ) {
|
||||
$element->{$scol} = $results->{$element->{$pk}};
|
||||
}
|
||||
else {
|
||||
$element->{$scol} = $self->_hash_to_array( $element->{$scol} );
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
my $records = $self->{allref_cache};
|
||||
|
||||
return $records;
|
||||
}
|
||||
|
||||
sub score {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{score};
|
||||
}
|
||||
|
||||
sub _hash_to_array {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $href = shift or return;
|
||||
|
||||
my $results = $self->{'results'};
|
||||
my $table = $self->{table};
|
||||
my $cols = $table->cols();
|
||||
my $ordercols = ( $self->{ordercols} ||= [ sort { $cols->{$a}->{pos} <=> $cols->{$b}->{pos} } keys %$cols ] );
|
||||
my ($pk) = $self->{table}->pk;
|
||||
my $aref = [ map { $href->{$_} } @$ordercols, ( $self->{score} = $results->{$href->{$pk}} ) ];
|
||||
|
||||
return $aref;
|
||||
}
|
||||
|
||||
sub rows {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
return $self->{rows};
|
||||
}
|
||||
|
||||
sub _table_info {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL');
|
||||
my ($pk) = $self->{table}->pk;
|
||||
return ( $table, $pk );
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->{'sth'} and $self->{'sth'}->finish();
|
||||
}
|
||||
|
||||
sub debug_dumper {
|
||||
#--------------------------------------------------------------------------------
|
||||
# calls debug but also dumps all the messages
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
my $level = ref $_[0] ? 1 : shift;
|
||||
|
||||
if ( $self->{_debug} >= $level ) {
|
||||
require GT::Dumper;
|
||||
$self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,572 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::Base
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Search.pm,v 1.25 2004/08/28 03:53:46 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Base classes upon which all search drivers are based
|
||||
#
|
||||
|
||||
package GT::SQL::Search::Base::Search;
|
||||
|
||||
|
||||
use strict;
|
||||
use vars qw/ @ISA $ATTRIBS $VERSION $DEBUG $AUTOLOAD /;
|
||||
use GT::Base;
|
||||
use GT::SQL::Search::Base::Common;
|
||||
@ISA = qw( GT::Base GT::SQL::Search::Base::Common);
|
||||
|
||||
#--------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/;
|
||||
@ISA = qw/ GT::Base /;
|
||||
|
||||
$ATTRIBS = {
|
||||
'stopwords' => $STOPWORDS,
|
||||
'mh' => 25,
|
||||
'nh' => 1,
|
||||
'ww' => undef,
|
||||
'ma' => undef,
|
||||
'bool' => undef,
|
||||
'substring' => 0,
|
||||
'query' => '',
|
||||
'sb' => 'score',
|
||||
'so' => '',
|
||||
'score_col' => 'SCORE',
|
||||
'score_sort'=> 0,
|
||||
'debug' => 0,
|
||||
'_debug' => 0,
|
||||
|
||||
# query related
|
||||
'db' => undef,
|
||||
'table' => undef,
|
||||
'filter' => undef,
|
||||
'callback' => undef,
|
||||
|
||||
# strict matching of indexed words, accents on words do count
|
||||
'sm' => 0,
|
||||
'min_word_size' => 3,
|
||||
'max_word_size' => 50,
|
||||
};
|
||||
|
||||
sub init {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Initialises the Search object
|
||||
#
|
||||
my $self = shift;
|
||||
my $input = $self->common_param(@_);
|
||||
|
||||
$self->set($input);
|
||||
|
||||
# now handle filters...,
|
||||
my $tbl = $self->{table};
|
||||
my $cols = $tbl->cols();
|
||||
my %filters = map {
|
||||
(my $tmp = $_) =~ s/-[lg]t$//;
|
||||
exists $cols->{$tmp} ? ($_ => $input->{$_}) : ()
|
||||
} keys %{$input};
|
||||
|
||||
if ( keys %filters ) {
|
||||
$self->debug_dumper( "INIT: Creating Filters: ", \%filters ) if ( $self->{_debug} );
|
||||
$self->filter(\%filters);
|
||||
}
|
||||
|
||||
$self->{table}->connect;
|
||||
}
|
||||
|
||||
sub query {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Returns a sth based on a query
|
||||
#
|
||||
# Options:
|
||||
# - paging
|
||||
# mh : max hits
|
||||
# nh : number hit (or page of hits)
|
||||
#
|
||||
# - searching
|
||||
# ww : whole word
|
||||
# ma : 1 => OR match, 0 => AND match, undefined => QUERY
|
||||
# substring : search for substrings of words
|
||||
# bool : 'and' => and search, 'or' => or search, '' => regular query
|
||||
# query : the string of things to ask for
|
||||
#
|
||||
# - filtering
|
||||
# field_name : value # Find all rows with field_name = value
|
||||
# field_name : ">value" # Find all rows with field_name > value.
|
||||
# field_name : "<value" # Find all rows with field_name < value.
|
||||
# field_name-gt : value # Find all rows with field_name > value.
|
||||
# field_name-lt : value # Find all rows with field_name < value.
|
||||
#
|
||||
# Parameters:
|
||||
# ( $CGI ) : a single cgi object
|
||||
# ( $HASH ) : a hash of the parameters
|
||||
#
|
||||
my $self = shift;
|
||||
# find out what sort of a parameter we're dealing with
|
||||
my $input = $self->common_param(@_);
|
||||
|
||||
# add additional parameters if required
|
||||
foreach my $parameter ( keys %{$ATTRIBS} ) {
|
||||
if ( not exists $input->{$parameter} ) {
|
||||
$input->{$parameter} = $self->{$parameter};
|
||||
}
|
||||
}
|
||||
|
||||
# parse query...,
|
||||
$self->debug( "Search Query: $$input{query}", 1 ) if ($self->{_debug});
|
||||
my ( $query, $rejected ) = $self->_parse_query_string( $input->{'query'} );
|
||||
|
||||
$self->{'rejected_keywords'} = $rejected;
|
||||
|
||||
# setup the additional input parameters
|
||||
$query = $self->_preset_options( $query, $input );
|
||||
|
||||
$self->debug_dumper( "Set the pre-options: ", $query ) if ($self->{_debug});
|
||||
|
||||
# now sort into distinct buckets
|
||||
my $buckets = &_create_buckets( $query );
|
||||
$self->debug_dumper( "Created Buckets for querying: ", $buckets ) if ($self->{_debug});
|
||||
|
||||
return $self->_query($input, $buckets);
|
||||
}
|
||||
|
||||
sub _query {
|
||||
#--------------------------------------------------------------------------------
|
||||
my ( $self, $input, $buckets ) = @_;
|
||||
|
||||
# now handle the separate possibilities
|
||||
my $results = {};
|
||||
|
||||
# query can have phrases
|
||||
$results = $self->_phrase_query( $buckets->{phrases}, $results );
|
||||
$self->debug_dumper("Did phrase union query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query have keywords
|
||||
$results = $self->_union_query( $buckets->{keywords}, $results );
|
||||
$self->debug_dumper("Did keyword union query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query must have phrases
|
||||
$results = $self->_phrase_intersect_query( $buckets->{phrases_must}, $results );
|
||||
$self->debug_dumper("Did phrase intersect query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query must have keywords
|
||||
$results = $self->_intersect_query( $buckets->{keywords_must}, $results );
|
||||
$self->debug_dumper("Did keyword intersect query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query cannot have keywords
|
||||
$results = $self->_disjoin_query( $buckets->{keywords_cannot}, $results );
|
||||
$self->debug_dumper("Did keyword disjoin query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# query cannot have phrases
|
||||
$results = $self->_phrase_disjoin_query( $buckets->{phrases_cannot}, $results);
|
||||
$self->debug_dumper("Did phrase disjoin query. Current result set and scores: ", $results ) if ($self->{_debug});
|
||||
|
||||
# now handle filters
|
||||
my $cols = $self->{'table'}->cols();
|
||||
my %filters = map {
|
||||
(my $tmp = $_) =~ s/-[lg]t$//;
|
||||
$cols->{$tmp} ? ($_ => $input->{$_}) : ()
|
||||
} keys %{$input};
|
||||
|
||||
if (keys %filters) {
|
||||
$self->debug( "Creating Filters: ", \%filters ) if ($self->{_debug});
|
||||
$results = $self->filter(\%filters, $results);
|
||||
}
|
||||
elsif ($self->{filter}) {
|
||||
$self->debug( "Filtering results", $self->{filter} ) if ($self->{_debug});
|
||||
$results = $self->_filter_query( $self->{filter}, $results );
|
||||
}
|
||||
else {
|
||||
$self->debug( "No filters being used.") if ($self->{_debug});
|
||||
}
|
||||
|
||||
# now this query should probably clear the filters once it's been used, so i'll dothat here
|
||||
$self->{filter} = undef;
|
||||
|
||||
# now run through a callback function if needed.
|
||||
if ($self->{callback}) {
|
||||
unless (ref $self->{callback} and ref $self->{callback} eq 'CODE') {
|
||||
return $self->error ('BADARGS', 'FATAL', "callback '$self->{callback}' must be a code ref!");
|
||||
}
|
||||
$self->debug_dumper ("Running results through callback. Had: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
|
||||
$results = $self->{callback}->($self, $results);
|
||||
$self->debug_dumper ("New result set: " . scalar (keys %$results) . " results.", $results) if ($self->{_debug});
|
||||
}
|
||||
|
||||
# so how many hits did we get?
|
||||
$self->{table}->{last_hits} = ( $self->{rows} = scalar($results ? keys %{$results} : ()) );
|
||||
|
||||
# and now create a search sth object to handle all this
|
||||
return $self->sth( $results );
|
||||
}
|
||||
|
||||
sub sth {
|
||||
#--------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $results = shift;
|
||||
|
||||
require GT::SQL::Search::Base::STH;
|
||||
my $sth = GT::SQL::Search::STH->new(
|
||||
'results' => $results,
|
||||
'db' => $self->{table}->{driver},
|
||||
# pass the following attributes down to the STH handler
|
||||
map({ ($_ => $self->{$_}) } qw/ table sb so score_col score_sort nh mh rows _debug /)
|
||||
);
|
||||
|
||||
return $sth;
|
||||
}
|
||||
|
||||
sub rows {
|
||||
#--------------------------------------------------------------------------------
|
||||
# after a query is run, returns the number of rows
|
||||
my $self = shift;
|
||||
return $self->{rows} || 0;
|
||||
}
|
||||
|
||||
sub _add_filters {
|
||||
#--------------------------------------------------------------------------------
|
||||
# creates the filter object
|
||||
my $self = shift;
|
||||
my $filter;
|
||||
|
||||
# find out how we're calling the parameters
|
||||
if ( ref $_[0] eq 'GT::SQL::Condition' ) {
|
||||
$filter = shift;
|
||||
}
|
||||
elsif ( ref $_[0] eq 'HASH' ) {
|
||||
|
||||
|
||||
# setup the query condition using the build_query condition method
|
||||
# build the condition object
|
||||
my %opts = %{ shift() || {} };
|
||||
delete $opts{query};
|
||||
|
||||
$filter = $self->{table}->build_query_cond( \%opts, $self->{table}{schema}{cols} );
|
||||
|
||||
}
|
||||
else {
|
||||
return $self->error ('BADARGS', 'FATAL', "Invalid argument: $_[0] passed to _add_filter");
|
||||
}
|
||||
|
||||
# Use ref, as someone can pass in filter => 1 and mess things up.
|
||||
|
||||
ref $self->{filter} ? $self->{filter}->add ($filter) : ($self->{filter} = $filter);
|
||||
$self->debug_dumper( "Filters: ", $self->{filter} ) if ($self->{_debug});
|
||||
|
||||
return $self->{filter};
|
||||
|
||||
}
|
||||
|
||||
sub _preset_options {
|
||||
#--------------------------------------------------------------------------------
|
||||
# sets up word parameters
|
||||
my $self = shift;
|
||||
my $query = shift or return;
|
||||
my $input = shift or return $query;
|
||||
|
||||
# whole word searching
|
||||
if ( defined $input->{'ww'} or defined $self->{'ww'}) {
|
||||
if ( defined $input->{'ww'} ? $input->{'ww'} : $self->{'ww'} ) {
|
||||
for ( keys %{$query} ) { $query->{$_}->{mode} = 'substring'; }
|
||||
}
|
||||
}
|
||||
|
||||
# substring searching
|
||||
if ( defined $input->{'substring'} or defined $self->{'substring'}) {
|
||||
if ( defined $input->{'substring'} ? $input->{'substring'} : $self->{'substring'} ) {
|
||||
for ( keys %{$query} ) { $query->{$_}->{'substring'} = 1; }
|
||||
}
|
||||
}
|
||||
|
||||
if ( defined $input->{'ma'} or defined $self->{'ma'} ) {
|
||||
# each keyword must be included
|
||||
if ( defined $input->{'ma'} ? $input->{'ma'} : $self->{'ma'} ) {
|
||||
for ( keys %{$query} ) {
|
||||
next if $query->{$_}->{mode} eq 'cannot';
|
||||
$query->{$_}->{mode} = 'must';
|
||||
}
|
||||
}
|
||||
# each word can be included but is not necessary
|
||||
else {
|
||||
for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; }
|
||||
}
|
||||
}
|
||||
|
||||
# some more and or searches, only if user hasn't put +word -word
|
||||
if ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'and' ) {
|
||||
unless ($input->{query} =~ /(?:^|\s)[+-]\w/) {
|
||||
for ( keys %{$query} ) {
|
||||
next if $query->{$_}->{mode} eq 'cannot';
|
||||
$query->{$_}->{mode} = 'must';
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( lc( $input->{'bool'} || $self->{'bool'} ) eq 'or' ) {
|
||||
unless ($input->{query} =~ /(?:^|\s)[+-]\w/) {
|
||||
for ( keys %{$query} ) { $query->{$_}->{mode} = 'can'; }
|
||||
}
|
||||
}
|
||||
|
||||
return $query;
|
||||
}
|
||||
|
||||
sub _phrase_query { $_[1] }
|
||||
sub _union_query { $_[1] }
|
||||
sub _phrase_intersect_query { $_[1] }
|
||||
sub _intersect_query { $_[1] }
|
||||
sub _disjoin_query { $_[1] }
|
||||
sub _phrase_disjoin_query { $_[1] }
|
||||
|
||||
sub filter {
|
||||
#--------------------------------------------------------------------------------
|
||||
# adds a filter
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# add filters..,
|
||||
my $filters = $self->_add_filters( shift );
|
||||
my $results = shift;
|
||||
|
||||
# see if we need to execute a search, otherwise just return the current filterset
|
||||
defined $results or return $results;
|
||||
|
||||
# start doing the filter stuff
|
||||
return $self->_filter_query( $filters, $results );
|
||||
}
|
||||
|
||||
sub _parse_query_string {
|
||||
#------------------------------------------------------------
|
||||
# from Mastering Regular Expressions altered a fair bit
|
||||
# takes a space delimited string and breaks it up.
|
||||
#
|
||||
my $self = shift;
|
||||
my $text = shift;
|
||||
|
||||
my %words = ();
|
||||
my %reject = ();
|
||||
my %mode = (
|
||||
'+' => 'must',
|
||||
'-' => 'cannot',
|
||||
'<' => 'greater',
|
||||
'>' => 'less'
|
||||
);
|
||||
|
||||
# work on the individual elements
|
||||
my @new = ();
|
||||
while ( $text =~ m{
|
||||
# the first part groups the phrase inside the quotes.
|
||||
# see explanation of this pattern in MRE
|
||||
([+-]?"[^\"\\]*(?:\\.[^\"\\]*)*)" ?
|
||||
| (\+?[\w\x80-\xFF\-\*]+),?
|
||||
| ' '
|
||||
}gx ) {
|
||||
|
||||
my $match = lc $+;
|
||||
|
||||
# strip out buffering spaces
|
||||
$match =~ s/^\s+//; $match =~ s/\s+$//;
|
||||
|
||||
# don't bother trying if there is nothing there
|
||||
next unless $match;
|
||||
|
||||
# find out the searching mode
|
||||
my ($mode, $substring, $phrase);
|
||||
if (my $m = $mode{substr($match,0,1)}) {
|
||||
$match = substr($match,1);
|
||||
$mode = $m;
|
||||
}
|
||||
|
||||
# do we need to substring match?
|
||||
if ( substr( $match, -1, 1 ) eq "*" ) {
|
||||
$match = substr($match,0,length($match)-1);
|
||||
$substring = 1;
|
||||
}
|
||||
|
||||
# find out if we're dealing with a phrase
|
||||
if ( substr($match,0,1) eq '"' ) {
|
||||
$self->debug( "Dealing with a phrase: $match" ) if ($self->{_debug});
|
||||
|
||||
$match = substr($match,1);
|
||||
|
||||
# however, we want to make sure it's a phrase and not something else
|
||||
my ( $word_list, $rejected ) = $self->_tokenize( $match );
|
||||
$self->debug_dumper( "Phrase reduced to: ", $word_list ) if ($self->{_debug});
|
||||
$self->debug_dumper( "Phrase words rejected: ", $rejected ) if ($self->{_debug});
|
||||
my $word_count = @$word_list;
|
||||
|
||||
if ( $word_count > 1 ) { $phrase = $word_list } # ok, standard phrase
|
||||
elsif ($word_count == 1) { $match = $word_list->[0] } # just a standard word, don't worry about searching by phrase
|
||||
}
|
||||
|
||||
# make sure we can use this word
|
||||
if ( not $phrase and my $code = $self->_check_word( $match, $self->{stopwords} ) ) {
|
||||
$reject{ $match } = $code;
|
||||
next;
|
||||
}
|
||||
|
||||
# now, see if we should toss this word
|
||||
$words{$match} = {
|
||||
mode => $mode,
|
||||
phrase => $phrase,
|
||||
substring => $substring,
|
||||
keyword => not $phrase,
|
||||
};
|
||||
}
|
||||
|
||||
# words is a hashref of:
|
||||
# {
|
||||
# word => {
|
||||
# paramaters => 'values'
|
||||
# },
|
||||
# word1 => {
|
||||
# ...
|
||||
# },
|
||||
# ...
|
||||
# }
|
||||
#
|
||||
return( \%words, \%reject );
|
||||
|
||||
}
|
||||
|
||||
|
||||
sub _filter_query {
|
||||
#--------------------------------------------------------------------------------
|
||||
# get the results from the filter
|
||||
#
|
||||
my $self = shift;
|
||||
my $filters = shift;
|
||||
my $results = shift or return {};
|
||||
keys %{$results} or return $results;
|
||||
|
||||
my $table = $self->{table};
|
||||
my $tname = $table->name();
|
||||
|
||||
# setup the where clause
|
||||
my $where = $filters->sql() or return $results;
|
||||
my ($pk) = $table->pk;
|
||||
$where .= qq! AND $pk IN (! . join(',', keys %$results) . ')';
|
||||
|
||||
# now do the filter
|
||||
my $query = qq!
|
||||
SELECT $pk
|
||||
FROM
|
||||
$tname
|
||||
WHERE
|
||||
$where
|
||||
!;
|
||||
$self->debug( "Filter Query: $query" ) if ($self->{_debug});
|
||||
my $sth = $self->{table}->{driver}->prepare($query);
|
||||
$sth->execute();
|
||||
|
||||
# get all the results
|
||||
my $aref = $sth->fetchall_arrayref;
|
||||
return {
|
||||
map {
|
||||
$_->[0] => $results->{$_->[0]}
|
||||
} @$aref
|
||||
};
|
||||
}
|
||||
|
||||
sub _create_buckets {
|
||||
#------------------------------------------------------------
|
||||
# takes the output from _parse_query_string and creates a
|
||||
# bucket hash of all the different types of searching
|
||||
# possible
|
||||
my $query = shift or return;
|
||||
|
||||
my %buckets;
|
||||
|
||||
# put each word in the appropriate hash bucket
|
||||
foreach my $parameter ( keys %{$query} ) {
|
||||
|
||||
my $word_data = $query->{$parameter};
|
||||
|
||||
# the following is slower, however, done that way to be syntatically legible
|
||||
if ( $word_data->{'phrase'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'} =~ /(must|cannot)/ ))) {
|
||||
$buckets{"phrases_$1"}->{$parameter} = $word_data;
|
||||
}
|
||||
elsif ( $word_data->{'phrase'} ) {
|
||||
$buckets{'phrases'}->{$parameter} = $word_data;
|
||||
}
|
||||
elsif ( $word_data->{'keyword'} and ( defined $word_data->{'mode'} and ($word_data->{'mode'}=~ /(must|cannot|greater|less)/) )) {
|
||||
$buckets{"keywords_$1"}->{$parameter} = $word_data;
|
||||
}
|
||||
else {
|
||||
$buckets{'keywords'}->{$parameter} = $word_data;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return \%buckets;
|
||||
}
|
||||
|
||||
sub alternate_driver_query {
|
||||
#--------------------------------------------------------------------------------
|
||||
my ( $self, $drivername, $input ) = @_;
|
||||
|
||||
$drivername = uc $drivername;
|
||||
require GT::SQL::Search;
|
||||
my $driver = GT::SQL::Search->load_search({ %$input, table => $self->{table}, driver => $drivername });
|
||||
my $sth = $driver->query( $input );
|
||||
foreach ( qw( rows rejected_keywords ) ) { $self->{$_} = $driver->{$_}; }
|
||||
return $sth;
|
||||
|
||||
}
|
||||
|
||||
sub clean_sb {
|
||||
# -------------------------------------------------------------------------------
|
||||
# Convert the sort by, sort order into an sql string.
|
||||
#
|
||||
my ($class, $sb, $so) = @_;
|
||||
my $output = '';
|
||||
|
||||
return $output unless ($sb);
|
||||
|
||||
# Remove score attribute, used only for internal indexes.
|
||||
$sb =~ s/^\s*score\b//;
|
||||
$sb =~ s/,?\s*\bscore\b//;
|
||||
|
||||
if ($sb and not ref $sb) {
|
||||
if ($sb =~ /^[\w\s,]+$/) {
|
||||
if ($sb =~ /\s(?:asc|desc)/i) {
|
||||
$output = 'ORDER BY ' . $sb;
|
||||
}
|
||||
else {
|
||||
$output = 'ORDER BY ' . $sb . ' ' . $so;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$class->error('BADSB', 'WARN', $sb);
|
||||
}
|
||||
}
|
||||
elsif (ref $sb eq 'ARRAY') {
|
||||
foreach ( @$sb ) {
|
||||
/^[\w\s,]+$/ or $class->error( 'BADSB', 'WARN', $sb ), next;
|
||||
}
|
||||
$output = 'ORDER BY ' . join(',', @$sb);
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub debug_dumper {
|
||||
#--------------------------------------------------------------------------------
|
||||
# calls debug but also dumps all the messages
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
my $level = ref $_[0] ? 1 : defined $_[0] ? shift : 0;
|
||||
|
||||
if ( $self->{_debug} >= $level ) {
|
||||
require GT::Dumper;
|
||||
$self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ )) if ($self->{_debug});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,411 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Search::INTERNAL::Indexer
|
||||
# Author: Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Indexer.pm,v 1.11 2004/01/13 01:35:19 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ====================================================================
|
||||
#
|
||||
|
||||
package GT::SQL::Search::INTERNAL::Indexer;
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
use strict;
|
||||
use vars qw/@ISA $ATTRIBS $VERSION $DEBUG /;
|
||||
use GT::SQL::Search::Base::Indexer;
|
||||
@ISA = qw/ GT::SQL::Search::Base::Indexer /;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.11 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
sub load {
|
||||
shift;
|
||||
return GT::SQL::Search::INTERNAL::Indexer->new(@_)
|
||||
}
|
||||
|
||||
sub drop_search_driver {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $table = $self->{table}->name;
|
||||
my $rc1 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Word_List");
|
||||
my $rc2 = $self->{table}->do_query(qq!DROP TABLE $table! ."_Score_List");
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub add_search_driver {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $name = $self->{table}->name;
|
||||
|
||||
# first create the table that handles the words.
|
||||
my $creator = $self->{table}->creator ( $name . "_Word_List" );
|
||||
$creator->cols(
|
||||
Word_ID => {
|
||||
pos => 1,
|
||||
type => 'int',
|
||||
not_null => 1,
|
||||
unsigned => 1
|
||||
},
|
||||
Word => {
|
||||
pos => 2,
|
||||
type => 'varchar',
|
||||
not_null=> 1,
|
||||
size => '50'
|
||||
},
|
||||
Frequency => {
|
||||
pos => 3,
|
||||
type => 'int',
|
||||
not_null=> 1
|
||||
}
|
||||
);
|
||||
$creator->pk('Word_ID');
|
||||
$creator->ai('Word_ID');
|
||||
$creator->unique({ $name . "_wordndx" => ['Word'] });
|
||||
$creator->create('force') or return;
|
||||
|
||||
# now create the handler for scores
|
||||
$creator = $self->{table}->creator( $name . '_Score_List' );
|
||||
$creator->cols(
|
||||
Word_ID => {
|
||||
pos => 1,
|
||||
type => 'int',
|
||||
not_null => 1,
|
||||
unsigned => 1
|
||||
},
|
||||
Item_ID => {
|
||||
pos => 2,
|
||||
type => 'int',
|
||||
not_null => 1,
|
||||
unsigned => 1
|
||||
},
|
||||
Score => {
|
||||
pos => 3,
|
||||
type => 'int',
|
||||
not_null => 1
|
||||
},
|
||||
Word_Pos => {
|
||||
pos => 4,
|
||||
type => 'int',
|
||||
not_null => 1
|
||||
}
|
||||
);
|
||||
$creator->index({ 'wndx' => ['Word_ID', 'Item_ID', 'Score'], 'itndx' => ['Item_ID'] });
|
||||
$creator->create('force') or return;
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub post_create_table {
|
||||
# ------------------------------------------------------------------------------
|
||||
# creates the index tables..
|
||||
#
|
||||
return $_[0]->add_search_driver(@_);
|
||||
}
|
||||
|
||||
sub post_drop_table {
|
||||
# -------------------------------------------------------
|
||||
# Remove the index tables.
|
||||
#
|
||||
return $_[0]->drop_search_driver(@_);
|
||||
}
|
||||
|
||||
sub init_queries {
|
||||
# -------------------------------------------------------
|
||||
# Pre-load all our queries.
|
||||
#
|
||||
my $self = shift;
|
||||
my $queries = shift;
|
||||
|
||||
my $driver = $self->{table}->{driver} or return $self->error ('NODRIVER', 'FATAL');
|
||||
my $table_name = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL');
|
||||
my $wtable = $table_name . '_Word_List';
|
||||
my $seq = $wtable . '_seq';
|
||||
my $stable = $table_name . '_Score_List';
|
||||
|
||||
my %ai_queries = (
|
||||
ins_word_ORACLE => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES ($seq.NEXTVAL, ?, ?)",
|
||||
ins_word_PG => "INSERT INTO $wtable (Word_ID, Word, Frequency) VALUES (NEXTVAL('$seq'), ?, ?)",
|
||||
ins_word => "INSERT INTO $wtable (Word, Frequency) VALUES (?, ?)"
|
||||
);
|
||||
my %queries = (
|
||||
upd_word => "UPDATE $wtable SET Frequency = ? WHERE Word_ID = ?",
|
||||
sel_word => "SELECT Word_ID,Word,Frequency FROM $wtable WHERE Word = ?",
|
||||
sel_freq => "SELECT Frequency FROM $wtable WHERE Word_ID = ?",
|
||||
del_word => "DELETE FROM $wtable WHERE Word_ID = ?",
|
||||
mod_word => "UPDATE $wtable SET Frequency = Frequency - ? WHERE Word_ID = ?",
|
||||
ins_scor => "INSERT INTO $stable (Word_ID, Item_ID, Score, Word_Pos) VALUES (?, ?, ?, ?)",
|
||||
item_cnt => "SELECT Word_ID, COUNT(*) FROM $stable WHERE Item_ID = ? GROUP BY Word_ID",
|
||||
scr_del => "DELETE FROM $stable WHERE Item_ID = ?",
|
||||
dump_word => "DELETE FROM $wtable",
|
||||
dump_scor => "DELETE FROM $stable"
|
||||
);
|
||||
my $type = uc $self->{table}->{connect}->{driver};
|
||||
$self->{ins_word} = $driver->prepare($ai_queries{"ins_word_$type"} || $ai_queries{"ins_word"});
|
||||
|
||||
# check to see if the table exist
|
||||
$self->{table}->new_table( $wtable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error);
|
||||
$self->{table}->new_table( $stable ) or return $self->error('CANTPREPARE','WARN', 'Loading of table', $GT::SQL::error);
|
||||
|
||||
|
||||
if ($type eq 'MYSQL') {
|
||||
foreach my $query (keys %queries) {
|
||||
$self->{$query} = $driver->prepare_raw ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error);
|
||||
}
|
||||
}
|
||||
else {
|
||||
foreach my $query (keys %queries) {
|
||||
$self->{$query} = $driver->prepare ($queries{$query}) or return $self->error ('CANTPREPARE', 'WARN', $query, $GT::SQL::error);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub post_add_record {
|
||||
# -------------------------------------------------------
|
||||
# indexes a single record
|
||||
my ($self, $rec, $insert_sth ) = @_;
|
||||
|
||||
# Only continue if we have weights and a primary key.
|
||||
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
|
||||
my %weights = $tbl->_weight_cols() or return;
|
||||
my ($pk) = $tbl->pk();
|
||||
my $item_id = ( $tbl->ai() and $insert_sth ) ? $insert_sth->insert_id() : $rec->{$pk};
|
||||
my $index = 0;
|
||||
|
||||
$self->{init} or $self->init_queries;
|
||||
|
||||
# Go through each column and index it.
|
||||
foreach my $column ( keys %weights ) {
|
||||
my ($word_list, $rejected) = $self->_tokenize( $rec->{$column} );
|
||||
$word_list or next;
|
||||
|
||||
# Build a hash of word => frequency.
|
||||
my %words;
|
||||
foreach my $word (@{$word_list}) {
|
||||
$words{$word}++;
|
||||
}
|
||||
|
||||
# Add the words in, or update frequency.
|
||||
my %word_ids = ();
|
||||
while (my ($word, $freq) = each %words) {
|
||||
$self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
my $word_r = $self->{sel_word}->fetchrow_arrayref; # Word_ID, Word, Frequency
|
||||
if ($word_r) {
|
||||
$word_r->[2] += $freq;
|
||||
$word_ids{$word} = $word_r->[0];
|
||||
$self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
else {
|
||||
$self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
$word_ids{$word} = $self->{ins_word}->insert_id();
|
||||
}
|
||||
}
|
||||
# now that we have the word ids, insert each of the word-points
|
||||
my $weight = $weights{$column};
|
||||
foreach my $word ( @{$word_list} ) {
|
||||
$self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
$index++;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub reindex_all {
|
||||
# -------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $table = shift;
|
||||
my $opts = shift;
|
||||
my $tick = $opts->{tick} || 0;
|
||||
my $max = $opts->{max} || 5000;
|
||||
|
||||
my %weights = $self->{table}->_weight_cols() or return;
|
||||
my @weight_list = keys %weights;
|
||||
my @weight_arr = map { $weights{$_} } @weight_list;
|
||||
my ($pk) = $self->{table}->pk();
|
||||
my $index = 0;
|
||||
my $word_id = 1;
|
||||
$self->{init} or $self->init_queries;
|
||||
|
||||
# first nuke the current index
|
||||
$self->dump_index();
|
||||
|
||||
# Go through the table and index each field.
|
||||
my $iterations = 1;
|
||||
my $count = 0;
|
||||
|
||||
while (1) {
|
||||
if ($max) {
|
||||
my $offset = ($iterations-1) * $max;
|
||||
$table->select_options ( "LIMIT $offset,$max");
|
||||
}
|
||||
my $cond = $opts->{cond} || {};
|
||||
my $sth = $table->select($cond, [ $pk, @weight_list] );
|
||||
my $done = 1;
|
||||
|
||||
while ( my $arrayref = $sth->fetchrow_arrayref() ) {
|
||||
# the primary key value
|
||||
my $i = 0;
|
||||
my $item_id = $arrayref->[($i++)];
|
||||
$index = 0;
|
||||
$done = 0;
|
||||
|
||||
# start going through the record data
|
||||
foreach my $weight ( @weight_arr ) {
|
||||
my ($word_list, $junk) = $self->_tokenize( $arrayref->[$i++] );
|
||||
$word_list or next;
|
||||
|
||||
# Build a hash of word => frequency.
|
||||
my %words;
|
||||
foreach my $word (@{$word_list}) {
|
||||
$words{$word}++;
|
||||
}
|
||||
|
||||
# Add the words in, or update frequency.
|
||||
my %word_ids = ();
|
||||
while (my ($word, $freq) = each %words) {
|
||||
$self->{sel_word}->execute($word) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
my $word_r = $self->{sel_word}->fetchrow_arrayref; # WordID,Word,Freq
|
||||
if ($word_r) {
|
||||
$word_r->[2] += $freq;
|
||||
$word_ids{$word} = $word_r->[0];
|
||||
$self->{upd_word}->execute ($word_r->[2], $word_r->[0]) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
else {
|
||||
$self->{ins_word}->execute ($word, $words{$word}) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
$word_ids{$word} = $self->{ins_word}->insert_id();
|
||||
}
|
||||
}
|
||||
# now that we have the word ids, insert each of the word-points
|
||||
foreach my $word ( @{$word_list} ) {
|
||||
$self->{ins_scor}->execute ($word_ids{$word}, $item_id, $weight, $index++) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
$index++;
|
||||
}
|
||||
if ($tick) {
|
||||
$count++;
|
||||
$count % $tick or (print "$count ");
|
||||
$count % ($tick*10) or (print "\n");
|
||||
}
|
||||
}
|
||||
return if ($done);
|
||||
$iterations++;
|
||||
return if (! $max);
|
||||
}
|
||||
}
|
||||
|
||||
sub pre_delete_record {
|
||||
# -------------------------------------------------------
|
||||
# Delete a records index values.
|
||||
#
|
||||
my $self = shift;
|
||||
my $where = shift;
|
||||
|
||||
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
|
||||
my %weights = $tbl->_weight_cols() or return;
|
||||
my ($pk) = $tbl->pk();
|
||||
my $q = $tbl->select( $where, [ $pk ] );
|
||||
|
||||
while ( my $aref = $q->fetchrow_arrayref() ) {
|
||||
my $item_id = $aref->[0] or next;
|
||||
my @weight_list = keys %weights;
|
||||
my $index = 0;
|
||||
$self->{init} or $self->init_queries;
|
||||
|
||||
# Get a frequency count for each word
|
||||
$self->{item_cnt}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
|
||||
# Now go through and either decrement the freq, or remove the entry.
|
||||
while ( my ($word_id, $frequency) = $self->{item_cnt}->fetchrow_array() ) {
|
||||
$self->{sel_freq}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
$self->debug( "Deleting frequencies for $word_id. decreasing by $frequency" ) if ($self->{_debug});
|
||||
if (my $freq = $self->{sel_freq}->fetchrow_arrayref) {
|
||||
if ($freq->[0] == $frequency) {
|
||||
$self->{del_word}->execute($word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
else {
|
||||
$self->{mod_word}->execute($frequency, $word_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
}
|
||||
}
|
||||
# Remove the listings from the scores table.
|
||||
$self->{scr_del}->execute($item_id) or return $self->error ('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub post_update_record {
|
||||
# -------------------------------------------------------
|
||||
my ( $self, $set_cond, $where_cond, $tmp ) = @_;
|
||||
|
||||
# delete the previous record
|
||||
$self->pre_delete_record( $where_cond ) or return;
|
||||
#
|
||||
# the new record
|
||||
my $tbl = $self->{table} or $self->error( 'NODRIVER', 'FATAL' );
|
||||
my $q = $tbl->select( $where_cond );
|
||||
while ( my $href = $q->fetchrow_hashref() ) {
|
||||
$self->post_add_record( $href );
|
||||
}
|
||||
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
sub reindex_record {
|
||||
# -------------------------------------------------------
|
||||
# reindexes a record. basically deletes all associated records from current db abnd does an index.
|
||||
# it's safe to use this
|
||||
my $self = shift;
|
||||
my $rec = shift;
|
||||
|
||||
$self->delete_record($rec);
|
||||
$self->index_record($rec);
|
||||
}
|
||||
|
||||
sub dump_index {
|
||||
# -------------------------------------------------------
|
||||
my $self = shift;
|
||||
$self->{init} or $self->init_queries;
|
||||
|
||||
$self->{dump_word}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
$self->{dump_scor}->execute() or $self->error('CANTEXECUTE', 'WARN', $DBI::errstr);
|
||||
}
|
||||
|
||||
|
||||
sub debug_dumper {
|
||||
# ------------------------------------------------------------------------------
|
||||
# calls debug but also dumps all the messages
|
||||
my $self = shift;
|
||||
my $message = shift;
|
||||
my $level = ref $_[0] ? 1 : shift;
|
||||
|
||||
if ( $self->{_debug} >= $level ) {
|
||||
require GT::Dumper;
|
||||
$self->debug( $message . join( "", map { GT::Dumper::Dumper($_) } @_ ));
|
||||
}
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Calls finish on init queries.
|
||||
#
|
||||
my $self = shift;
|
||||
return unless ($self->{init});
|
||||
$self->{upd_word}->finish;
|
||||
# $self->{ins_word}->finish; will get finished automatically
|
||||
$self->{sel_word}->finish;
|
||||
$self->{sel_freq}->finish;
|
||||
$self->{del_word}->finish;
|
||||
$self->{mod_word}->finish;
|
||||
$self->{ins_scor}->finish;
|
||||
$self->{item_cnt}->finish;
|
||||
$self->{scr_del}->finish;
|
||||
$self->{dump_word}->finish;
|
||||
$self->{dump_scor}->finish;
|
||||
$self->{init} = 0;
|
||||
}
|
||||
|
||||
1;
|
||||
@ -0,0 +1,604 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Indexer
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info : 087,071,086,086,085
|
||||
# $Id: Search.pm,v 1.18 2004/08/28 03:53:47 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Class used to make changes to tables and create tables.
|
||||
#
|
||||
|
||||
package GT::SQL::Search::INTERNAL::Search;
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
use strict;
|
||||
use vars qw/@ISA $VERSION $DEBUG $ATTRIBS /;
|
||||
use GT::SQL::Search::Base::Search;
|
||||
@ISA = qw( GT::SQL::Search::Base::Search );
|
||||
|
||||
# ------------------------------------------------------------------------------
|
||||
# Preamble information related to the object
|
||||
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
# the max number of links that can be handled by UNION before it should simply
|
||||
# shunt the searching pipe to NONINDEXED system
|
||||
'union_shunt_threshold' => '5000',
|
||||
'phrase_shunt_threshold' => '1000',
|
||||
};
|
||||
|
||||
|
||||
################################################################################
|
||||
# Internal functions
|
||||
################################################################################
|
||||
|
||||
sub load {
|
||||
shift;
|
||||
return GT::SQL::Search::INTERNAL::Search->new(@_)
|
||||
}
|
||||
|
||||
sub _query {
|
||||
# ------------------------------------------------------------------------------
|
||||
# this just checks to ensure that the words are not all search keywords
|
||||
#
|
||||
my ( $self, $input, $buckets ) = @_;
|
||||
|
||||
# calculate wordids and frequencies
|
||||
foreach ( keys %$buckets ) {
|
||||
$buckets->{$_} = $self->get_wordids( $buckets->{$_}, ( /phrase/ ? "phrases" : "keywords" ) );
|
||||
}
|
||||
|
||||
# the following is a bit tricky and will be replaced however, if the number
|
||||
# of results from a union is more than the maximum shunt value, it will
|
||||
# simply do a nonindexed query
|
||||
if ( $buckets->{keywords} ) {
|
||||
my $rec = _count_frequencies( $buckets->{keywords} );
|
||||
my $count = 0;
|
||||
foreach ( values %$rec ) { $count += $_; }
|
||||
if ($count > $self->{union_shunt_threshold}) {
|
||||
$self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug});
|
||||
return $self->alternate_driver_query( 'NONINDEXED', $input );
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Now test the phrases. Just due to how the phrase searching works, the queries
|
||||
# can grow in size extremely rapidly, and slowdown the search. So the limit for
|
||||
# phrase searching is separate as it requires a different cutoff value than
|
||||
# the keyword search which is usually much lower!
|
||||
if ($buckets->{phrases}) {
|
||||
foreach my $phrase ( keys %{$buckets->{phrases} || {} } ) {
|
||||
my $rec = _count_frequencies( $buckets->{phrases}->{$phrase}->{word_info} );
|
||||
my ( $count ) = sort values %$rec; # Get smallest frequency.
|
||||
if ( $count > $self->{phrase_shunt_threshold} ) {
|
||||
$self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug});
|
||||
return $self->alternate_driver_query( 'NONINDEXED', $input );
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($buckets->{phrases_must}) {
|
||||
foreach my $phrase ( keys %{$buckets->{phrases_must} || {} } ) {
|
||||
my $rec = _count_frequencies( $buckets->{phrases_must}->{$phrase}->{word_info} );
|
||||
my ( $count ) = sort values %$rec; # Get smallest frequency.
|
||||
if ( $count > $self->{phrase_shunt_threshold} ) {
|
||||
$self->debug_dumper("Too many results using internal search, falling back to nonindexed. Counts are: ", $rec) if ($self->{_debug});
|
||||
return $self->alternate_driver_query( 'NONINDEXED', $input );
|
||||
}
|
||||
}
|
||||
}
|
||||
return $self->SUPER::_query( $input, $buckets );
|
||||
}
|
||||
|
||||
sub _count_frequencies {
|
||||
# ------------------------------------------------------------------------------
|
||||
my $word_info = shift;
|
||||
my $rec = {};
|
||||
foreach my $word ( keys %$word_info ) {
|
||||
my $freq = 0;
|
||||
foreach ( values %{$word_info->{$word}->{word_info}} ) {
|
||||
$freq += $_;
|
||||
}
|
||||
$rec->{$word} = $freq;
|
||||
}
|
||||
|
||||
return $rec;
|
||||
}
|
||||
|
||||
sub _table_names {
|
||||
# ------------------------------------------------------------------------------
|
||||
# return the table names
|
||||
#
|
||||
my $self = shift;
|
||||
my $table = $self->{table}->name() or return $self->error('NOSCHEMA', 'FATAL');
|
||||
my $wtable = $table . '_Word_List';
|
||||
my $stable = $table . '_Score_List';
|
||||
|
||||
return ( $table, $wtable, $stable);
|
||||
}
|
||||
|
||||
sub _word_infos {
|
||||
# ------------------------------------------------------------------------------
|
||||
# get the word ids and frequencies
|
||||
#
|
||||
my $self = shift;
|
||||
my $word_infos = shift;
|
||||
|
||||
my $rec = {};
|
||||
|
||||
foreach my $word ( keys %$word_infos ) {
|
||||
my $wi = $word_infos->{$word}->{word_info};
|
||||
$rec->{$word} = [ map { [ $_, $wi->{$_} ] } keys %$wi ];
|
||||
}
|
||||
|
||||
return $rec;
|
||||
|
||||
}
|
||||
|
||||
sub _union_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Takes a list of words and gets all words that match
|
||||
# returns { itemid -> score } of hits that match
|
||||
#
|
||||
my $self = shift;
|
||||
my $words = shift;
|
||||
my $results = shift || {};
|
||||
my ( $query, $where, $db, $word_infos );
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
|
||||
$db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' );
|
||||
$word_infos = $self->_word_infos( $words ) or return $results;
|
||||
|
||||
return $results unless (keys %{$word_infos});
|
||||
|
||||
$self->debug_dumper( "Getting words: ", $words) if ($self->{_debug});
|
||||
|
||||
# build the where clause
|
||||
my @word_ids;
|
||||
foreach my $word_synonym_list ( values %$word_infos ) {
|
||||
next unless ( $word_synonym_list );
|
||||
foreach my $word_id ( @{$word_synonym_list }) {
|
||||
next unless ( ref $word_id eq 'ARRAY' ); # ensure it's a reference
|
||||
push @word_ids, $word_id->[0]; # we need to shed the word quantities
|
||||
}
|
||||
}
|
||||
|
||||
return $results unless ( @word_ids );
|
||||
$where = 'Word_ID IN(' . join(",", @word_ids) . ")";
|
||||
|
||||
# build the query
|
||||
$query = qq!
|
||||
SELECT Item_ID, SUM(Score)
|
||||
FROM $stable
|
||||
WHERE
|
||||
$where
|
||||
GROUP BY Item_ID
|
||||
!;
|
||||
|
||||
$self->debug( "Union Query: $query" ) if ($self->{_debug});
|
||||
|
||||
# prepare the query
|
||||
my $sth = $db->prepare( $query ) or return;
|
||||
$sth->execute() or return;
|
||||
|
||||
# get the results
|
||||
my %word_infos = $sth->fetchall_list;
|
||||
|
||||
# merge the current result set into found
|
||||
foreach my $item ( keys %{$results} ) {
|
||||
$word_infos{$item} += $results->{$item};
|
||||
};
|
||||
|
||||
return \%word_infos;
|
||||
}
|
||||
|
||||
sub _intersect_query {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Takes a list of words and gets all words that match all the keywords
|
||||
# returns { itemid -> score } of hits that match
|
||||
#
|
||||
my $self = shift;
|
||||
my $words = shift;
|
||||
my $results = shift || {};
|
||||
|
||||
$words or return $results;
|
||||
keys %{$words} or return $results;
|
||||
|
||||
my ( $query, $where, $db, $word_infos, $word_hits );
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
|
||||
# have we left any of our words out?
|
||||
$db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' );
|
||||
$word_infos = $self->_word_infos( $words ) or return {};
|
||||
if ( keys %{$word_infos} < keys %{$words} ) {
|
||||
return {};
|
||||
}
|
||||
|
||||
$self->debug_dumper( "Keyword Intersect words: ", $word_infos ) if ($self->{_debug});
|
||||
|
||||
# take the words and get a hash of the word scores
|
||||
foreach my $word ( keys %{$word_infos} ) {
|
||||
|
||||
my $total_freq = 0;
|
||||
foreach my $word_synonyms ( @{$word_infos->{$word}} ) {
|
||||
$total_freq += $word_synonyms->[1];
|
||||
}
|
||||
|
||||
$word_hits->{$word} = $total_freq or return;
|
||||
|
||||
}
|
||||
|
||||
# so now, sort out the words from lowest frequency to highest frequency
|
||||
my @search_order = sort { $word_hits->{$a} <=> $word_hits->{$b} } keys %{$word_hits};
|
||||
|
||||
$self->debug_dumper( "Searching words in this order: ", \@search_order) if ($self->{_debug});
|
||||
|
||||
# find out how we're going to handle the searching, if the first elements
|
||||
|
||||
################################################################################
|
||||
### The following part is for smaller intersect subsets
|
||||
################################################################################
|
||||
my $intersect = $results;
|
||||
foreach my $word ( @search_order ) {
|
||||
|
||||
# setup the where clause to get all the words associated
|
||||
my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")";
|
||||
|
||||
# setup the intersect for the previous if required. for iterative intersecting
|
||||
if ( keys %{$intersect} ) {
|
||||
$where .= " AND Item_ID in(" . join(",",keys %{$intersect}) . ")";
|
||||
}
|
||||
|
||||
# make the database engine work a little bit
|
||||
$query = qq!
|
||||
SELECT Item_ID, SUM(Score) AS Score
|
||||
FROM $stable
|
||||
WHERE
|
||||
$where
|
||||
GROUP BY Item_ID
|
||||
!;
|
||||
$self->debug( "Intersect Query: $query" ) if ($self->{_debug});
|
||||
my $intersect_sth = $db->prepare( $query );
|
||||
|
||||
$intersect_sth->execute();
|
||||
|
||||
# get a list of all the matches
|
||||
my $matches = $intersect_sth->fetchall_arrayref();
|
||||
|
||||
$self->debug_dumper( "Matches found for $word: ", $matches ) if ($self->{_debug});
|
||||
|
||||
# go through all the matches and intersect them
|
||||
my %tmp = ();
|
||||
foreach my $row ( @{$matches} ) {
|
||||
my ( $itemid, $score ) = @{$row};
|
||||
$intersect->{$itemid} ||= 0;
|
||||
$tmp{ $itemid } = $intersect->{$itemid} + $score;
|
||||
}
|
||||
|
||||
# inform the system of that development
|
||||
%tmp or return;
|
||||
$intersect = \%tmp;
|
||||
}
|
||||
|
||||
return $intersect;
|
||||
}
|
||||
|
||||
sub _disjoin_query {
|
||||
#------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $words = shift;
|
||||
my $results = shift || {};
|
||||
$words or return $results;
|
||||
|
||||
my ( $query, $where, $db, $word_infos, $word_hits );
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
|
||||
$db = $self->{table}->{driver} or return $results;
|
||||
|
||||
# have we left any of our words out?
|
||||
$word_infos = $self->_word_infos( $words ) or return $results;
|
||||
# if ( keys %{$word_infos} < keys %{$words} ) {
|
||||
# return $results;
|
||||
# }
|
||||
|
||||
# take the words and get a hash of the word scores
|
||||
foreach my $word ( keys %{$word_infos} ) {
|
||||
my $total_freq = 0;
|
||||
foreach my $word_synonyms ( $word_infos->{$word} ) {
|
||||
$total_freq += ( $word_synonyms->[0] || 0 );
|
||||
}
|
||||
# if the value is null this mean there is actually no results, whoops!
|
||||
$total_freq and $word_hits->{$word} = $total_freq;
|
||||
}
|
||||
|
||||
# so now, sort out the words from lowest frequency to highest frequency
|
||||
my @search_order = sort { $word_hits->{$b} <=> $word_hits->{$b} } keys %{$word_hits};
|
||||
$self->debug_dumper( "Disjoining words in the following order: ", \@search_order) if ($self->{_debug});
|
||||
|
||||
################################################################################
|
||||
### This following part is for smaller disjoin presets
|
||||
################################################################################
|
||||
foreach my $word ( @search_order ) {
|
||||
|
||||
# setup the where clause to get all the words associated
|
||||
my $where = "Word_ID in(" . join(",", map( { $_->[0] } @{$word_infos->{$word}} )) . ")";
|
||||
|
||||
# setup the intersect for the previous if required. for iterative intersecting
|
||||
if ( keys %{$results} ) {
|
||||
$where .= " AND Item_ID in(" . join(",", keys %{$results}) . ")";
|
||||
}
|
||||
|
||||
# make the database engine work a little bit
|
||||
$query = qq!
|
||||
SELECT Item_ID
|
||||
FROM $stable
|
||||
WHERE
|
||||
$where
|
||||
GROUP BY Item_ID
|
||||
!;
|
||||
$self->debug($query) if ($self->{_debug});
|
||||
my $intersect_sth = $db->prepare( $query );
|
||||
|
||||
$intersect_sth->execute();
|
||||
|
||||
# get a list of all the matches
|
||||
my $matches = $intersect_sth->fetchall_arrayref();
|
||||
|
||||
# strip the matches from the current result set
|
||||
foreach my $word ( map { $_->[0] } @{$matches}) {
|
||||
delete $results->{$word};
|
||||
}
|
||||
}
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub _phrase_disjoin_query {
|
||||
#------------------------------------------------------------
|
||||
# subtracts the found phrases from the list
|
||||
my $self = shift;
|
||||
my $phrases = shift;
|
||||
my $results = shift || {};
|
||||
$phrases or return $results;
|
||||
|
||||
foreach my $phrase ( values %{$phrases} ) {
|
||||
my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} );
|
||||
|
||||
# perform disjoin
|
||||
foreach my $itemid ( keys %{$temp} ) {
|
||||
$self->debug( "Deleting $itemid from list" ) if ($self->{_debug});
|
||||
delete $results->{$itemid};
|
||||
}
|
||||
}
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub _phrase_intersect_query {
|
||||
#------------------------------------------------------------
|
||||
# intersects phrases together
|
||||
my $self = shift;
|
||||
my $phrases = shift;
|
||||
my $results = shift || {};
|
||||
|
||||
$phrases or return $results;
|
||||
|
||||
foreach my $phrase ( values %{$phrases} ) {
|
||||
my $temp = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info} );
|
||||
|
||||
# perform intersect
|
||||
foreach my $itemid ( keys %{$temp} ) {
|
||||
$temp->{$itemid} += $results->{$itemid} || 0;
|
||||
}
|
||||
$results = $temp;
|
||||
|
||||
}
|
||||
|
||||
return $results;
|
||||
|
||||
}
|
||||
|
||||
sub _phrase_query {
|
||||
#------------------------------------------------------------
|
||||
# this is a phrase union query
|
||||
my $self = shift;
|
||||
my $phrases = shift or return;
|
||||
my $results = shift || {};
|
||||
|
||||
foreach my $phrase ( values %{$phrases} ) {
|
||||
$self->debug_dumper( "Unioning: ", $phrase ) if ($self->{_debug});
|
||||
$results = $self->_get_phrase( $phrase->{'phrase'}, $phrase->{word_info}, $results );
|
||||
}
|
||||
|
||||
return $results;
|
||||
|
||||
}
|
||||
|
||||
sub _get_phrase {
|
||||
#------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $wordlist= shift;
|
||||
my $word_info = shift;
|
||||
my $results = shift || {};
|
||||
|
||||
$wordlist or return $results;
|
||||
|
||||
my ( $query, $where, $db, $word_infos, %word_hits );
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
my ($pk) = $self->{table}->pk;
|
||||
|
||||
$self->debug_dumper( "Getting words: ", $wordlist ) if ($self->{_debug});
|
||||
|
||||
# get all the word ids that we want to handle
|
||||
$db = $self->{table}->{driver} or return $self->error( 'NODRIVER', 'FATAL' );
|
||||
$word_infos = $self->_word_infos( $word_info ) or return;
|
||||
|
||||
|
||||
$self->debug_dumper( "Word infos: ", $word_infos ) if ($self->{_debug});
|
||||
|
||||
# take the words and get a hash of the word scores
|
||||
foreach my $word ( keys %{$word_infos} ) {
|
||||
|
||||
@{$word_infos->{$word} || []} or return;
|
||||
|
||||
my $total_freq = 0;
|
||||
foreach my $word_synonyms ( @{$word_infos->{$word}} ) {
|
||||
$total_freq += $word_synonyms->[1];
|
||||
}
|
||||
|
||||
# if the value is null this mean there is actually no results, whoops!
|
||||
$word_hits{$word} = $total_freq;
|
||||
}
|
||||
|
||||
$self->debug_dumper( "With synonyms tallied: ", \%word_hits ) if ($self->{_debug});
|
||||
|
||||
# so now, setup the order of search
|
||||
my $i = 0;
|
||||
my %word_order = map { $_ => $i++ } @{$wordlist};
|
||||
my @search_order = sort { $word_hits{$a} <=> $word_hits{$b} } keys %word_hits;
|
||||
|
||||
$self->debug_dumper( "Word search order: ", \@search_order ) if ($self->{_debug});
|
||||
|
||||
################################################################################
|
||||
### This following part is for smaller phrases
|
||||
################################################################################
|
||||
# start getting words in order of their frequency
|
||||
my %matches = ();
|
||||
my $index = 0;
|
||||
foreach my $word ( @search_order ) {
|
||||
|
||||
# setup the where clause for the individual words, firstly
|
||||
if ( keys %matches ) {
|
||||
my $vector = $word_order{$word} - $index;
|
||||
$where = '(';
|
||||
$where =
|
||||
'(' .
|
||||
join(
|
||||
" OR ",
|
||||
map(
|
||||
"Item_ID = $_ AND Word_Pos IN(" . join(",", map $_->[0] + $vector, @{$matches{$_}}) . ')',
|
||||
keys %matches
|
||||
)
|
||||
) .
|
||||
") AND ";
|
||||
}
|
||||
else {
|
||||
$where = '';
|
||||
}
|
||||
|
||||
$where .= "Word_ID IN(" . ( join ",", map { $_->[0] || () } @{$word_infos->{$word}} or return $results ) . ')';
|
||||
|
||||
$query = qq!
|
||||
SELECT
|
||||
Item_ID, Score, Word_Pos
|
||||
FROM
|
||||
$stable
|
||||
WHERE
|
||||
$where
|
||||
!;
|
||||
|
||||
$self->debug( "Phrase get for '$word': " . $query ) if ($self->{_debug});
|
||||
my $sth = $db->prepare( $query );
|
||||
$sth->execute();
|
||||
|
||||
%matches = ();
|
||||
|
||||
while (my $hit = $sth->fetchrow_arrayref) {
|
||||
push @{$matches{$hit->[0]}}, [ $hit->[2], $hit->[1] ];
|
||||
}
|
||||
|
||||
# If there are no values stored in %matches, it means that for
|
||||
# this keyword, there have been no hits based upon position.
|
||||
# In that case, terminate and return a null result
|
||||
keys %matches or last;
|
||||
|
||||
# where were we in the string?
|
||||
$index = $word_order{$word};
|
||||
}
|
||||
|
||||
# now tally up all the scores and merge the new records in
|
||||
foreach my $itemid ( keys %matches ) {
|
||||
my $score = 0;
|
||||
foreach my $sub_total ( @{$matches{$itemid}} ) {
|
||||
$score += $sub_total->[1];
|
||||
}
|
||||
$results->{$itemid} += $score;
|
||||
}
|
||||
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub get_wordids {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Get a list of words
|
||||
#
|
||||
my $self = shift;
|
||||
my $elements = shift or return;
|
||||
my $mode = lc shift || 'keywords';
|
||||
|
||||
if ( $mode eq 'keywords' ) {
|
||||
$elements = $self->_get_wordid($elements);
|
||||
}
|
||||
else {
|
||||
foreach my $phrase ( keys %$elements ) {
|
||||
my $results = $self->_get_wordid({
|
||||
map { ($_ => { substring => 0 }) } @{$elements->{$phrase}->{phrase}}
|
||||
});
|
||||
|
||||
$elements->{$phrase}->{word_info} = $results;
|
||||
}
|
||||
}
|
||||
|
||||
return $elements;
|
||||
}
|
||||
|
||||
sub _get_wordid {
|
||||
# ------------------------------------------------------------------------------
|
||||
# Get a list of words
|
||||
#
|
||||
my $self = shift;
|
||||
my $words = shift;
|
||||
my $tbl = $self->{table};
|
||||
|
||||
my ( $table, $wtable, $stable) = $self->_table_names();
|
||||
|
||||
foreach my $word ( keys %$words ) {
|
||||
my $query =
|
||||
qq!SELECT Word_ID, Frequency FROM $wtable WHERE Word LIKE '! .
|
||||
quotemeta($word) .
|
||||
( $words->{$word}->{substring} ? '%' : '' ) .
|
||||
"'";
|
||||
my $sth = $tbl->do_query($query) or next;
|
||||
my $tmp = { $sth->fetchall_list };
|
||||
|
||||
$words->{$word}->{word_info} = $tmp;
|
||||
}
|
||||
|
||||
return $words;
|
||||
}
|
||||
|
||||
##
|
||||
# Internal Use
|
||||
# $self->_cgi_to_hash ($in);
|
||||
# --------------------------
|
||||
# Creates a hash ref from a cgi object.
|
||||
##
|
||||
sub _cgi_to_hash {
|
||||
my ($self, $cgi) = @_;
|
||||
$cgi and UNIVERSAL::can($cgi, 'param') or return $self->error(NODRIVER => 'FATAL');
|
||||
my @keys = $cgi->param;
|
||||
my $result = {};
|
||||
foreach my $key (@keys) {
|
||||
my @values = $cgi->param($key);
|
||||
if (@values == 1) { $result->{$key} = $values[0] }
|
||||
else { $result->{$key} = \@values }
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
1;
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user