First pass at adding key files
This commit is contained in:
dsainty
143
site/common/bin/minify.cgi
Executable file
143
site/common/bin/minify.cgi
Executable file
@@ -0,0 +1,143 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use FindBin qw/$Bin/;
|
||||
FindBin::again;
|
||||
|
||||
use lib "$Bin/../admin";
|
||||
use GForum qw/$IN $CFG $DB %STASH/;
|
||||
GForum::init("$Bin/../admin");
|
||||
|
||||
$STASH{admin_request} = 1;
|
||||
|
||||
$|++;
|
||||
|
||||
use constant HOME => "/home/slowtwitch/site/common";
|
||||
|
||||
our $YUI_COMP = HOME . '/bin/yuicompressor-2.4.8.jar';
|
||||
our $GOOGLE_CLOSURE = HOME . '/bin/compiler.jar';
|
||||
|
||||
our %CSS = (
|
||||
'core.css' => 'core.min.css',
|
||||
'forum.css' => 'forum.min.css',
|
||||
'print.css' => 'print.min.css'
|
||||
);
|
||||
our %CSS_APPEND = (
|
||||
'forum.css' => [
|
||||
'jquery-ui.min.css',
|
||||
'lightbox.min.css',
|
||||
'core.min.css',
|
||||
]
|
||||
);
|
||||
|
||||
|
||||
# These must be in the static/js directory, and get placed into
|
||||
# static/js/file.min.js
|
||||
our %JS = (
|
||||
'gforum.js' => 'gforum.min.js',
|
||||
'utils.js' => 'utils.min.js',
|
||||
'core.js' => 'base.min.js'
|
||||
);
|
||||
our %JS_APPEND = (
|
||||
'core.js' => [
|
||||
'jquery.min.js',
|
||||
'jquery-ui.min.js',
|
||||
'jquery.form.min.js',
|
||||
'jquery.jcarousellite.min.js',
|
||||
'jquery.autocomplete.min.js'
|
||||
],
|
||||
'gforum.js' => [
|
||||
'utils.min.js'
|
||||
]
|
||||
);
|
||||
|
||||
print $IN->header, "<pre>";
|
||||
main();
|
||||
|
||||
sub main {
|
||||
# -------------------------------------------------------------------
|
||||
print "Creating css files ... \n";
|
||||
for my $css (keys %CSS) {
|
||||
print " $css => $CSS{$css} ... \n";
|
||||
my $full_path = HOME . "/static/css/$css";
|
||||
my $output = HOME . "/static/css/$CSS{$css}";
|
||||
if (! -e $full_path) {
|
||||
die "Missing css file $full_path";
|
||||
}
|
||||
if ($CSS_APPEND{$css}) {
|
||||
open my $fh, ">", "$full_path.tmp" or die "open $full_path.tmp ($!)";
|
||||
for my $file (@{$CSS_APPEND{$css}}) {
|
||||
print " Appending $file\n";
|
||||
my $append_file = HOME . "/static/css/$file";
|
||||
open my $append, "<", $append_file or die "open $append_file: $!";
|
||||
while (<$append>) {
|
||||
print $fh $_;
|
||||
}
|
||||
close $append;
|
||||
}
|
||||
close $fh;
|
||||
}
|
||||
system("java -jar $YUI_COMP $full_path >> $full_path.tmp") or die $!;
|
||||
|
||||
# Minifying breaks this WebKit css filter. Put a space back in between
|
||||
# the 'and' and '('.
|
||||
system("perl -p -i -e 's/\@media screen and\\(/\@media screen and (/' $full_path.tmp");
|
||||
chmod(0644, "$full_path.tmp") or die "chmod $full_path.tmp ($!)";
|
||||
unless (-s "$full_path.tmp") {
|
||||
die "New css file is 0 bytes, bailing!";
|
||||
}
|
||||
rename("$full_path.tmp", $output) or die "rename ($full_path.tmp) ($output): $!";
|
||||
}
|
||||
|
||||
print "\nCreate js files ... \n";
|
||||
for my $js (keys %JS) {
|
||||
print " $js => $JS{$js}\n";
|
||||
my $full_path = HOME . "/static/js/$js";
|
||||
my $output = HOME . "/static/js/$JS{$js}";
|
||||
if (! -e $full_path) {
|
||||
die "Missing js file $full_path";
|
||||
}
|
||||
if ($JS_APPEND{$js}) {
|
||||
open my $fh, ">", "$full_path.tmp" or die "open $full_path.tmp ($!)";
|
||||
for my $file (@{$JS_APPEND{$js}}) {
|
||||
print " Appending $file\n";
|
||||
my $append_file = HOME . "/static/js/$file";
|
||||
open my $append, "<", $append_file or die "open $append_file: $!";
|
||||
while (<$append>) {
|
||||
print $fh $_;
|
||||
}
|
||||
close $append;
|
||||
}
|
||||
close $fh;
|
||||
}
|
||||
system("java -jar $GOOGLE_CLOSURE -js $full_path >> $full_path.tmp");
|
||||
chmod(0644, "$full_path.tmp") or die "chmod $full_path.tmp ($!)";
|
||||
unless (-s "$full_path.tmp") {
|
||||
die "New js file is 0 bytes, bailing!";
|
||||
}
|
||||
rename("$full_path.tmp", $output) or die "rename ($full_path.tmp) ($output): ($!)";
|
||||
}
|
||||
|
||||
my $rev;
|
||||
my $globals = '';
|
||||
open my $fh, "<", HOME . "/templates/include_global_head.html" or die "open include_global_head.html ($!)";
|
||||
while (<$fh>) {
|
||||
if (m{mini_version\s*=\s*'(\d+)'}) {
|
||||
$rev = $1;
|
||||
my $new = $rev + 1;
|
||||
s{mini_version\s*=\s*'(\d+)'}{mini_version = '$new'};
|
||||
$rev = $new;
|
||||
}
|
||||
$globals .= $_;
|
||||
}
|
||||
close $fh;
|
||||
if (! $rev) { die "Couldn't find revision in include_global_head.html"; }
|
||||
|
||||
print "Updating include_global_head.html\n";
|
||||
open $fh, ">", HOME . "/templates/include_global_head.html.new" or die "open: $!";
|
||||
print $fh $globals;
|
||||
close $fh;
|
||||
chmod(0640, HOME . '/templates/include_global_head.html.new') or die "chmod ($!)";
|
||||
rename(HOME . "/templates/include_global_head.html.new", HOME . "/templates/include_global_head.html") or die "rename ($!)";
|
||||
print "Done\n";
|
||||
}
|
||||
23
site/forum.slowtwitch.com/cgi-bin/gforum.cgi
Executable file
23
site/forum.slowtwitch.com/cgi-bin/gforum.cgi
Executable file
@@ -0,0 +1,23 @@
|
||||
#!/usr/bin/speedy
|
||||
|
||||
# Nathan moved this to speedycgi, Nov 23 2017 #!/usr/bin/perl
|
||||
|
||||
# ==================================================================
|
||||
# Gossamer Forum - Advanced web community
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: gforum.cgi,v 1.56 2006/03/31 21:32:04 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/$PLG/;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
$PLG->dispatch(main => \&GForum::request);
|
||||
6
site/forum.slowtwitch.com/cgi-bin/poll/admin/.htaccess
Normal file
6
site/forum.slowtwitch.com/cgi-bin/poll/admin/.htaccess
Normal file
@@ -0,0 +1,6 @@
|
||||
AuthUserFile /home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin/.htpasswd
|
||||
AuthGroupFile /dev/null
|
||||
AuthType Basic
|
||||
AuthName "Gossamer Forum Administration"
|
||||
|
||||
require valid-user
|
||||
411
site/forum.slowtwitch.com/cgi-bin/poll/admin/admin.cgi
Executable file
411
site/forum.slowtwitch.com/cgi-bin/poll/admin/admin.cgi
Executable file
@@ -0,0 +1,411 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/$DB $CFG $IN/;
|
||||
use vars qw/$PRINT_HEADER $FONT $MAX $poll_vars/;
|
||||
|
||||
local $SIG{__DIE__} = \&GForum::fatal;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
$poll_vars = do "poll.cfg";
|
||||
|
||||
$MAX = 20;
|
||||
$FONT = qq~font face="tacoma, arial, san-serif" size="2"~;
|
||||
main();
|
||||
|
||||
sub main {
|
||||
header();
|
||||
nav();
|
||||
my $do = $IN->param('do');
|
||||
if ($do eq 'add_form') { add_form(); }
|
||||
elsif ($do eq 'add') { add(); }
|
||||
elsif ($do eq 'modify_form') { modify_form(); }
|
||||
elsif ($do eq 'modify') { modify(); }
|
||||
elsif ($do eq 'disable') { disable(); }
|
||||
elsif ($do eq 'enable') { enable(); }
|
||||
elsif ($do eq 'home_show') { home_show(); }
|
||||
elsif ($do eq 'home_notshow') { home_notshow(); }
|
||||
else {
|
||||
&list();
|
||||
}
|
||||
footer();
|
||||
}
|
||||
|
||||
sub header {
|
||||
if (!$PRINT_HEADER) {
|
||||
print $IN->header();
|
||||
}
|
||||
print "<html><head><title>Poll Admin</title></head><body><$FONT>";
|
||||
}
|
||||
|
||||
sub nav {
|
||||
print qq!
|
||||
<b>Poll</b>: <a href="admin.cgi?do=add_form">Add Poll</a> | <a href="admin.cgi">List Poll</a>
|
||||
!;
|
||||
#<br><b>Quiz</b>: <a href="admin.cgi?do=add_form&poll_type=1">Add Quiz</a> | <a href="admin.cgi?poll_type=1">List Quiz</a><br>
|
||||
}
|
||||
|
||||
sub footer {
|
||||
print "</body></html>";
|
||||
}
|
||||
|
||||
sub include_form {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $val = shift || {};
|
||||
my $option = shift || $MAX;
|
||||
my $output = qq~<form action="admin.cgi" method="post">
|
||||
<input type="hidden" name="do" value="$val->{do}">
|
||||
<input type="hidden" name="poll_id" value="$val->{poll_id}">\n~;
|
||||
|
||||
$output .= qq~<p><$FONT color="red">$val->{error}</font></p>~ if $val->{error};
|
||||
|
||||
$output .= qq~
|
||||
<B>Question:</B> <br><textarea rows="4" cols="50" name="poll_question">$val->{poll_question}</textarea><br>\n
|
||||
<B>Description:</B> <br><textarea rows="4" cols="50" name="poll_text">$val->{poll_text}</textarea><br>\n
|
||||
<b>Answers Options:</b> <br>
|
||||
~;
|
||||
my $i = 1;
|
||||
my $select = qq~<select name="poll_answer">~;
|
||||
if ($val->{poll_answers_loop}) {
|
||||
foreach my $ans (@{$val->{poll_answers_loop}}) {
|
||||
$output .= qq~Option $i: <input type="text" name="poll_answer_answer_$i" size="30" value="$ans->{poll_answer_answer}"> ~;
|
||||
if (!$val->{poll_type}) {
|
||||
$output .= qq~Votes: <input type="text" name="poll_answer_votes_$i" size="10" value="$ans->{poll_answer_votes}"><br>\n~;
|
||||
}
|
||||
$output .= qq~<input type="hidden" name="current_poll_answer_id_$i" value="$ans->{poll_answer_id}">\n~;
|
||||
$output .= "<br>";
|
||||
$select .= qq~<option value="$ans->{poll_answer_id}"~;
|
||||
if ($val->{poll_answer} == $ans->{poll_answer_id}) {
|
||||
$select .= " selected";
|
||||
}
|
||||
$select .= qq~>$i</option>\n~;
|
||||
$i++;
|
||||
}
|
||||
if ($IN->param('num_answers') > $i) {
|
||||
foreach ($i .. $IN->param('num_answers')) {
|
||||
$output .= qq~Option $_: <input type="text" name="poll_answer_answer_$_" size="30" value=""> ~;
|
||||
if (!$val->{poll_type}) {
|
||||
$output .= qq~Votes: <input type="text" name="poll_answer_votes_$_" size="10" value="0"><br>\n~;
|
||||
}
|
||||
$output .= "<br>";
|
||||
$select .= qq~<option value="$_">$_</option>\n~;
|
||||
}
|
||||
}
|
||||
$i += 2;
|
||||
}
|
||||
else {
|
||||
foreach (1 .. $option) {
|
||||
my $ans = $val->{'poll_answer_answer_' . $_};
|
||||
$output .= qq~Option $_: <input type="text" name="poll_answer_answer_$_" size="30" value="$ans"> ~;
|
||||
if (!$val->{poll_type}) {
|
||||
$output .= qq~Votes: <input type="text" name="poll_answer_votes_$_" size="10" value="0">\n~;
|
||||
}
|
||||
$output .= "<br>";
|
||||
$select .= qq~<option value="$_">$_</option>\n~;
|
||||
}
|
||||
}
|
||||
$select .= "</select>";
|
||||
if ($val->{poll_type} == 1) {
|
||||
$output .= qq~<b>Right Answer:</b> $select<br><input type="hidden" name="poll_type" value="1">\n~;
|
||||
}
|
||||
$output .= qq~<B>Total Votes:</B> <input type="text" size="10" name="poll_votes" value="$val->{poll_votes}"><br><br>\n~;
|
||||
$output .= $val->{poll_id} ?
|
||||
qq~<input type="submit" value="Modify"> <a href="admin.cgi?do=modify_form&poll_id=$val->{poll_id}&num_answers=$i">Want to add more options?</a></form>~ :
|
||||
qq~<input type="submit" value="Add"></form>~;
|
||||
|
||||
return $output . "\n";
|
||||
}
|
||||
|
||||
sub list {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $msg = shift;
|
||||
my $start_at = $IN->param("start_at") || 1;
|
||||
my $poll_count = $IN->param("poll_count") || 100;
|
||||
my $cgi = $IN->get_hash();
|
||||
$cgi->{nh} ||= $start_at;
|
||||
$cgi->{mh} ||= $poll_count;
|
||||
$cgi->{sb} ||= "poll_date";
|
||||
$cgi->{so} ||= "DESC";
|
||||
$cgi->{poll_type} ||= 0;
|
||||
|
||||
#use Data::Dumper; print "<pre>" . Dumper($cgi) . "</pre>";
|
||||
my $db = $DB->table('Poll');
|
||||
my $ans_db = $DB->table('PollAnswer');
|
||||
my $sth = $db->query_sth($cgi);
|
||||
my $output;
|
||||
|
||||
if ($msg) {
|
||||
$output .= "<p>$msg</p>";
|
||||
}
|
||||
my $i=1;
|
||||
my $correct = "";
|
||||
while (my $row = $sth->fetchrow_hashref()) {
|
||||
my $date = $row->{poll_date};
|
||||
$output .= qq~<p><table width="100%"><tr><td colspan="2"><$FONT>$i.) $row->{poll_question} (posted on $date)</td></tr>
|
||||
<tr><td colspan="2"><$FONT>Description: $row->{poll_text}</td></tr>~;
|
||||
my $answers = $ans_db->select( { poll_id_fk => $row->{poll_id} })->fetchall_hashref();
|
||||
my $max = 0;
|
||||
my $votes = $row->{poll_votes};
|
||||
foreach my $poll_answer (@$answers) {
|
||||
if ($votes) {
|
||||
$poll_answer->{poll_answer_percentage} = sprintf("%" . $poll_vars->{percentage_pre} . "." . $poll_vars->{percentage_post} . "f",$poll_answer->{poll_answer_votes} / $votes * 100);
|
||||
}
|
||||
if ($poll_answer->{poll_answer_votes} > $max) {
|
||||
$max = $poll_answer->{poll_answer_votes};
|
||||
$poll_answer->{poll_answer_is_leading} = 1;
|
||||
}
|
||||
else {
|
||||
$poll_answer->{poll_answer_is_leading} = 0;
|
||||
}
|
||||
if ($poll_answer->{poll_answer_id} == $row->{poll_answer}) {
|
||||
$correct = $poll_answer->{poll_answer_answer};
|
||||
}
|
||||
$output .= qq~
|
||||
<tr>
|
||||
<td align="right" width="20%">
|
||||
<$FONT>
|
||||
$poll_answer->{poll_answer_answer}
|
||||
</td>
|
||||
<td align="left" width="80%">
|
||||
<$FONT> ~;
|
||||
if ($poll_answer->{poll_answer_percentage}) {
|
||||
my $width = $poll_answer->{poll_answer_percentage} * 4;
|
||||
$output .= qq~<img src="/images/leftbar.gif" height="10" width="2" alt="" /><img src="/images/mainbar.gif" height="10" width="$width" alt="" /><img src="/images/rightbar.gif" height="10" width="2" alt="" />~;
|
||||
}
|
||||
else {
|
||||
$output .= qq~<img src="/images/leftbar.gif" height="10" width="2" alt="" /><img src="/images/rightbar.gif" height="10" width="2" alt="" />~;
|
||||
}
|
||||
$output .= qq~$poll_answer->{poll_answer_votes} / $poll_answer->{poll_answer_percentage} %
|
||||
</td>
|
||||
</tr>
|
||||
~;
|
||||
}
|
||||
if ($row->{poll_type}) {
|
||||
$output .= qq~<tr><td colspan="2"><$FONT>The Correct Answer is: $correct</td></tr>~;
|
||||
$output .= qq~<tr><td colspan="2"><$FONT>Total Answered: $row->{poll_votes}</td></tr>~;
|
||||
}
|
||||
else {
|
||||
$output .= qq~<tr><td colspan="2"><$FONT>Total Votes: $row->{poll_votes}</td></tr>~;
|
||||
}
|
||||
$output .= qq~<tr><td colspan="2"><$FONT> <a href="admin.cgi?do=modify_form&poll_id=$row->{poll_id}">Edit</a> | ~;
|
||||
$output .= $row->{poll_enabled} ?
|
||||
qq~<a href="admin.cgi?do=disable&poll_id=$row->{poll_id}"> Disable </a>~ :
|
||||
qq~<a href="admin.cgi?do=enable&poll_id=$row->{poll_id}"> Enable</a>~ ;
|
||||
$output .= $row->{poll_home} ?
|
||||
qq~| <a href="admin.cgi?do=home_notshow&poll_id=$row->{poll_id}"> Don't Show this on Home Page</a>~ :
|
||||
qq~| <a href="admin.cgi?do=home_show&poll_id=$row->{poll_id}"> Show this on Home Page</a>~ ;
|
||||
$output .= qq~</td></tr></table>~;
|
||||
$i++;
|
||||
}
|
||||
print $output;
|
||||
}
|
||||
|
||||
sub add_form {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $cgi = $IN->get_hash();
|
||||
my $error = shift;
|
||||
if ($error) {
|
||||
$cgi->{error} = $error;
|
||||
}
|
||||
$cgi->{do} = 'add';
|
||||
my $form = include_form( { %$cgi }, 4 );
|
||||
print $form;
|
||||
}
|
||||
|
||||
sub add {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
# This subroutine will get called whenever the hook 'do_post_post'
|
||||
# is run.
|
||||
my $total_options = 0;
|
||||
my %seen;
|
||||
my $dup = 0;
|
||||
for (1 .. $MAX) {
|
||||
my $ans = $IN->param("poll_answer_answer_$_");
|
||||
if ($ans) {
|
||||
if ($seen{$ans}) {
|
||||
$dup = 1;
|
||||
last;
|
||||
}
|
||||
$seen{$ans} = 1;
|
||||
$total_options++;
|
||||
}
|
||||
}
|
||||
if ($dup) {
|
||||
return add_form("Answers are the same.");
|
||||
}
|
||||
|
||||
if (!$IN->param('poll_question')) {
|
||||
add_form("No question entered!");
|
||||
return;
|
||||
}
|
||||
if ($total_options < 2) {
|
||||
add_form("POLL_NOT_ENOUGH_OPTIONS");
|
||||
return;
|
||||
}
|
||||
|
||||
# Insert question into Poll table
|
||||
my $a = $DB->table('Poll');
|
||||
my $cgi = $IN->get_hash;
|
||||
$cgi->{'poll_enabled'} = '1';
|
||||
$cgi->{'poll_type'} ||= 0;
|
||||
$cgi->{'poll_votes'} = 0;
|
||||
if (!$cgi->{'poll_type'}){
|
||||
$cgi->{'poll_answer'} = 0;
|
||||
}
|
||||
require GT::Date;
|
||||
$cgi->{'poll_date'} = GT::Date::date_get();
|
||||
my $rec = $a->insert($cgi) or die "$GT::SQL::error";
|
||||
my $poll_id = $rec->insert_id;
|
||||
|
||||
if (!$poll_id) {
|
||||
print "error: can't add poll, reason: $GT::SQL::error";
|
||||
return;
|
||||
}
|
||||
# Insert answers into PollAnswer table
|
||||
my $votes_sum;
|
||||
my $b = $DB->table('PollAnswer');
|
||||
for (my $i = 1; $i <= $MAX; $i++) {
|
||||
my %answer;
|
||||
if ($IN->param("poll_answer_answer_$i")) {
|
||||
$answer{'poll_answer_answer'} = $IN->param("poll_answer_answer_$i");
|
||||
$answer{'poll_answer_votes'} = 0;
|
||||
$answer{'poll_id_fk'} = $poll_id;
|
||||
my $res = $b->insert(\%answer);
|
||||
my $ans_id = $res->insert_id;
|
||||
if ($i == $cgi->{poll_answer}) {
|
||||
$a->update( { poll_answer => $ans_id }, { poll_id => $poll_id });
|
||||
}
|
||||
};
|
||||
};
|
||||
my $msg = "Poll added successfully!";
|
||||
&list($msg);
|
||||
}
|
||||
|
||||
sub modify_form {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $id = $IN->param('poll_id') || shift;
|
||||
if (!$id) {
|
||||
print "no poll id passed";
|
||||
return;
|
||||
}
|
||||
my $poll = $DB->table('Poll')->get($id);
|
||||
my $ans_db = $DB->table('PollAnswer');
|
||||
my $poll_answer = $ans_db->select( { poll_id_fk => $id } )->fetchall_hashref();
|
||||
my $hits = $ans_db->hits;
|
||||
my $form = include_form( { do => 'modify', %$poll, poll_answers_loop => $poll_answer}, 4 );
|
||||
print $form;
|
||||
}
|
||||
|
||||
sub modify {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $cgi = $IN->get_hash();
|
||||
|
||||
# Update existing record or insert new record (PollAnswer table)
|
||||
my $votes_sum = 0;
|
||||
my $a = $DB->table('PollAnswer');
|
||||
for (my $i = 1; $i <= $MAX; $i++) {
|
||||
my %answer;
|
||||
if ($IN->param("poll_answer_answer_$i")) {
|
||||
$answer{'poll_answer_answer'} = $IN->param("poll_answer_answer_$i");
|
||||
if ($IN->param("poll_answer_votes_$i")) {
|
||||
$answer{'poll_answer_votes'} = $IN->param("poll_answer_votes_$i");
|
||||
}
|
||||
$answer{'poll_id_fk'} = $poll_id;
|
||||
$votes_sum += $IN->param("poll_answer_votes_$i");
|
||||
if ($IN->param("current_poll_answer_id_$i")) {
|
||||
$a->update(\%answer, { poll_answer_id => $IN->param("current_poll_answer_id_$i") }) or die $GT::SQL::error;
|
||||
}
|
||||
else {
|
||||
$a->insert(\%answer);
|
||||
}
|
||||
}
|
||||
elsif ($IN->param("current_poll_answer_id_$i") and not $IN->param("poll_answer_answer_$i")) {
|
||||
$a->delete( { poll_answer_id => $IN->param("current_poll_answer_id_$i") });
|
||||
};
|
||||
};
|
||||
|
||||
# Update vote count
|
||||
my $p = $DB->table('Poll');
|
||||
my $poll_type = $IN->param('poll_type') || '0';
|
||||
my $cols = $p->cols;
|
||||
my $mod = {};
|
||||
foreach (keys %$cols) {
|
||||
next if ($_ eq 'poll_id');
|
||||
next if ($_ eq 'poll_date');
|
||||
next if ($_ eq 'poll_home');
|
||||
next if ($_ eq 'poll_enabled');
|
||||
$mod->{$_} = $cgi->{$_};
|
||||
}
|
||||
if (!$poll_type) {
|
||||
$mod->{poll_answer} = 0;
|
||||
$mod->{poll_type} = 0;
|
||||
}
|
||||
$p->update( $mod , { poll_id => $poll_id }) or die "$GT::SQL::error";
|
||||
&list("The poll has been updated successfully!");
|
||||
}
|
||||
|
||||
sub disable {
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $p = $DB->table('Poll');
|
||||
|
||||
my $poll = $p->get($poll_id);
|
||||
if (!$poll) {
|
||||
return &list("No such quiz or poll: $poll_id");
|
||||
}
|
||||
$p->update({ poll_enabled => 0 }, { poll_id => $poll_id });
|
||||
$IN->param('poll_id',"");
|
||||
$IN->param('poll_type',$poll->{poll_type});
|
||||
&list("The poll/quiz $poll->{poll_question} has been disabled.");
|
||||
}
|
||||
|
||||
sub enable {
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $p = $DB->table('Poll');
|
||||
|
||||
my $poll = $p->get($poll_id);
|
||||
if (!$poll) {
|
||||
return &list("No such quiz or poll: $poll_id");
|
||||
}
|
||||
$p->update({ poll_enabled => 1 }, { poll_id => $poll_id });
|
||||
$IN->param('poll_id',"");
|
||||
$IN->param('poll_type',$poll->{poll_type});
|
||||
&list("The poll/quiz $poll->{poll_question} has been enabled.");
|
||||
}
|
||||
|
||||
sub home_show {
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $p = $DB->table('Poll');
|
||||
|
||||
my $poll = $p->get($poll_id);
|
||||
if (!$poll) {
|
||||
return &list("No such quiz or poll: $poll_id");
|
||||
}
|
||||
$p->update({ poll_home => 0 });
|
||||
$p->update({ poll_home => 1 }, { poll_id => $poll_id });
|
||||
$IN->param('poll_id',"");
|
||||
$IN->param('poll_type',$poll->{poll_type});
|
||||
&list("The poll/quiz $poll->{poll_question} has been set to show on home page.");
|
||||
}
|
||||
|
||||
sub home_notshow {
|
||||
my $poll_id = $IN->param('poll_id');
|
||||
my $p = $DB->table('Poll');
|
||||
|
||||
my $poll = $p->get($poll_id);
|
||||
if (!$poll) {
|
||||
return &list("No such quiz or poll: $poll_id");
|
||||
}
|
||||
$p->update({ poll_home => 1 }, { poll_id => $poll_id });
|
||||
$IN->param('poll_id',"");
|
||||
$IN->param('poll_type',$poll->{poll_type});
|
||||
&list("The poll/quiz $poll->{poll_question} has been removed from showing on the home page.");
|
||||
}
|
||||
83
site/forum.slowtwitch.com/cgi-bin/poll/admin/sql.cgi
Executable file
83
site/forum.slowtwitch.com/cgi-bin/poll/admin/sql.cgi
Executable file
@@ -0,0 +1,83 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/$DB $CFG/;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
main();
|
||||
|
||||
sub main {
|
||||
# Create the Poll table.
|
||||
my $p = $DB->creator ('Poll');
|
||||
$p->cols([
|
||||
poll_id => { type => 'INT', not_null => 1 },
|
||||
poll_question => { type => 'VARCHAR',size => '255',not_null => 1},
|
||||
poll_answer => { type => 'VARCHAR',size => '255',not_null => 1},
|
||||
poll_type => { type => 'TINYINT',default => '1',not_null => '1'},
|
||||
poll_votes => { type => 'INT',not_null => 1},
|
||||
poll_enabled => { type => 'TINYINT',default => '1',not_null => 1},
|
||||
poll_date => { type => 'Date', not_null => 1},
|
||||
poll_text => { type => 'TEXT', not_null => 0},
|
||||
poll_home => { type => 'TINYINT',default => '0',not_null => 1},
|
||||
]);
|
||||
|
||||
$p->pk('poll_id');
|
||||
$p->ai('poll_id');
|
||||
|
||||
if (!$p->create and $GT::SQL::errcode eq 'TBLEXISTS') {
|
||||
$p->set_defaults();
|
||||
$p->save_schema();
|
||||
}
|
||||
|
||||
# Create the PollAnswer table
|
||||
my $a = $DB->creator ('PollAnswer');
|
||||
$a->cols([
|
||||
poll_answer_id => { type => 'INT', not_null => 1 },
|
||||
poll_id_fk => { type => 'INT', not_null => 1 },
|
||||
poll_answer_answer => {type => 'VARCHAR',size => '255',not_null => 1,default => 0},
|
||||
poll_answer_votes => {type => 'INT',not_null => 1,default => 0}
|
||||
]);
|
||||
|
||||
$a->pk('poll_answer_id');
|
||||
$a->ai('poll_answer_id');
|
||||
|
||||
$a->fk({
|
||||
Poll => { poll_id_fk => 'poll_id' },
|
||||
});
|
||||
|
||||
$a->index({ a_pl => ['poll_id_fk']});
|
||||
|
||||
if (!$a->create and $GT::SQL::errcode eq 'TBLEXISTS') {
|
||||
$a->set_defaults();
|
||||
$a->save_schema();
|
||||
}
|
||||
|
||||
# Create the PollVote table
|
||||
my $v = $DB->creator ('PollVote');
|
||||
$v->cols([
|
||||
poll_vote_id => { type => 'INT', not_null => 1 },
|
||||
poll_id_fk => { type => 'INT', not_null => 1 },
|
||||
poll_vote_ip => { type => 'VARCHAR',size => '15', not_null => 1 },
|
||||
poll_vote_time => { type => 'INT', default => '0', not_null => '1' }
|
||||
]);
|
||||
|
||||
$v->pk('poll_vote_id');
|
||||
$v->ai('poll_vote_id');
|
||||
|
||||
$v->fk ( {
|
||||
'Poll' => {
|
||||
'poll_id_fk' => 'poll_id'
|
||||
},
|
||||
});
|
||||
|
||||
$v->index({ v_p => ['poll_id_fk'] });
|
||||
|
||||
if (!$v->create and $GT::SQL::errcode eq 'TBLEXISTS') {
|
||||
$v->set_defaults();
|
||||
$v->save_schema();
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
11
site/forum.slowtwitch.com/cgi-bin/poll/poll.cgi
Executable file
11
site/forum.slowtwitch.com/cgi-bin/poll/poll.cgi
Executable file
@@ -0,0 +1,11 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/$DB $CFG $IN/;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
use Poll;
|
||||
Poll::handle();
|
||||
|
||||
107
site/forum.slowtwitch.com/cgi-bin/silent_post_live.cgi
Executable file
107
site/forum.slowtwitch.com/cgi-bin/silent_post_live.cgi
Executable file
@@ -0,0 +1,107 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/:objects/;
|
||||
use GForum::Payment qw/:status :log/;
|
||||
use Data::Dumper;
|
||||
use vars qw/%INVALID %EMPTY/;
|
||||
use GT::Payment::Direct::AuthorizeDotNetRec;
|
||||
use Slowtwitch::Payment;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
main();
|
||||
|
||||
sub main {
|
||||
silent_post();
|
||||
}
|
||||
|
||||
sub silent_post {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Handle PayPal postback
|
||||
my $unique = $IN->param('x_invoice_num');
|
||||
my $pay = $DB->table('Subscription_Payments');
|
||||
my $log = $DB->table('Subscription_PaymentLogs');
|
||||
my $in = $IN->get_hash();
|
||||
my $payment = $pay->get($unique);
|
||||
if (!$payment) {
|
||||
open (LOG, ">>/var/home/virginia/virginialo.com/cgi-bin/forum/admin/auth_silent_error.log");
|
||||
print LOG Dumper($in);
|
||||
close (LOG);
|
||||
print $IN->header . "No such invoice: $unique.";
|
||||
return;
|
||||
}
|
||||
|
||||
open (LOG, ">>/var/home/virginia/virginialo.com/cgi-bin/forum/admin/auth_silent_live.log");
|
||||
print LOG Dumper($payment,$in);
|
||||
close (LOG);
|
||||
|
||||
print $IN->header;
|
||||
GT::Payment::Direct::AuthorizeDotNetRec::process(
|
||||
param => $IN,
|
||||
test_mode => $CFG->{payment}->{direct}->{used}->{AuthorizeDotNetRec}->{test_mode},
|
||||
account_username => $CFG->{payment}->{direct}->{used}->{AuthorizeDotNetRec}->{account_username},
|
||||
md5_key => $CFG->{payment}->{direct}->{used}->{AuthorizeDotNetRec}->{md5_key},
|
||||
duplicate => sub {
|
||||
my $id = $IN->param('x_trans_id');
|
||||
my $cond = GT::SQL::Condition->new();
|
||||
$cond->add(paylogs_payments_id => '=' => $unique);
|
||||
$cond->add(paylogs_type => '=' => LOG_ACCEPTED);
|
||||
$cond->add(paylogs_text => LIKE => "%Transaction ID: $id\n%");
|
||||
my $found = $log->count($cond);
|
||||
#warn "$found ($id) **";
|
||||
return $found ? undef : 1; # True if everything checks out; undef if a duplicate was found
|
||||
},
|
||||
on_invalid => sub {
|
||||
},
|
||||
on_error => sub {
|
||||
my $errmsg = shift;
|
||||
print $errmsg . "\n";
|
||||
$pay->update(
|
||||
{ payments_status => ERROR, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => $errmsg
|
||||
});
|
||||
},
|
||||
on_recurring => sub {
|
||||
if ($IN->param('x_amount') < $payment->{payments_amount}) {
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => "Invalid payment (payment amount is less than original charge): " .
|
||||
$IN->param('x_amount') . " < " . $payment->{payments_amount}
|
||||
});
|
||||
return;
|
||||
}
|
||||
|
||||
$pay->update(
|
||||
{ payments_status => COMPLETED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ACCEPTED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
"Transaction ID: " . $IN->param('x_trans_id') . "\n" .
|
||||
"Amount: " . $IN->param('x_amount') . " " .
|
||||
"Subscription payment #: " . $IN->param('x_subscription_paynum') . " " .
|
||||
"Subscription ID: " . $IN->param('x_subscription_id') . "\n"
|
||||
)
|
||||
});
|
||||
|
||||
Slowtwitch::Payment::process_payment($payment->{payments_userid}, '', $payment->{payments_id});
|
||||
}
|
||||
);
|
||||
|
||||
1;
|
||||
}
|
||||
24
site/forum.slowtwitch.com/cgi-bin/threads.cgi
Executable file
24
site/forum.slowtwitch.com/cgi-bin/threads.cgi
Executable file
@@ -0,0 +1,24 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib "/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin";
|
||||
use GForum qw/$IN $CFG $DB/;
|
||||
use GForum::SEO;
|
||||
|
||||
GForum::init("/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin");
|
||||
|
||||
my @ids = split(/\s*,\s*/, $IN->param('id') || '');
|
||||
|
||||
print $IN->header;
|
||||
if (scalar @ids) {
|
||||
my $posts = $DB->table('Post')->select(/post_id post_subject/, { post_id => \@ids })->fetchall_hashref;
|
||||
my %posts = map { $_->{post_id} => $_ } @$posts;
|
||||
|
||||
my ($count, $html) = (0, "");
|
||||
foreach my $id (@ids) {
|
||||
$count++;
|
||||
my $url = $CFG->{cgi_root_url} . GForum::SEO::url(type => "post", id => $id);
|
||||
$html .= qq!<div class="link"><div><span>$count</span></div><a href="$url">$posts{$id}{post_subject}</a></div>!;
|
||||
}
|
||||
print qq!<div class="list">$html</div>!;
|
||||
}
|
||||
6
site/forum.slowtwitch.com/cgi-bin/ticker/admin/.htaccess
Normal file
6
site/forum.slowtwitch.com/cgi-bin/ticker/admin/.htaccess
Normal file
@@ -0,0 +1,6 @@
|
||||
AuthUserFile /home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin/.htpasswd
|
||||
AuthGroupFile /dev/null
|
||||
AuthType Basic
|
||||
AuthName "Gossamer Forum Administration"
|
||||
|
||||
require valid-user
|
||||
160
site/forum.slowtwitch.com/cgi-bin/ticker/admin/admin.cgi
Executable file
160
site/forum.slowtwitch.com/cgi-bin/ticker/admin/admin.cgi
Executable file
@@ -0,0 +1,160 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# The ticker (client & admin) loosely follows an MVC architecture. The model
|
||||
# is over in Ticker.pm (it does all the DB work). ticker.cgi is the view for
|
||||
# the client, while this is the view+controller for the admin.
|
||||
#
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
use Error qw(:try);
|
||||
|
||||
use constant {
|
||||
STATE_NORMAL => 0,
|
||||
STATE_UPDATE => 1,
|
||||
STATE_REDIRECT => 2,
|
||||
ADMIN_URL => "http://forum.slowtwitch.com/cgi-bin/ticker/admin/admin.cgi"
|
||||
};
|
||||
|
||||
# prototypes.
|
||||
sub controller();
|
||||
sub view($);
|
||||
|
||||
# And call the controller.
|
||||
controller();
|
||||
|
||||
#
|
||||
# This is the controller. This is where work gets done.
|
||||
#
|
||||
sub controller() {
|
||||
my %viewstate = (state => STATE_NORMAL);
|
||||
|
||||
# if we have an action parameter (that's non-empty), then do work:
|
||||
if(defined $IN->param('action') && length($IN->param('action')) > 0) {
|
||||
$viewstate{state} = STATE_REDIRECT;
|
||||
try {
|
||||
my $p = $IN->get_hash();
|
||||
if($p->{action} =~ /create/) {
|
||||
Ticker::create_ticker($p->{msg}, $p->{link});
|
||||
} elsif($p->{action} =~ /show_update/) {
|
||||
$viewstate{state} = STATE_UPDATE;
|
||||
$viewstate{id} = $p->{'id'};
|
||||
} elsif($p->{action} =~ /do_update/) {
|
||||
Ticker::update_ticker($p->{'id'}, $p->{'msg'}, $p->{'link'});
|
||||
} elsif($p->{action} =~ /delete/) {
|
||||
Ticker::delete_ticker($p->{'id'});
|
||||
}
|
||||
} catch Ticker::TickerException with {
|
||||
# oops. something bad happened.
|
||||
$viewstate{error} = "Error: " . shift;
|
||||
# reset the viewstate so that we display the error message.
|
||||
$viewstate{state} = STATE_NORMAL;
|
||||
};
|
||||
}
|
||||
|
||||
return view(\%viewstate);
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Build the view, which takes a single hashref describing how the view should
|
||||
# behave.
|
||||
#
|
||||
sub view($) {
|
||||
my ($state) = @_;
|
||||
my %s = %$state;
|
||||
|
||||
# If the state is redirect, we're done.
|
||||
if($s{state} == STATE_REDIRECT) {
|
||||
print $IN->redirect(ADMIN_URL);
|
||||
return;
|
||||
}
|
||||
|
||||
# Now let's actually build the view, depending on our current state:
|
||||
print $IN->header();
|
||||
print qq{<html><head><title>Ticker Admin</title></head><body>};
|
||||
|
||||
# Try to load all the tickers:
|
||||
try {
|
||||
$s{data} = Ticker::read_tickers();
|
||||
|
||||
# Are we also trying to update a record? Yeah, I know - we're
|
||||
# hitting the db again. I wish that fetchall_hashref actually worked...
|
||||
if(defined $s{id}) {
|
||||
my $result = Ticker::read_ticker($s{id});
|
||||
$s{msg} = $result->{ticker_text};
|
||||
$s{link} = $result->{ticker_link};
|
||||
}
|
||||
} catch Ticker::TickerException with {
|
||||
$s{error} .= " Could not read tickers from database!";
|
||||
};
|
||||
|
||||
# Print an error message if we have one:
|
||||
if(defined $s{error}) {
|
||||
print "<p>" . $s{error} . "</p>";
|
||||
}
|
||||
|
||||
# What should the top form look like?
|
||||
if($s{state} == STATE_NORMAL) {
|
||||
$s{title} = 'Create a ticker:';
|
||||
$s{submit} = 'Create ticker';
|
||||
$s{action} = 'create';
|
||||
$s{id} = "";
|
||||
$s{msg} = "";
|
||||
$s{link} = "";
|
||||
} elsif($s{state} == STATE_UPDATE) {
|
||||
$s{title} = 'Update a ticker:';
|
||||
$s{submit} = 'Update ticker';
|
||||
$s{action} = 'do_update';
|
||||
}
|
||||
|
||||
# print the form, which is configured for the type of action we're
|
||||
# performing:
|
||||
print qq{<h3>} . $s{title} . qq{</h3>
|
||||
<form method="post" action="} . ADMIN_URL . qq{">
|
||||
<input type="hidden" name="action" value="} .
|
||||
$s{action} . qq{"/>
|
||||
<input type="hidden" name="id" value="} . $s{id} . qq{"/>
|
||||
<div><label for="message">Message:</label>
|
||||
<input type="text" name="msg" value="} . $s{msg} . qq{"/>
|
||||
</div><div><label for="link">Link:</label>
|
||||
<input type="text" name="link" value="} . $s{link} . qq{"/>
|
||||
</div><div><input type="submit" value="} . $s{submit} . qq{"/>
|
||||
</div></form>
|
||||
};
|
||||
|
||||
# provide a way to get back to the create interface:
|
||||
if($s{action} =~ /update/) {
|
||||
print qq{<a href="} . ADMIN_URL . qq{">Create a ticker instead.</a>};
|
||||
}
|
||||
|
||||
# Now print the entire list of all tickers.
|
||||
print qq{<h3>Current tickers:</h3>};
|
||||
|
||||
|
||||
# If there are no tickers, say so:
|
||||
if(@{$s{data}} == 0) {
|
||||
print "There are no tickers.";
|
||||
} else {
|
||||
# Print a table showing the ID, delete/edit links, messages, and links:
|
||||
print "<table>";
|
||||
print "<tr><td>ID</td><td/><td/><td>Message</td><td>Link</td></tr>";
|
||||
foreach my $k (@{$s{data}}) {
|
||||
my $id = $k->{ticker_id};
|
||||
my $msg = $k->{ticker_text};
|
||||
my $link = $k->{ticker_link};
|
||||
print qq{<tr><td>$id</td><td>
|
||||
<a href="} . ADMIN_URL . qq{?action=delete&id=$id">Delete</a></td><td>
|
||||
<a href="} . ADMIN_URL . qq{?action=show_update&id=$id">Update</a></td><td>} .
|
||||
$msg . "</td><td>" .
|
||||
qq{<a href="} . $link . qq{">} .
|
||||
$link . "</a></td></tr>";
|
||||
}
|
||||
print "</table>";
|
||||
}
|
||||
print qq{</body></html>};
|
||||
}
|
||||
|
||||
8
site/forum.slowtwitch.com/cgi-bin/ticker/admin/sql.cgi
Executable file
8
site/forum.slowtwitch.com/cgi-bin/ticker/admin/sql.cgi
Executable file
@@ -0,0 +1,8 @@
|
||||
#!/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use Ticker;
|
||||
|
||||
Ticker::create_table();
|
||||
18
site/forum.slowtwitch.com/cgi-bin/ticker/coupons.cgi
Executable file
18
site/forum.slowtwitch.com/cgi-bin/ticker/coupons.cgi
Executable file
@@ -0,0 +1,18 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# Handle requests for the client-side view of the Ticker.
|
||||
#
|
||||
# Returns an xml document containing all the tickers currently present in
|
||||
# the database.
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
|
||||
print $IN->header();
|
||||
GForum::Template->parse_print('include_ticker_coupons.html');
|
||||
|
||||
17
site/forum.slowtwitch.com/cgi-bin/ticker/ticker.cgi
Executable file
17
site/forum.slowtwitch.com/cgi-bin/ticker/ticker.cgi
Executable file
@@ -0,0 +1,17 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# Handle requests for the client-side view of the Ticker.
|
||||
#
|
||||
# Returns an xml document containing all the tickers currently present in
|
||||
# the database.
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
|
||||
print $IN->header(-type => "text/xml");
|
||||
print Ticker::read_tickers_xml();
|
||||
@@ -0,0 +1,6 @@
|
||||
AuthUserFile /home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin/.htpasswd
|
||||
AuthGroupFile /dev/null
|
||||
AuthType Basic
|
||||
AuthName "Gossamer Forum Administration"
|
||||
|
||||
require valid-user
|
||||
160
site/forum.slowtwitch.com/cgi-bin/tickerad/admin/admin.cgi
Executable file
160
site/forum.slowtwitch.com/cgi-bin/tickerad/admin/admin.cgi
Executable file
@@ -0,0 +1,160 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# The ticker (client & admin) loosely follows an MVC architecture. The model
|
||||
# is over in TickerAd.pm (it does all the DB work). ticker.cgi is the view for
|
||||
# the client, while this is the view+controller for the admin.
|
||||
#
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use TickerAd;
|
||||
use Error qw(:try);
|
||||
|
||||
use constant {
|
||||
STATE_NORMAL => 0,
|
||||
STATE_UPDATE => 1,
|
||||
STATE_REDIRECT => 2,
|
||||
ADMIN_URL => "http://forum.slowtwitch.com/cgi-bin/tickerad/admin/admin.cgi"
|
||||
};
|
||||
|
||||
# prototypes.
|
||||
sub controller();
|
||||
sub view($);
|
||||
|
||||
# And call the controller.
|
||||
controller();
|
||||
|
||||
#
|
||||
# This is the controller. This is where work gets done.
|
||||
#
|
||||
sub controller() {
|
||||
my %viewstate = (state => STATE_NORMAL);
|
||||
|
||||
# if we have an action parameter (that's non-empty), then do work:
|
||||
if(defined $IN->param('action') && length($IN->param('action')) > 0) {
|
||||
$viewstate{state} = STATE_REDIRECT;
|
||||
try {
|
||||
my $p = $IN->get_hash();
|
||||
if($p->{action} =~ /create/) {
|
||||
TickerAd::create_ticker($p->{msg}, $p->{link});
|
||||
} elsif($p->{action} =~ /show_update/) {
|
||||
$viewstate{state} = STATE_UPDATE;
|
||||
$viewstate{id} = $p->{'id'};
|
||||
} elsif($p->{action} =~ /do_update/) {
|
||||
TickerAd::update_ticker($p->{'id'}, $p->{'msg'}, $p->{'link'});
|
||||
} elsif($p->{action} =~ /delete/) {
|
||||
TickerAd::delete_ticker($p->{'id'});
|
||||
}
|
||||
} catch TickerAd::TickerAdException with {
|
||||
# oops. something bad happened.
|
||||
$viewstate{error} = "Error: " . shift;
|
||||
# reset the viewstate so that we display the error message.
|
||||
$viewstate{state} = STATE_NORMAL;
|
||||
};
|
||||
}
|
||||
|
||||
return view(\%viewstate);
|
||||
}
|
||||
|
||||
|
||||
#
|
||||
# Build the view, which takes a single hashref describing how the view should
|
||||
# behave.
|
||||
#
|
||||
sub view($) {
|
||||
my ($state) = @_;
|
||||
my %s = %$state;
|
||||
|
||||
# If the state is redirect, we're done.
|
||||
if($s{state} == STATE_REDIRECT) {
|
||||
print $IN->redirect(ADMIN_URL);
|
||||
return;
|
||||
}
|
||||
|
||||
# Now let's actually build the view, depending on our current state:
|
||||
print $IN->header();
|
||||
print qq{<html><head><title>TickerAd Admin</title></head><body>};
|
||||
|
||||
# Try to load all the tickers:
|
||||
try {
|
||||
$s{data} = TickerAd::read_tickers();
|
||||
|
||||
# Are we also trying to update a record? Yeah, I know - we're
|
||||
# hitting the db again. I wish that fetchall_hashref actually worked...
|
||||
if(defined $s{id}) {
|
||||
my $result = TickerAd::read_ticker($s{id});
|
||||
$s{msg} = $result->{ticker_text};
|
||||
$s{link} = $result->{ticker_link};
|
||||
}
|
||||
} catch TickerAd::TickerAdException with {
|
||||
$s{error} .= " Could not read tickers from database!";
|
||||
};
|
||||
|
||||
# Print an error message if we have one:
|
||||
if(defined $s{error}) {
|
||||
print "<p>" . $s{error} . "</p>";
|
||||
}
|
||||
|
||||
# What should the top form look like?
|
||||
if($s{state} == STATE_NORMAL) {
|
||||
$s{title} = 'Create a ticker:';
|
||||
$s{submit} = 'Create ticker';
|
||||
$s{action} = 'create';
|
||||
$s{id} = "";
|
||||
$s{msg} = "";
|
||||
$s{link} = "";
|
||||
} elsif($s{state} == STATE_UPDATE) {
|
||||
$s{title} = 'Update a ticker:';
|
||||
$s{submit} = 'Update ticker';
|
||||
$s{action} = 'do_update';
|
||||
}
|
||||
|
||||
# print the form, which is configured for the type of action we're
|
||||
# performing:
|
||||
print qq{<h3>} . $s{title} . qq{</h3>
|
||||
<form method="post" action="} . ADMIN_URL . qq{">
|
||||
<input type="hidden" name="action" value="} .
|
||||
$s{action} . qq{"/>
|
||||
<input type="hidden" name="id" value="} . $s{id} . qq{"/>
|
||||
<div><label for="message">Message:</label>
|
||||
<input type="text" name="msg" value="} . $s{msg} . qq{"/>
|
||||
</div><div><label for="link">Link:</label>
|
||||
<input type="text" name="link" value="} . $s{link} . qq{"/>
|
||||
</div><div><input type="submit" value="} . $s{submit} . qq{"/>
|
||||
</div></form>
|
||||
};
|
||||
|
||||
# provide a way to get back to the create interface:
|
||||
if($s{action} =~ /update/) {
|
||||
print qq{<a href="} . ADMIN_URL . qq{">Create a ticker instead.</a>};
|
||||
}
|
||||
|
||||
# Now print the entire list of all tickers.
|
||||
print qq{<h3>Current tickers:</h3>};
|
||||
|
||||
|
||||
# If there are no tickers, say so:
|
||||
if(@{$s{data}} == 0) {
|
||||
print "There are no tickers.";
|
||||
} else {
|
||||
# Print a table showing the ID, delete/edit links, messages, and links:
|
||||
print "<table>";
|
||||
print "<tr><td>ID</td><td/><td/><td>Message</td><td>Link</td></tr>";
|
||||
foreach my $k (@{$s{data}}) {
|
||||
my $id = $k->{ticker_id};
|
||||
my $msg = $k->{ticker_text};
|
||||
my $link = $k->{ticker_link};
|
||||
print qq{<tr><td>$id</td><td>
|
||||
<a href="} . ADMIN_URL . qq{?action=delete&id=$id">Delete</a></td><td>
|
||||
<a href="} . ADMIN_URL . qq{?action=show_update&id=$id">Update</a></td><td>} .
|
||||
$msg . "</td><td>" .
|
||||
qq{<a href="} . $link . qq{">} .
|
||||
$link . "</a></td></tr>";
|
||||
}
|
||||
print "</table>";
|
||||
}
|
||||
print qq{</body></html>};
|
||||
}
|
||||
|
||||
8
site/forum.slowtwitch.com/cgi-bin/tickerad/admin/sql.cgi
Executable file
8
site/forum.slowtwitch.com/cgi-bin/tickerad/admin/sql.cgi
Executable file
@@ -0,0 +1,8 @@
|
||||
#!/bin/env perl
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use Ticker;
|
||||
|
||||
Ticker::create_table();
|
||||
18
site/forum.slowtwitch.com/cgi-bin/tickerad/coupons.cgi
Executable file
18
site/forum.slowtwitch.com/cgi-bin/tickerad/coupons.cgi
Executable file
@@ -0,0 +1,18 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# Handle requests for the client-side view of the Ticker.
|
||||
#
|
||||
# Returns an xml document containing all the tickers currently present in
|
||||
# the database.
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
|
||||
print $IN->header();
|
||||
GForum::Template->parse_print('include_ticker_coupons.html');
|
||||
|
||||
17
site/forum.slowtwitch.com/cgi-bin/tickerad/ticker.cgi
Executable file
17
site/forum.slowtwitch.com/cgi-bin/tickerad/ticker.cgi
Executable file
@@ -0,0 +1,17 @@
|
||||
#!/bin/env perl
|
||||
#
|
||||
# Handle requests for the client-side view of the Ticker.
|
||||
#
|
||||
# Returns an xml document containing all the tickers currently present in
|
||||
# the database.
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw($IN);
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
use Ticker;
|
||||
|
||||
print $IN->header(-type => "text/xml");
|
||||
print Ticker::read_tickers_xml();
|
||||
89
site/forum.slowtwitch.com/cgi-bin/toggle.cgi
Executable file
89
site/forum.slowtwitch.com/cgi-bin/toggle.cgi
Executable file
@@ -0,0 +1,89 @@
|
||||
#!/usr/bin/perl
|
||||
# ==================================================================
|
||||
# Gossamer Forum -
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: gforum.cgi,v 1.52.2.5 2003/10/10 20:30:01 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2003 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin';
|
||||
use GForum qw/:forum :user $DB $IN $CFG $USER $GUEST %HIDDEN $TEMPLATE_SET/;
|
||||
use GForum::Template;
|
||||
use GForum::Authenticate;
|
||||
|
||||
GForum::init('/home/slowtwitch/forum.slowtwitch.com/cgi-bin/admin');
|
||||
|
||||
main();
|
||||
|
||||
sub main {
|
||||
# -------------------------------------------------------------------
|
||||
# Display whatever page the user has requested
|
||||
#
|
||||
local $SIG{__DIE__} = \&GForum::fatal;
|
||||
|
||||
# Show the disabled page if the forum has been disabled
|
||||
if ($CFG->{disabled} == 1) {
|
||||
print $IN->header;
|
||||
my $message = $CFG->{disabled_message};
|
||||
$message =~ s/\n/<br>\n/g;
|
||||
return GForum::Template->parse_print("disabled.html" => { message => \$message });
|
||||
}
|
||||
{
|
||||
# If the user is banned, simply deny them access
|
||||
my @expanded_bans = @{$CFG->{bans}};
|
||||
for (@expanded_bans) {
|
||||
if (/^(\d+\.\d+\.\d+\.)(\d+)-(\d+)$/ and $2 < $3) {
|
||||
# Allows you to specify '123.45.67.89-123' to ban that range of IP's
|
||||
for ($2 .. $3) {
|
||||
push @expanded_bans, "$1$_";
|
||||
}
|
||||
next;
|
||||
}
|
||||
# Turn a ban into a regexp
|
||||
my $ban = quotemeta($_);
|
||||
# *'s match anything
|
||||
$ban =~ s/\\\*/.*/g;
|
||||
# ?'s match any single character
|
||||
$ban =~ s/\\\?/./g;
|
||||
if ($ENV{REMOTE_HOST} and $ENV{REMOTE_HOST} =~ /^$ban$/i or $ENV{REMOTE_ADDR} =~ /^$ban$/i) {
|
||||
print $IN->header;
|
||||
return GForum::Template->parse_print($CFG->{functions}->{banned}->{page}, { error => GForum::language('USER_BANNED') });
|
||||
}
|
||||
}
|
||||
}
|
||||
GForum::authenticate() or return; # False = stop!
|
||||
|
||||
if ($CFG->{disabled} == 2 and (not $USER or $USER->{user_status} != ADMINISTRATOR)) {
|
||||
print $IN->header;
|
||||
my $message = $CFG->{disabled_message};
|
||||
$message =~ s/\n/<br>\n/g;
|
||||
return GForum::Template->parse_print("disabled.html" => { message => \$message });
|
||||
}
|
||||
|
||||
my $template_set = $IN->param('t');
|
||||
if (not $template_set or $template_set !~ /^[\w-]+$/ or not -d "$CFG->{admin_root_path}/templates/$template_set" or $template_set =~ /^(?:help|admin|fileman|CVS)$/) {
|
||||
$template_set = '';
|
||||
}
|
||||
else { # It's good!
|
||||
$HIDDEN{t} = $template_set;
|
||||
}
|
||||
|
||||
if ($USER) {
|
||||
if ($USER->{user_show_racetags}) {
|
||||
$DB->table('User')->update({ user_show_racetags => 0 }, { user_id => $USER->{user_id} });
|
||||
print $IN->header . qq~Hidden <a href="#" onclick="return status_toggle()">(click to unhide)</a>~;
|
||||
}
|
||||
else {
|
||||
$DB->table('User')->update({ user_show_racetags => 1 }, { user_id => $USER->{user_id} });
|
||||
print $IN->header . qq~Viewable <a href="#" onclick="return status_toggle()">(click to hide)</a>~;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
27
site/forum.slowtwitch.com/cgi-bin/widget.cgi
Executable file
27
site/forum.slowtwitch.com/cgi-bin/widget.cgi
Executable file
@@ -0,0 +1,27 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
use lib '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin';
|
||||
|
||||
use Links qw/$PLG $IN $DB/;
|
||||
use Links::User::Page;
|
||||
|
||||
local $SIG{__DIE__} = \&Links::fatal;
|
||||
|
||||
Links::init('/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin');
|
||||
|
||||
my $id = $IN->param('id');
|
||||
|
||||
print $IN->header;
|
||||
if ($id) {
|
||||
my $tab = $DB->table('Widgets');
|
||||
my $widget = $tab->get($id);
|
||||
|
||||
if ($widget) {
|
||||
if ($widget->{Image}) {
|
||||
my $fh = $tab->file_info('Image', $widget->{ID});
|
||||
$widget->{Image_URL} = '/images/widgets/' . $fh->File_RelativeURL;
|
||||
}
|
||||
print Links::SiteHTML::display('include_widgets', { widgets_loop => [$widget] });
|
||||
}
|
||||
}
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 7.7 KiB |
1251
site/glist/lib/GList.pm
Normal file
1251
site/glist/lib/GList.pm
Normal file
File diff suppressed because it is too large
Load Diff
1344
site/glist/lib/GList/Admin.pm
Normal file
1344
site/glist/lib/GList/Admin.pm
Normal file
File diff suppressed because it is too large
Load Diff
246
site/glist/lib/GList/Authenticate.pm
Normal file
246
site/glist/lib/GList/Authenticate.pm
Normal file
@@ -0,0 +1,246 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Authenticate.pm,v 1.15 2004/04/15 19:46:36 bao 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 GList::Authenticate;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects/;
|
||||
use GT::Session::SQL;
|
||||
|
||||
sub auth {
|
||||
# -------------------------------------------------------------------
|
||||
# Runs the request auth function through the plugin system.
|
||||
#
|
||||
($_[0] eq 'GList::Authenticate') and shift;
|
||||
|
||||
my ($auth, $args) = @_;
|
||||
my $code = exists $GList::Authenticate::{"auth_$auth"} ? $GList::Authenticate::{"auth_$auth"} : die "Invalid Authenticate method: auth_$auth called.";
|
||||
GT::Plugins->dispatch("$CFG->{priv_path}/lib/GList/Plugins", "auth_$auth", $code, $args);
|
||||
}
|
||||
|
||||
sub auth_init {
|
||||
# -------------------------------------------------------------------
|
||||
# This function is guaranteed to be called before any other authentication
|
||||
# function, but may be called multiple times during one request.
|
||||
#
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub auth_get_user {
|
||||
# -------------------------------------------------------------------
|
||||
# This function returns user information for a given user, auto
|
||||
# creating if it doesn't exist.
|
||||
#
|
||||
my $args = shift;
|
||||
return $DB->table ('Users')->get({ usr_username => $args->{username}, usr_status => '1' });
|
||||
}
|
||||
|
||||
sub auth_valid_user {
|
||||
# -------------------------------------------------------------------
|
||||
# This function returns 1 if the user/pass combo is valid, 0/undef
|
||||
# otherwise.
|
||||
#
|
||||
my $args = shift;
|
||||
my $user = $DB->table('Users')->get($args->{username});
|
||||
return if ( !$user );
|
||||
|
||||
return ($user->{usr_password} eq GList::encrypt($args->{password}, $user->{usr_password})) ? 1 : 0;
|
||||
}
|
||||
|
||||
sub auth_create_session {
|
||||
# -------------------------------------------------------------------
|
||||
# This function creates a session, and prints the header and returns a
|
||||
# hash with session => $id, and redirect => 0/1.
|
||||
#
|
||||
my $args = shift;
|
||||
|
||||
my $uid = $args->{username};
|
||||
my $use_cookie = ( $CFG->{user_session} ) ? 0 : 1;
|
||||
my $session = GT::Session::SQL->new ({
|
||||
_debug => $CFG->{debug},
|
||||
tb => $DB->table('Users_Sessions'),
|
||||
session_user_id => $uid,
|
||||
session_data => { cookie => $use_cookie, do => scalar($IN->param('do')) },
|
||||
expires => $CFG->{session_exp},
|
||||
}
|
||||
);
|
||||
|
||||
if ( $GT::Session::SQL::error ) {
|
||||
return { error => $GT::Session::SQL::error };
|
||||
}
|
||||
# Delete all old sessions.
|
||||
$session->cleanup;
|
||||
if ($use_cookie) {
|
||||
print $IN->cookie(
|
||||
-name => 'sid',
|
||||
-value => $session->{info}->{session_id},
|
||||
)->cookie_header() . "\n";
|
||||
}
|
||||
return { session_id => $session->{info}->{session_id}, use_cookie => $use_cookie };
|
||||
}
|
||||
|
||||
sub auth_valid_session {
|
||||
# -------------------------------------------------------------------
|
||||
# This functions checks to see if the session is valid, and returns the
|
||||
# username.
|
||||
my $args = shift;
|
||||
my ($sid, $cookie);
|
||||
if ($IN->param ('sid')) {
|
||||
$sid = $IN->param ('sid');
|
||||
}
|
||||
elsif ( !$CFG->{user_session} and $IN->cookie ('sid') ) {
|
||||
$cookie = 1;
|
||||
$sid = $IN->cookie ('sid');
|
||||
}
|
||||
else { return }
|
||||
my $use_cookie = ( $CFG->{user_session} ) ? 0 : 1;
|
||||
|
||||
# Cookie authentication
|
||||
my $session = new GT::Session::SQL ({
|
||||
_debug => $CFG->{debug},
|
||||
tb => $DB->table('Users_Sessions'),
|
||||
session_id => $sid,
|
||||
expires => $CFG->{session_exp},
|
||||
session_data => { cookie => $use_cookie, do => scalar($IN->param('do')) },
|
||||
}) or return;
|
||||
|
||||
# Delete any of the user's expired sessions
|
||||
$sid = '' if ($session->{data}->{cookie});
|
||||
|
||||
# Must return the session id and the userid
|
||||
return { session_id => $session->{info}->{session_id}, use_cookie => $use_cookie, user_name => $session->{info}->{session_user_id} };
|
||||
}
|
||||
|
||||
sub auth_delete_session {
|
||||
# -------------------------------------------------------------------
|
||||
# This function removes a session, returns 1 on success, undef on
|
||||
# failure.
|
||||
#
|
||||
my $args = shift;
|
||||
my $sid;
|
||||
if ( $IN->param('sid') ) {
|
||||
$sid = $IN->param ('sid');
|
||||
}
|
||||
elsif ( !$CFG->{user_session} and $IN->cookie('sid') ) {
|
||||
$sid = $IN->cookie ('sid');
|
||||
}
|
||||
else { return }
|
||||
|
||||
my $session = new GT::Session::SQL (
|
||||
{
|
||||
_debug => $CFG->{debug},
|
||||
tb => $DB->table ('Users_Sessions'),
|
||||
session_id => $sid
|
||||
}
|
||||
) or return;
|
||||
|
||||
# Delete the cookie
|
||||
$session->delete or return;
|
||||
|
||||
# Print the cookie header
|
||||
if (!$CFG->{user_session}) {
|
||||
print $IN->cookie(
|
||||
-name => 'sid',
|
||||
-value => $sid,
|
||||
-expires => '-1h'
|
||||
)->cookie_header() . "\n";
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub auth_admin_valid_user {
|
||||
#---------------------------------------------------------
|
||||
#
|
||||
my $args = shift;
|
||||
|
||||
my $admins = $CFG->{admin};
|
||||
foreach my $u (keys % $admins) {
|
||||
my $pass = $admins->{$u}->[0];
|
||||
if ($u eq $args->{username} and GList::encrypt($args->{password}, $pass) eq $pass ) {
|
||||
return $args->{username};
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub auth_admin_create_session {
|
||||
#---------------------------------------------------------
|
||||
#
|
||||
my $args = shift;
|
||||
|
||||
# Clear out old sessions.
|
||||
require GT::Session::File;
|
||||
GT::Session::File->cleanup(1800, "$CFG->{priv_path}/tmp");
|
||||
|
||||
# Create a new session and save the information.
|
||||
my $session = new GT::Session::File ( directory => "$CFG->{priv_path}/tmp" );
|
||||
$session->{data}->{username} = $args->{username};
|
||||
my $session_id = $session->{id};
|
||||
$session->save;
|
||||
|
||||
# Now redirect to another URL and set cookies, or set URL string.
|
||||
my $redirect = 0;
|
||||
my $use_cookie = ( $CFG->{user_session} ) ? 0 : 1;
|
||||
if ($use_cookie) {
|
||||
print $IN->cookie (
|
||||
-name => 'session_id',
|
||||
-value => $session_id,
|
||||
-path => '/'
|
||||
)->cookie_header() . "\n";
|
||||
}
|
||||
return { session_id => $session_id, use_cookie => $use_cookie };
|
||||
}
|
||||
|
||||
sub auth_admin_valid_session {
|
||||
# -------------------------------------------------------------------
|
||||
# This functions checks to see if the session is valid, and returns the
|
||||
# username.
|
||||
#
|
||||
my $args = shift;
|
||||
|
||||
# Clear out old sessions.
|
||||
require GT::Session::File;
|
||||
GT::Session::File->cleanup(1800, "$CFG->{priv_path}/tmp");
|
||||
|
||||
my $session_id = $IN->param('session_id') || $IN->cookie('session_id') || return;
|
||||
my $session = new GT::Session::File (
|
||||
directory => "$CFG->{priv_path}/tmp",
|
||||
id => $session_id
|
||||
) || return;
|
||||
|
||||
my $use_cookie = ( $CFG->{user_session} ) ? 0 : 1;
|
||||
return { username => $session->{data}->{username}, session_id => $session_id, use_cookie => $use_cookie };
|
||||
}
|
||||
|
||||
sub auth_admin_delete_session {
|
||||
#--------------------------------------------------------
|
||||
#
|
||||
require GT::Session::File;
|
||||
my $session_id = $IN->cookie('session_id') || $IN->param('session_id') || return;
|
||||
my $session = new GT::Session::File(
|
||||
directory => "$CFG->{priv_path}/tmp",
|
||||
id => $session_id
|
||||
) || return;
|
||||
|
||||
print $IN->cookie(
|
||||
-name => 'session_id',
|
||||
-value => '',
|
||||
-path => '/'
|
||||
)->cookie_header() . "\n";
|
||||
|
||||
return $session->delete();
|
||||
}
|
||||
|
||||
1;
|
||||
196
site/glist/lib/GList/Config.pm
Normal file
196
site/glist/lib/GList/Config.pm
Normal file
@@ -0,0 +1,196 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Config.pm,v 1.7 2004/10/05 22:02:27 bao 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 GList::Config;
|
||||
# =============================================================================
|
||||
# Sets up our config variables -- if you are looking to hand edit variables the
|
||||
# data is in GList/Config/Data.pm, but you shouldn't have to do this, really!
|
||||
#
|
||||
use GT::Config();
|
||||
use vars qw/@ISA/;
|
||||
@ISA = 'GT::Config';
|
||||
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
# -----------------------------------------------------------------------------
|
||||
my $class = ref $_[0] ? ref shift : shift;
|
||||
my $path = shift || '.';
|
||||
|
||||
my $file = "$path/GList/Config/Data.pm";
|
||||
|
||||
my $self = $class->load($file => {
|
||||
debug => $GList::DEBUG,
|
||||
header => <<'HEADER'
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website: http://gossamer-threads.com/
|
||||
# Support: http://gossamer-threads.com/scripts/support/
|
||||
# Updated: [localtime]
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
HEADER
|
||||
});
|
||||
|
||||
$self->debug_level($self->{debug});
|
||||
|
||||
return $self;
|
||||
|
||||
$self->{priv_path} ||= '.';
|
||||
$self->{version} ||= $GList::VERSION;
|
||||
$self->{setup} ||= 0;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub tpl_load {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a hash of config variables for use in tempaltes.
|
||||
#
|
||||
my $t = {};
|
||||
while (my ($key, $val) = each %{$GList::CFG}) {
|
||||
(ref $val eq 'ARRAY') and ($val = join ",", @$val);
|
||||
(ref $val eq 'HASH') and do { my $tmp = ''; foreach (sort keys %$val) { $tmp .= "$_ = $val->{$_}, "; } chop $tmp; chop $tmp; $val = $tmp; };
|
||||
$t->{"cfg_$key"} = $GList::IN->html_escape($val);
|
||||
}
|
||||
return $t;
|
||||
}
|
||||
|
||||
sub defaults {
|
||||
# ------------------------------------------------------------------
|
||||
# Set sensible defaults for the config values, overwriting old values.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{setup} = 1;
|
||||
$self->default_path(1);
|
||||
$self->default_misc(1);
|
||||
}
|
||||
|
||||
sub create_defaults {
|
||||
# ------------------------------------------------------------------
|
||||
# Create defaults, does not overwrite old values.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->{setup} = 1;
|
||||
$self->default_path(0);
|
||||
$self->default_misc(0);
|
||||
}
|
||||
|
||||
sub set {
|
||||
# ------------------------------------------------------------------
|
||||
# Sets a value.
|
||||
#
|
||||
my ($self, $key, $val, $overwrite) = @_;
|
||||
if ($overwrite or ! exists $self->{$key}) { $self->{$key} = $val }
|
||||
}
|
||||
|
||||
sub default_path {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the path settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('cgi_url', _find_cgi_url(), $overwrite);
|
||||
$self->set('image_url', _find_image_url(), $overwrite);
|
||||
$self->set('path_to_perl', _find_perl(), $overwrite);
|
||||
$self->set('path_fileman', $self->{priv_path}, $overwrite);
|
||||
}
|
||||
|
||||
sub default_misc {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the misc settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('reg_number', '', $overwrite);
|
||||
$self->set('debug_level', 0, $overwrite);
|
||||
$self->set('user_session', '', $overwrite);
|
||||
$self->set('session_exp', 3, $overwrite);
|
||||
$self->set('scheduled_mailing_minute', 5, $overwrite);
|
||||
$self->set('admin_email', '', $overwrite);
|
||||
$self->set('smtp_server', '', $overwrite);
|
||||
$self->set('mail_path', _find_sendmail(), $overwrite);
|
||||
$self->set('highlight_color', 1, $overwrite);
|
||||
|
||||
# for attachments
|
||||
$self->set('max_attachments_size', 1024, $overwrite);
|
||||
|
||||
# for templates
|
||||
my $html_code = <<'HTML';
|
||||
<!-- CODE BEGINS-->
|
||||
<form method="post" action="<%url%>">
|
||||
Join <%name%>!<br>
|
||||
Email Address: <input name=email width=40><br>
|
||||
Name: <input name=name width=40><br>
|
||||
<select name="do">
|
||||
<option value="subscribe">Subscribe</option>
|
||||
<option value="unsubscribe">Unsubscribe</option>
|
||||
<input Type=submit value="Go">
|
||||
<input type=hidden name="lid" value="<%id%>">
|
||||
</form>
|
||||
<!-- CODE ENDS -->
|
||||
HTML
|
||||
|
||||
$self->set('html_code', $html_code, $overwrite);
|
||||
}
|
||||
|
||||
sub _find_cgi_url {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns basedir of current url.
|
||||
#
|
||||
my $url = GT::CGI->url({ absolute => 1, query_string => 0 });
|
||||
$url =~ s,/[^/]*$,,;
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub _find_image_url {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns image directory basedir from cgi basedir, replacing cgi with images
|
||||
#
|
||||
my $url = _find_cgi_url();
|
||||
$url =~ s,/cgi$,,;
|
||||
$url .= '/images';
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub _find_perl {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns path to perl.
|
||||
#
|
||||
my @poss_perls = qw(
|
||||
/usr/local/bin/perl /usr/bin/perl /bin/perl
|
||||
/usr/local/bin/perl5 /usr/bin/perl5 /bin/perl5
|
||||
/perl/bin/perl.exe c:/perl/bin/perl.exe d:/perl/bin/perl.exe
|
||||
);
|
||||
foreach my $perl_path (@poss_perls) {
|
||||
return $perl_path if -f $perl_path and -x _;
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
sub _find_sendmail {
|
||||
# ------------------------------------------------------------------
|
||||
# Looks for sendmail.
|
||||
#
|
||||
for (qw(/usr/sbin/sendmail /usr/lib/sendmail /usr/bin/sendmail /sbin/sendmail /bin/sendmail)) {
|
||||
return $_ if -f and -x _;
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
73
site/glist/lib/GList/Config/Data.pm
Normal file
73
site/glist/lib/GList/Config/Data.pm
Normal file
@@ -0,0 +1,73 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website: http://gossamer-threads.com/
|
||||
# Support: http://gossamer-threads.com/scripts/support/
|
||||
# Updated: Sat Feb 12 12:02:26 2022
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
{
|
||||
'admin' => {
|
||||
'admin' => [
|
||||
'$GT$YJ4E9RP4$khwtQz/NC7ErNdHmPNOAE0',
|
||||
'slowman@slowtwitch.com'
|
||||
],
|
||||
'rappstar' => [
|
||||
'$GT$HQRmVMKU$qsarcJtu/9LHJtzyZBTJt.',
|
||||
'rappstar@slowtwitch.com'
|
||||
]
|
||||
},
|
||||
'admin_email' => '',
|
||||
'allowed_space' => '100000',
|
||||
'cgi_url' => 'https://secure.slowtwitch.com/cgi-bin',
|
||||
'command_time_out' => '10',
|
||||
'debug_level' => '0',
|
||||
'highlight_color' => '1',
|
||||
'html_code' => '<!-- CODE BEGINS-->
|
||||
<form method="post" action="<%url%>">
|
||||
Join <%name%>!<br>
|
||||
Email Address: <input name=email width=40><br>
|
||||
Name: <input name=name width=40><br>
|
||||
<select name="do">
|
||||
<option value="user_subscribe">Subscribe</option>
|
||||
<option value="user_unsubscribe">Unsubscribe</option>
|
||||
</select>
|
||||
<input Type=submit value="Go">
|
||||
<input type=hidden name="lid" value="<%id%>">
|
||||
</form>
|
||||
<!-- CODE ENDS -->
|
||||
',
|
||||
'iframe_tracking' => '1',
|
||||
'image_path' => '/home/slowtwitch/secure.slowtwitch.com/secure-www/glist',
|
||||
'image_url' => 'https://secure.slowtwitch.com/glist',
|
||||
'mail_path' => '/usr/sbin/sendmail',
|
||||
'max_attachments_size' => '1024',
|
||||
'max_bounced_emails' => '10000',
|
||||
'path_fileman' => '/home/slowtwitch/site/glist',
|
||||
'path_to_perl' => '/usr/bin/perl',
|
||||
'priv_path' => '/home/slowtwitch/site/glist',
|
||||
'reg_number' => '',
|
||||
'scheduled_mailing_minute' => '5',
|
||||
'session_exp' => '3',
|
||||
'setup' => '1',
|
||||
'signup_admin_validate' => '0',
|
||||
'signup_email_validate' => '1',
|
||||
'signup_enable' => '0',
|
||||
'signup_limit_email30' => '100',
|
||||
'signup_limit_list' => '10',
|
||||
'signup_limit_sublist' => '10',
|
||||
'signup_restricted_email' => [],
|
||||
'signup_username_regex' => '^[\w\-\.]{3,}$',
|
||||
'smtp_server' => '',
|
||||
'static_url' => 'https://secure.slowtwitch.com/glist',
|
||||
'template_backups' => '1',
|
||||
'template_set' => 'gossamer',
|
||||
'user_session' => '0',
|
||||
'version' => '1.1.1'
|
||||
};
|
||||
|
||||
# vim:syn=perl:ts=4:noet
|
||||
30
site/glist/lib/GList/Custom.pm
Normal file
30
site/glist/lib/GList/Custom.pm
Normal file
@@ -0,0 +1,30 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Custom.pm,v 1.1 2004/01/13 01:19:23 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.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# By default, this file is empty, however it is here to allow installations
|
||||
# to perform special operations required to make Gossamer Mail load.
|
||||
# For example, some installations might need a 'use lib' line to work
|
||||
# properly.
|
||||
#
|
||||
# This file will NOT be overwritten when upgrading your installation, so you
|
||||
# do not need to worry about additions made here being overwritten. This is
|
||||
# generally loaded after GMail.pm has started loading, but before any other
|
||||
# modules are loaded.
|
||||
#
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
1; # This must remain at the bottom of the file
|
||||
249
site/glist/lib/GList/GUI.pm
Normal file
249
site/glist/lib/GList/GUI.pm
Normal file
@@ -0,0 +1,249 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: GUI.pm,v 1.5 2004/08/24 19:28:37 bao 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 GList::GUI;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects/;
|
||||
|
||||
sub gui_profile_form {
|
||||
# -------------------------------------------------------------------
|
||||
require GT::SQL::Display::HTML;
|
||||
require GT::SQL::Display::HTML::Table;
|
||||
|
||||
my $opts = {@_};
|
||||
my $user_tb = $DB->table('Users');
|
||||
|
||||
$opts->{cols} ||= [ grep(/^pro_/, $user_tb->ordered_columns) ];
|
||||
$opts->{tr} ||= 'class="body"';
|
||||
$opts->{td_l} ||= 'class="body" width="40%" align="right"';
|
||||
$opts->{td_r} ||= 'class="body" align="left"';
|
||||
$opts->{cols} ||= [];
|
||||
$opts->{mode} ||= 'edit';
|
||||
$opts->{required} ||= ($opts->{mode} eq 'search') ? '' : '*';
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
my $cols = $user_tb->cols;
|
||||
my $disp = $DB->html($user_tb, GT::Template->tags);
|
||||
my $html = '';
|
||||
my $prefix = $opts->{prefix} || '';
|
||||
|
||||
if ( $opts->{mode} eq 'hidden' ) {
|
||||
|
||||
# Preserve all columns that relate to the Users database
|
||||
my $cols = $user_tb->cols;
|
||||
my $hidden_html = '';
|
||||
foreach my $col ( keys %$cols ) {
|
||||
foreach my $name ( map { "$col$_" } ( '', qw( -opt -gt -lt -le -ge -ne )) ) {
|
||||
my $v = $tags->{$name};
|
||||
next unless defined $v;
|
||||
my $input_html = gui_form_control({
|
||||
form_type => 'hidden',
|
||||
value => $v,
|
||||
name => $name
|
||||
});
|
||||
$html .= $$input_html;
|
||||
}
|
||||
}
|
||||
return \$html;
|
||||
}
|
||||
|
||||
my %search_defs = (
|
||||
string => { names => [qw( LIKE <> = )] },
|
||||
number => { names => [qw( = <> < <= > >= )] },
|
||||
date => { names => [ '', qw( = <> < <= > >= )] },
|
||||
radio => { names => [qw( = <> )] },
|
||||
minimal => { names => [qw( = )] }
|
||||
);
|
||||
|
||||
foreach my $col (@{$opts->{cols}}) {
|
||||
my $control_opts = {%{$cols->{$col}||{}}};
|
||||
$control_opts->{name} = $col;
|
||||
$control_opts->{value} = $tags->{$col};
|
||||
my $title = GList::language( $cols->{$col}{form_display} );
|
||||
my $input_html = gui_form_control({
|
||||
name => "$prefix$col",
|
||||
value=> ($opts->{mode} eq 'search') ? '' : $tags->{"$prefix$col"},
|
||||
def => $control_opts
|
||||
});
|
||||
$html .= ( $cols->{$col}->{not_null} ) ?
|
||||
"<tr $opts->{tr}><td $opts->{td_l}><ul/>$title</td><td $opts->{td_r}>$$input_html $opts->{required}</td></tr>" :
|
||||
"<tr $opts->{tr}><td $opts->{td_l}><ul/>$title</td><td $opts->{td_r}>$$input_html</td></tr>";
|
||||
}
|
||||
return \$html;
|
||||
}
|
||||
|
||||
sub gui_form_control {
|
||||
# -------------------------------------------------------------------
|
||||
require GT::SQL::Display::HTML;
|
||||
require GT::SQL::Display::HTML::Table;
|
||||
require GT::Template;
|
||||
|
||||
my $opts = ref $_[0] eq 'HASH' ? shift : {@_};
|
||||
|
||||
my $user_tb = $DB->table('Users');
|
||||
my $tags = GT::Template->tags || {};
|
||||
my $disp = $DB->html($user_tb, $tags);
|
||||
|
||||
my $form_type = lc $opts->{def}->{form_type};
|
||||
exists $opts->{blank} or $opts->{blank} = $form_type eq 'select' ? 1 : 0;
|
||||
|
||||
$opts->{def}->{class} = 'object' if ($form_type !~ /radio|checkbox/);
|
||||
my $input_html = 'radio' eq $form_type ? $disp->radio( $opts ) :
|
||||
'checkbox' eq $form_type ? $disp->checkbox( $opts ) :
|
||||
'select' eq $form_type ? $disp->select( $opts ) :
|
||||
'hidden' eq $form_type ? $disp->hidden( $opts ) :
|
||||
'multiple' eq $form_type ? $disp->multiple( $opts ) :
|
||||
'textarea' eq $form_type ? $disp->textarea( $opts ) :
|
||||
'file' eq $form_type ? "File type not supported." :
|
||||
'date' eq $form_type ? do {
|
||||
require GT::Date;
|
||||
my ($sel_year, $sel_mon, $sel_day) = split /\-/, GT::CGI::html_escape($opts->{value});
|
||||
$sel_year ||= 1970;
|
||||
$sel_mon ||= 1;
|
||||
$sel_day ||= 1;
|
||||
my $month_sel = $disp->select({
|
||||
name => "$opts->{name}-mon",
|
||||
value => $sel_mon,
|
||||
values => { map { sprintf("%02d", $_) => $GT::Date::LANGUAGE->{short_month_names}->[$_ - 1] } (1 .. 12) },
|
||||
sort => [ map { sprintf("%02d", $_) } (1 .. 12) ],
|
||||
blank => 0
|
||||
});
|
||||
my $day_sel = $disp->select({
|
||||
name => "$opts->{name}-day",
|
||||
value => $sel_day,
|
||||
values => { map { sprintf("%02d", $_) => $_ } (1 .. 31) },
|
||||
sort => [ map { sprintf("%02d", $_) } (1 .. 31) ],
|
||||
blank => 0
|
||||
});
|
||||
qq~
|
||||
$day_sel /
|
||||
$month_sel /
|
||||
<input type="text" name="$opts->{name}-year" value="$sel_year" size="4" maxlength="4">
|
||||
~;
|
||||
} :
|
||||
$disp->text($opts);
|
||||
|
||||
return \$input_html;
|
||||
}
|
||||
|
||||
sub gui_toolbar {
|
||||
my %input = @_;
|
||||
my $tags = GT::Template->tags;
|
||||
$input{first} ||= q|<img src="$image_url/icons/first.gif" border="0" width="17" height="11" alt="First page">|;
|
||||
$input{first_grey} ||= q|<img src="$image_url/icons/first_grey.gif" border="0" width="17" height="11" alt="First page">|;
|
||||
$input{prev} ||= q|<img src="$image_url/icons/prev.gif" border="0" width="10" height="11" alt="Previous page">|;
|
||||
$input{prev_grey} ||= q|<img src="$image_url/icons/prev_grey.gif" border="0" width="10" height="11" alt="Previous page">|;
|
||||
$input{next} ||= q|<img src="$image_url/icons/next.gif" border="0" width="10" height="11" alt="Next page">|;
|
||||
$input{next_grey} ||= q|<img src="$image_url/icons/next_grey.gif" border="0" width="10" height="11" alt="Next page">|;
|
||||
$input{last} ||= q|<img src="$image_url/icons/last.gif" border="0" width="17" height="11" alt="Last page">|;
|
||||
$input{last_grey} ||= q|<img src="$image_url/icons/last_grey.gif" border="0" width="17" height="11" alt="Last page">|;
|
||||
$input{view_all} ||= q|View All|;
|
||||
$input{pages} ||= 9;
|
||||
$input{'...'} ||= '...';
|
||||
$input{'first_...'} ||= 1;
|
||||
$input{'last_...'} ||= 1;
|
||||
$input{before_page} ||= q||;
|
||||
$input{after_page} ||= q||;
|
||||
$input{before_current} ||= q|<b>|;
|
||||
$input{after_current} ||= q|</b>|;
|
||||
$input{'glist.cgi'} ||= 'glist.cgi';
|
||||
|
||||
for (keys %input) {
|
||||
$input{$_} =~ s/\$image_url/$tags->{image_url}/g;
|
||||
}
|
||||
|
||||
my $hidden_query = ${$tags->{hidden_query} || \''};
|
||||
|
||||
my $num_page_items = ref $tags->{num_page_items} eq 'SCALAR' ? ${$tags->{num_page_items}} : $tags->{num_page_items};
|
||||
my $paging = GList::paging($num_page_items, @$tags{qw/mh nh/}, @input{qw/pages last_.../});
|
||||
($paging, my ($top_page, $ddd)) = @$paging{'paging', 'top_page', 'dotdotdot'};
|
||||
my $return = '';
|
||||
my $search = '';
|
||||
if ($tags->{toolbar_table}) {
|
||||
my $cols = $DB->table($tags->{toolbar_table})->cols;
|
||||
foreach my $c (keys %{$cols}) {
|
||||
next unless $tags->{$c};
|
||||
$search .= qq|$c=$tags->{$c};|;
|
||||
if ($tags->{"$c-opt"}) { $search .= qq|$c-opt=$tags->{"$c-opt"};|; }
|
||||
}
|
||||
}
|
||||
|
||||
my $link = sub {
|
||||
my ($page, $disp) = @_;
|
||||
$return .= qq|<a href="$input{'glist.cgi'}?do=$tags->{do};|;
|
||||
if ($tags->{toolbar_query}) {
|
||||
my $query = ref $tags->{toolbar_query} ? ${$tags->{toolbar_query}} : $tags->{toolbar_query};
|
||||
$return .= qq|$query;|;
|
||||
}
|
||||
if ($search) {
|
||||
$return .= qq|$search|;
|
||||
}
|
||||
$return .= qq|nh=$page;|;
|
||||
if ($tags->{users}) { $return .= qq|users=1;| }
|
||||
if ($tags->{show_user}) { $return .= qq|show_user=1;| }
|
||||
if ($tags->{fd}) { $return .= qq|fd=$tags->{fd};| }
|
||||
if ($tags->{sb}) { $return .= qq|sb=$tags->{sb};| }
|
||||
if ($tags->{so}) { $return .= qq|so=$tags->{so};| }
|
||||
if ($tags->{mh}) { $return .= qq|mh=$tags->{mh};| }
|
||||
if ($tags->{id}) { $return .= qq|id=$tags->{id};| }
|
||||
if ($tags->{cs}) { $return .= qq|cs=$tags->{cs};| }
|
||||
if ($tags->{first}) { $return .= qq|first=$tags->{first};| }
|
||||
if ($tags->{mn_disable}){ $return .= qq|mn_disable=1;| }
|
||||
|
||||
$return .= qq|$hidden_query">$disp</a>\n|;
|
||||
};
|
||||
|
||||
unless ($top_page == 1) {
|
||||
if ($tags->{nh} == 1) {
|
||||
$return .= $input{first_grey} . "\n";
|
||||
$return .= $input{prev_grey} . "\n";
|
||||
}
|
||||
else {
|
||||
my $prev = ($tags->{nh} == -1) ? 1 : ($tags->{nh} - 1);
|
||||
$link->(1, $input{first});
|
||||
$link->($prev, $input{prev});
|
||||
}
|
||||
|
||||
if (@$paging and $paging->[0]->{page_num} > 1 and $input{'first_...'}) {
|
||||
$link->(1, qq|$input{before_page}1$input{after_page}|);
|
||||
$return .= "$input{before_page}$input{'...'}" . ($input{after_page} || " ") if $paging->[0]->{page_num} > 2;
|
||||
}
|
||||
for (@$paging) {
|
||||
if ($_->{is_current_page}) {
|
||||
$return .= qq|$input{before_current}$_->{page_num}$input{after_current}\n|;
|
||||
}
|
||||
else {
|
||||
$link->($_->{page_num}, qq|$input{before_page}$_->{page_num}$input{after_page}|);
|
||||
}
|
||||
}
|
||||
if ($ddd) {
|
||||
$return .= "$input{before_page}$input{'...'}" . ($input{after_page} || " ");
|
||||
$link->($top_page, "$input{before_page}$top_page$input{after_page}");
|
||||
}
|
||||
|
||||
if ($tags->{nh} >= $top_page) {
|
||||
$return .= $input{next_grey} . "\n";
|
||||
$return .= $input{last_grey} . "\n";
|
||||
}
|
||||
else {
|
||||
my $next = ($tags->{nh} == -1) ? 1 : ($tags->{nh} + 1);
|
||||
$link->($next, $input{next});
|
||||
$link->($top_page, $input{last});
|
||||
}
|
||||
}
|
||||
return \$return;
|
||||
}
|
||||
1;
|
||||
88
site/glist/lib/GList/HTML.pm
Normal file
88
site/glist/lib/GList/HTML.pm
Normal file
@@ -0,0 +1,88 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: HTML.pm,v 1.10 2004/03/01 21:38:38 bao 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 GList::HTML;
|
||||
|
||||
use strict;
|
||||
use GList q/:objects/;
|
||||
|
||||
sub date_get {
|
||||
#----------------------------------------------------------------------
|
||||
#
|
||||
my ($fld_name, $type) = @_;
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
my $format = $tags->{usr_date_format};
|
||||
$format =~ s/\#/\%/g;
|
||||
$format ||= '%mm%-%dd%-%yyyy%';
|
||||
$format .= ' %hh%:%MM%:%ss%' if ( $type );
|
||||
|
||||
require GT::Date;
|
||||
( $fld_name ) or return GT::Date::date_get(time, $format);
|
||||
|
||||
my $record = $tags->{results}[$tags->{row_num} - 1];
|
||||
return GT::Date::date_get($record->{$fld_name} || $tags->{$fld_name}, $format);
|
||||
}
|
||||
|
||||
sub html_unescape {
|
||||
#--------------------------------------------------------------------
|
||||
#
|
||||
my $content = shift;
|
||||
$content =~ s/\n/<br>/g;
|
||||
return $content;
|
||||
}
|
||||
|
||||
sub generate_attachments {
|
||||
#---------------------------------------------------------------------
|
||||
#
|
||||
my $col = shift || 'msg_id';
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
my $val = $tags->{results}[$tags->{row_num} - 1]->{$col};
|
||||
( $val ) or return;
|
||||
|
||||
my $sth;
|
||||
if ( $col eq 'msg_id' ) {
|
||||
$sth = $tags->{html}->{sql}->table('MessageAttachments')->select({ att_message_id_fk => $val });
|
||||
}
|
||||
else {
|
||||
$sth = $tags->{html}->{sql}->table('MailingAttachments')->select({ mat_mailing_id_fk => $val });
|
||||
}
|
||||
my $attachments;
|
||||
while ( my $rs = $sth->fetchrow_hashref ) {
|
||||
push @$attachments, $rs;
|
||||
}
|
||||
|
||||
return { attachments => ( !$attachments ) ? 0 : $attachments };
|
||||
}
|
||||
|
||||
sub generate_years {
|
||||
#-------------------------------------------------------------------
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
my $min = $tags->{html}->{sql}->table('MailingIndex')->select(['MIN(mli_done)'])->fetchrow_array || time;
|
||||
|
||||
require GT::Date;
|
||||
my $yy_min = GT::Date::date_get($min, '%yyyy%');
|
||||
my $yy_max = GT::Date::date_get(time, '%yyyy%');
|
||||
my @output;
|
||||
for my $i ( $yy_min .. $yy_max ) {
|
||||
push @output, { y => $i };
|
||||
}
|
||||
return { loop_years => \@output };
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
833
site/glist/lib/GList/List.pm
Normal file
833
site/glist/lib/GList/List.pm
Normal file
@@ -0,0 +1,833 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: List.pm,v 1.50 2004/11/04 17:54:05 bao 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 GList::List;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects :user_type $DEBUG/;
|
||||
use GT::AutoLoader;
|
||||
|
||||
sub process {
|
||||
#-------------------------------------------------------------------
|
||||
# Setermine what to do
|
||||
#
|
||||
my $do = shift;
|
||||
|
||||
my $action = _determine_action($do) or die "Error: Invalid Action! ($do)";
|
||||
my ($tpl, $results) = GT::Plugins->dispatch($CFG->{priv_path}.'/lib/GList/Plugins', $action, \&$action);
|
||||
|
||||
$tpl ||= 'lst_home.html';
|
||||
$MN_SELECTED = 2;
|
||||
|
||||
my $hidden = GList::hidden();
|
||||
$results->{hidden_query} = $hidden->{hidden_query};
|
||||
$results->{hidden_objects} = $hidden->{hidden_objects};
|
||||
GList::display($tpl, $results);
|
||||
}
|
||||
|
||||
$COMPILE{lst_home} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_home {
|
||||
#--------------------------------------------------------------------
|
||||
# Print home page
|
||||
#
|
||||
my $msg = shift;
|
||||
my $cgi = $IN->get_hash;
|
||||
if (defined $cgi->{do} and $cgi->{do} =~ /^lst_add|lst_modify|lst_html/) {
|
||||
foreach ( $DB->table('Lists')->cols ) { $cgi->{$_} = ''; }
|
||||
}
|
||||
my $search_check = ($IN->param('do') eq 'lst_search') ? 1 : 0;
|
||||
my $query = '';
|
||||
if ($cgi->{'lst_date_created-ge'} or $cgi->{'lst_date_created-le'}) {
|
||||
my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%';
|
||||
my ($valid_from, $valid_to) = (1, 1);
|
||||
require GT::Date;
|
||||
if ($cgi->{'lst_date_created-ge'}) {
|
||||
$query .= "lst_date_created-ge=$cgi->{'lst_date_created-ge'};";
|
||||
$valid_from = GList::date_to_time($cgi->{'lst_date_created-ge'}, $format);
|
||||
$cgi->{'lst_date_created-ge'} = GT::Date::date_get($valid_from, $format);
|
||||
}
|
||||
if ($cgi->{'lst_date_created-le'}) {
|
||||
$query .= "lst_date_created-le=$cgi->{'lst_date_created-le'};";
|
||||
$valid_to = GList::date_to_time($cgi->{'lst_date_created-le'}, $format);
|
||||
$cgi->{'lst_date_created-le'} = GT::Date::date_get($valid_to, $format);
|
||||
}
|
||||
|
||||
if ($search_check and (!$valid_from or !$valid_to)) {
|
||||
$format =~ s/\%//g;
|
||||
return lst_search_form(GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')));
|
||||
}
|
||||
}
|
||||
my $results = GList::search(
|
||||
cgi => $cgi,
|
||||
db => $DB->table('Lists'),
|
||||
prefix => 'lst',
|
||||
sb => 'lst_title',
|
||||
so => 'ASC',
|
||||
search_check=> $search_check,
|
||||
select_all => $cgi->{select_all}
|
||||
);
|
||||
|
||||
if (ref $results ne 'HASH') {
|
||||
($IN->param('do') eq 'lst_search') ? return (lst_search_form($results))
|
||||
: return ('lst_home.html', { msg => $results });
|
||||
}
|
||||
elsif ($results->{error} and $search_check) {
|
||||
return lst_search_form($results->{error});
|
||||
}
|
||||
|
||||
require GT::SQL::Condition;
|
||||
my $subs = $DB->table('Subscribers');
|
||||
my $output = $results->{results};
|
||||
my @lists = map $_->{lst_id}, @$output;
|
||||
|
||||
$subs->select_options("GROUP BY sub_list_id_fk");
|
||||
my %subscribers = $subs->select(sub_list_id_fk => 'COUNT(*)', { sub_list_id_fk => \@lists })->fetchall_list;
|
||||
|
||||
$subs->select_options("GROUP BY sub_list_id_fk");
|
||||
my %validateds = $subs->select(sub_list_id_fk => 'COUNT(*)', { sub_list_id_fk => \@lists, sub_validated => 1 })->fetchall_list;
|
||||
|
||||
$subs->select_options("GROUP BY sub_list_id_fk");
|
||||
my %bounceds = $subs->select(sub_list_id_fk => 'COUNT(*)', GT::SQL::Condition->new(sub_list_id_fk => 'IN' => \@lists, sub_bounced => '>=' => 1))->fetchall_list;
|
||||
|
||||
foreach my $rs (@$output) {
|
||||
$rs->{subscribers} = $subscribers{$rs->{lst_id}};
|
||||
$rs->{validateds} = $validateds{$rs->{lst_id}};
|
||||
$rs->{bounceds} = $bounceds{$rs->{lst_id}};
|
||||
}
|
||||
|
||||
if ($cgi->{select_all}) {
|
||||
my $sorted = _qsort($results->{results}, $cgi->{sb}, ($cgi->{so} eq 'ASC') ? 1 : 0);
|
||||
my @sorted;
|
||||
my $mh = $results->{mh};
|
||||
my $nh = $results->{nh} || 1;
|
||||
my $bg = ( $nh == 1 ) ? 0 : ( $nh - 1 ) * $mh;
|
||||
my $count = 0;
|
||||
if ( $bg < $results->{hits} ) {
|
||||
foreach my $i (0..($results->{hits} - 1)) {
|
||||
if ($i >= $bg) {
|
||||
push @sorted, $sorted->[$i];
|
||||
last if ($#sorted == $mh - 1);
|
||||
}
|
||||
}
|
||||
$results->{results} = \@sorted;
|
||||
}
|
||||
else {
|
||||
$results->{results} = [];
|
||||
}
|
||||
}
|
||||
$results->{msg} = $msg if ($msg);
|
||||
return ('lst_home.html', { %$results, toolbar_query => $query });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_add} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_add {
|
||||
#--------------------------------------------------------------------
|
||||
#
|
||||
return ('lst_add_form.html') if ($IN->param('form'));
|
||||
|
||||
# Check account limit if it's a limited user
|
||||
if ($USER->{usr_type} == LIMITED_USER and GList::check_limit('list')) {
|
||||
return lst_home($GList::error);
|
||||
}
|
||||
|
||||
my $ret = GList::add('Lists', 'lst');
|
||||
return ('lst_add_form.html', { msg => "<font color=red>$GList::error</font>", help => 'lists_add.html' }) if ( $GList::error );
|
||||
|
||||
my $name = $IN->param('lst_title');
|
||||
return lst_home(GList::language('LST_ADD_SUCCESS', $name));
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_modify_form} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_modify_form {
|
||||
#--------------------------------------------------------------------
|
||||
# Print modify form
|
||||
#
|
||||
my $msg = shift;
|
||||
|
||||
return lst_home(GList::language('LST_INVALID')) unless ($IN->param('lst_id'));
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $IN->param('lst_id'));
|
||||
return home($info) if (ref $info ne 'HASH');
|
||||
|
||||
return ('lst_modify_form.html', { msg => $msg, %$info, help => 'lists_add.html' });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_modify} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_modify {
|
||||
#--------------------------------------------------------------------
|
||||
#
|
||||
GList::modify('Lists', 'lst');
|
||||
return lst_modify_form("<font color=red>$GList::error</font>") if ( $GList::error );
|
||||
|
||||
my $title = $IN->param('lst_title');
|
||||
lst_home(GList::language('LST_MOD_SUCCESS', $title));
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_search_form} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_search_form {
|
||||
#--------------------------------------------------------------------
|
||||
# Print add form
|
||||
#
|
||||
my $msg = shift;
|
||||
return ('lst_search_form.html', { msg => $msg });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_delete} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_delete {
|
||||
#--------------------------------------------------------------------
|
||||
# Delete lists
|
||||
#
|
||||
return lst_home(GList::delete('Lists', 'lst'));
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_html} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_html {
|
||||
#-----------------------------------------------------------------
|
||||
#
|
||||
return lst_home(GList::language('LST_INVALID')) unless ($IN->param('lst_id'));
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $IN->param('lst_id'));
|
||||
return lst_home($info) if (ref $info ne 'HASH');
|
||||
|
||||
my $msg = $CFG->{html_code};
|
||||
$msg =~ s/<%name%>/$info->{lst_title}/;
|
||||
$msg =~ s/<%id%>/$info->{lst_id}/;
|
||||
$msg =~ s/<%url%>/$CFG->{cgi_url}\/glist.cgi/;
|
||||
return ('lst_html.html', { msg => $msg, lst_title => $info->{lst_title} });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_import} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_import {
|
||||
#-----------------------------------------------------------------
|
||||
# Import data into subcribers table
|
||||
#
|
||||
return ('lst_import_form.html', { help => 'lists_import.html' }) if ($IN->param('form'));
|
||||
|
||||
my $data = $IN->param('sub_file') || $IN->param('sub_data');
|
||||
return ('lst_import_form.html', { msg => GList::language('LST_IPT_INVALID'), help => 'lists_import.html' }) unless ($data);
|
||||
return ('lst_import_form.html', { msg => GList::language('LST_IPT_LIST_EMPTY'), help => 'lists_import.html' }) unless ($IN->param('import_to'));
|
||||
|
||||
my $import_to = (ref $IN->param('import_to') eq 'ARRAY') ? $IN->param('import_to') : [$IN->param('import_to')];
|
||||
my $fd = $IN->param('fd') || ',';
|
||||
my $fe = $IN->param('fe') || '\\';
|
||||
my $rd = $IN->param('rd') || '\n';
|
||||
my $rl = $IN->param('rl') || 0;
|
||||
|
||||
# Setup the language for GT::SQL.
|
||||
local $GT::SQL::ERRORS->{UNIQUE} = GList::language('LST_IPT_DUPLICATE_EMAIL');
|
||||
local $GT::SQL::ERRORS->{NOTNULL} = GList::language('LST_IMP_NOTNULL') if ( GList::language('LST_IMP_NOTNULL') );
|
||||
local $GT::SQL::ERRORS->{ILLEGALVAL} = '';
|
||||
|
||||
my (@data, @results);
|
||||
if ($IN->param('sub_file')) { # from a text file
|
||||
my $file_name = $data;
|
||||
$file_name =~ s/.*?([^\\\/:]+)$/$1/;
|
||||
$file_name =~ s/[\[\]\s\$\#\%'"]/\_/g;
|
||||
$file_name = "$CFG->{priv_path}/tmp/$file_name";
|
||||
open (OUTFILE, "> $file_name") ;
|
||||
binmode(OUTFILE);
|
||||
my ($bytesread, $buffer, $count);
|
||||
while ($bytesread = read($data, $buffer, 1024)) {
|
||||
$buffer =~ s,\r\n,\n,g;
|
||||
print OUTFILE $buffer;
|
||||
}
|
||||
close OUTFILE;
|
||||
|
||||
if (!-T $file_name) {
|
||||
unlink $file_name;
|
||||
return lst_import_form(GList::language('LST_IPT_INVALID_FILE'));
|
||||
}
|
||||
|
||||
open (DATA, "< $file_name");
|
||||
my @lines = <DATA>;
|
||||
close DATA;
|
||||
unlink $file_name;
|
||||
|
||||
LINE: foreach (@lines) {
|
||||
$count++;
|
||||
( /^#/ ) and next LINE;
|
||||
( /^\s*$/ ) and next LINE;
|
||||
( $count eq $rl ) and next LINE;
|
||||
push @data, $_;
|
||||
}
|
||||
}
|
||||
else { # from listings
|
||||
@data = split(/$rd/, $data);
|
||||
}
|
||||
foreach my $id (@$import_to) {
|
||||
my $results = _import_subscriber($id, \@data);
|
||||
if (ref $results eq 'HASH') {
|
||||
push @results, $results;
|
||||
}
|
||||
else {
|
||||
push @results, { lst_id => $id, error => $results };
|
||||
}
|
||||
}
|
||||
return ('lst_import_success.html', { import_results => \@results });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_import_subscriber} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _import_subscriber {
|
||||
#-----------------------------------------------------------------
|
||||
#
|
||||
my ($list_id, $data) = @_;
|
||||
|
||||
# Verify data before importing
|
||||
return GList::language('LST_INVALID') if (!$list_id or !$data);
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $list_id);
|
||||
return $info if (ref $info ne 'HASH');
|
||||
|
||||
if (GList::check_limit('sublist', $list_id)) {
|
||||
return { list_name => $info->{lst_title}, overlimit => 1 };
|
||||
}
|
||||
my $db = $DB->table('Subscribers');
|
||||
my $fd = $IN->param('fd') || ',';
|
||||
my $fe = $IN->param('fe') || '\\';
|
||||
my $rd = $IN->param('rd') || '\n';
|
||||
my $rl = $IN->param('rl') || 0;
|
||||
|
||||
# Create stoplist database and load wild cards
|
||||
my $db_stl = $DB->table('StopLists');
|
||||
my $wild_cards = GList::wild_cards();
|
||||
|
||||
my @results;
|
||||
my ($invalid, $duplicate) = (0, 0);
|
||||
foreach my $row ( @$data ) {
|
||||
$row =~ s/[\r\n\"]//g; # Remove Windows linefeed character.
|
||||
if ($IN->param('cname')) {
|
||||
my ($n, $e) = split(/$fd/, $row);
|
||||
$e = $1 if ($e =~ /<([^> ]+)>/);
|
||||
$e = lc $e;
|
||||
my $error = _check_subscriber($e, $list_id, $db_stl, $wild_cards);
|
||||
if ($error) {
|
||||
push @results, { list_name => $info->{lst_title}, sub_email => $e || $n, status => $error };
|
||||
$invalid++;
|
||||
}
|
||||
else {
|
||||
push @results, { list_name => $info->{lst_title}, sub_email => $e || $n, status => '' };
|
||||
if ($db->count({ sub_email => $e, sub_list_id_fk => $list_id })) {
|
||||
$db->update({ sub_name => $n }, { sub_email => $e, sub_list_id_fk => $list_id }) if $n;
|
||||
$results[-1]->{status} = GList::language('SYS_DUPLICATE');
|
||||
$duplicate++;
|
||||
}
|
||||
else {
|
||||
$db->insert({ sub_email => $e, sub_name => $n, sub_created => time, sub_list_id_fk => $list_id, sub_user_id_fk => $info->{lst_user_id_fk} });
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$row = $1 if ($row =~ /<([^> ]+)>/);
|
||||
$row = lc $row;
|
||||
my $error = _check_subscriber($row, $list_id, $db_stl, $wild_cards);
|
||||
if ($error) {
|
||||
push @results, { list_name => $info->{lst_title}, sub_email => $row, status => $error };
|
||||
$invalid++;
|
||||
}
|
||||
else {
|
||||
push @results, { list_name => $info->{lst_title}, sub_email => $row, status => '' };
|
||||
if ($db->count({ sub_email => $row, sub_list_id_fk => $list_id })) {
|
||||
$results[-1]->{status} = GList::language('SYS_DUPLICATE');
|
||||
$duplicate++;
|
||||
}
|
||||
else {
|
||||
$db->insert({ sub_email => $row, sub_created => time, sub_list_id_fk => $list_id, sub_user_id_fk => $info->{lst_user_id_fk} });
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return {
|
||||
list_name => $info->{lst_title},
|
||||
results => \@results,
|
||||
invalid => $invalid,
|
||||
duplicate => $duplicate,
|
||||
hits => scalar @results,
|
||||
successful => scalar @results - $invalid - $duplicate,
|
||||
declined => $invalid + $duplicate
|
||||
};
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_check_subscriber} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _check_subscriber {
|
||||
#-----------------------------------------------------------------
|
||||
#
|
||||
my ($email, $lst_id, $db_stl, $wild_cards) = @_;
|
||||
return GList::language('LST_IPT_OVERLIMIT') if (GList::check_limit('sublist', $lst_id));
|
||||
return GList::language('LST_IPT_INVALID_EMAIL') if ($email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $email =~ /\s/ );
|
||||
return GList::language('LST_IPT_ON_STOPLIST') if ($db_stl->count({ stl_email => $email }));
|
||||
foreach (@$wild_cards) {
|
||||
my $e = $_->[0];
|
||||
my $re = quotemeta $e;
|
||||
$re =~ s/\\\*/.*/;
|
||||
$re =~ s/\\\?/./;
|
||||
return GList::language('LST_IPT_ON_STOPLIST') if ($email =~ /$re/i);
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_subscribers} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_subscribers {
|
||||
#--------------------------------------------------------------------
|
||||
# Print add form
|
||||
#
|
||||
my $do = shift || 0;
|
||||
|
||||
my $msg = ($do and $do =~ /^\d+$/) ? _sub_modify($do) : $do;
|
||||
if ($do =~ /^\d+$/ and ($do =~ /3|4/ or ($do == 1 and $IN->param('unbounced_form')))) { # Reset bounced emails
|
||||
return lst_unsub_bounced($msg);
|
||||
}
|
||||
return ('lst_subscriber_form.html') if ($IN->param('form'));
|
||||
|
||||
my $alpha;
|
||||
my $cgi = $IN->get_hash();
|
||||
my $hidden = GList::hidden;
|
||||
|
||||
# Create condition for subscriber's quick search bar
|
||||
require GT::SQL::Condition;
|
||||
my $cd = GT::SQL::Condition->new(lst_user_id_fk => '=' => $USER->{usr_username});
|
||||
my $cols = $DB->table('Subscribers')->cols;
|
||||
my $url = "glist.cgi?do=lst_subscribers$hidden->{hidden_query}";
|
||||
my $query= '';
|
||||
foreach my $c (keys % $cols) {
|
||||
next if (!$cgi->{$c});
|
||||
if ($c eq 'sub_list_id_fk') {
|
||||
$cd->add($c => '=' => $cgi->{$c});
|
||||
}
|
||||
else {
|
||||
$cd->add($c => 'like' => "%$cgi->{$c}%");
|
||||
}
|
||||
$url .= ";$c=$cgi->{$c}";
|
||||
}
|
||||
|
||||
# Do a search from the main page
|
||||
if ($IN->param('sub_search') and $IN->param('search_val')) {
|
||||
$cgi->{$cgi->{search_col}} = $cgi->{search_val};
|
||||
$url .= ";$cgi->{search_col}=$cgi->{$cgi->{search_col}}" if $cgi->{search_val};
|
||||
$query .= ";$cgi->{search_col}=$cgi->{$cgi->{search_col}}" if $cgi->{search_val};
|
||||
}
|
||||
# And from quick search bar
|
||||
if ($IN->param('alpha') and $IN->param('alpha') ne 'all') {
|
||||
$alpha = $IN->param('alpha');
|
||||
$query .= ";alpha=$alpha";
|
||||
}
|
||||
|
||||
# Search on date fields
|
||||
my $search_check = ($IN->param('search_form')) ? 1 : 0;
|
||||
if ($cgi->{'sub_created-ge'} or $cgi->{'sub_created-le'}) {
|
||||
my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%';
|
||||
my ($valid_from, $valid_to) = (1, 1);
|
||||
|
||||
require GT::Date;
|
||||
if ($cgi->{'sub_created-ge'}) {
|
||||
$valid_from = GList::date_to_time($cgi->{'sub_created-ge'}, $format);
|
||||
$cgi->{'sub_created-ge'} = GT::Date::date_get($valid_from, $format) if ($valid_from);
|
||||
}
|
||||
if ($cgi->{'sub_created-le'}) {
|
||||
$valid_to = GList::date_to_time($cgi->{'sub_created-le'}, $format);
|
||||
$cgi->{'sub_created-le'} = GT::Date::date_get($valid_to, $format) if ($valid_to);
|
||||
}
|
||||
if ($search_check and (!$valid_from or !$valid_to)) {
|
||||
$format =~ s/\%//g;
|
||||
return ('lst_subscriber_form.html', { msg => GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')) });
|
||||
}
|
||||
}
|
||||
if ($cgi->{sub_bounced}) {
|
||||
$cgi->{'sub_bounced-opt'} = '>=';
|
||||
}
|
||||
my $results = GList::search(
|
||||
cgi => $cgi,
|
||||
db => $DB->table('Subscribers'),
|
||||
prefix => 'sub',
|
||||
sb => 'sub_email',
|
||||
so => 'ASC',
|
||||
search_alpha=> $alpha,
|
||||
search_col => 'sub_email',
|
||||
search_check=> $search_check,
|
||||
show_user => $cgi->{show_user},
|
||||
return_msg => 'LST_SUB_RESULTS',
|
||||
);
|
||||
|
||||
my $page = ($IN->param('mn_disable')) ? 'lst_subscribers_preview.html' : 'lst_subscribers.html';
|
||||
my $subs_db = $DB->table('Lists', 'Subscribers');
|
||||
$subs_db->select_options('ORDER BY letter');
|
||||
|
||||
my $sth = $subs_db->select($cd, ['DISTINCT SUBSTRING(sub_email, 1, 1) as letter']);
|
||||
if (ref $results ne 'HASH') {
|
||||
$page = 'lst_subscriber_form.html' if ($search_check);
|
||||
return ($page, { msg => $msg || $results, search_bar => _search_bar($sth, $url) });
|
||||
}
|
||||
elsif ($results->{error} and $search_check) {
|
||||
return ('lst_subscriber_form.html', { msg => $results->{error} });
|
||||
}
|
||||
|
||||
if ($IN->param('mn_disable')) {
|
||||
$results->{msg} = '';
|
||||
}
|
||||
else {
|
||||
$results->{msg} = $msg if ($msg);
|
||||
}
|
||||
return ($page, { search_bar => _search_bar($sth, $url), toolbar_query => $query, %$results });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_sub_modify} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _sub_modify {
|
||||
#--------------------------------------------------------------------
|
||||
# Validate/delete subscribers user
|
||||
#
|
||||
my $do = shift;
|
||||
|
||||
# If they selected only one record to search we still need an array ref
|
||||
my $mod = ( ref $IN->param('modify') eq 'ARRAY' ) ? $IN->param('modify') : [$IN->param('modify')];
|
||||
my $db = $DB->table('Subscribers');
|
||||
my $cgi = $IN->get_hash;
|
||||
|
||||
my ($msg, $rec_modified) = ('', 0);
|
||||
if ($do == 1) { # Delete subscribers
|
||||
foreach my $rec_num ( @{$mod} ) {
|
||||
my $info = GList::check_owner('Subscribers', 'sub', $cgi->{"$rec_num-sub_id"});
|
||||
next if (!$info);
|
||||
|
||||
my $ret = $db->delete({ sub_id => $info->{sub_id} });
|
||||
if (defined $ret and $ret != 0) {
|
||||
$rec_modified++;
|
||||
}
|
||||
}
|
||||
$msg = GList::language('LST_SUB_DELETED', $rec_modified);
|
||||
}
|
||||
elsif ($do == 2) { # Validate subscribers
|
||||
foreach my $rec_num ( @{$mod} ) {
|
||||
my $info = GList::check_owner('Subscribers', 'sub', $cgi->{"$rec_num-sub_id"});
|
||||
next if (!$info);
|
||||
|
||||
if ($db->count({ sub_id => $info->{sub_id}, sub_validated => 0 })) {
|
||||
$db->update({ sub_validated => 1 }, { sub_id => $info->{sub_id} });
|
||||
$rec_modified++;
|
||||
}
|
||||
}
|
||||
$msg = GList::language('LST_SUB_VALIDATED', $rec_modified);
|
||||
}
|
||||
elsif ($do == 3) { # Unbounced subscribers
|
||||
require GT::SQL::Condition;
|
||||
foreach my $rec_num ( @{$mod} ) {
|
||||
my $info = GList::check_owner('Subscribers', 'sub', $cgi->{"$rec_num-sub_id"});
|
||||
next if (!$info);
|
||||
|
||||
if ($db->count(GT::SQL::Condition->new(sub_id => '=' => $info->{sub_id}, sub_bounced => '>=' => 1))) {
|
||||
$db->update({ sub_bounced => '0' }, { sub_id => $info->{sub_id} });
|
||||
$rec_modified++;
|
||||
}
|
||||
}
|
||||
$msg = GList::language('LST_SUB_UNBOUNCED', $rec_modified);
|
||||
}
|
||||
elsif ($do == 4) { # Remove all unbounced subscribers
|
||||
require GT::SQL::Condition;
|
||||
my $cond = new GT::SQL::Condition;
|
||||
$cond->add(sub_bounced => '>=' => 1, sub_user_id_fk => '=' => $USER->{usr_username});
|
||||
$cond->add(sub_list_id_fk => '=', $cgi->{list_id}) if $cgi->{list_id};
|
||||
if ($cgi->{sub_bounced} and $cgi->{sub_bounced} ne '*') {
|
||||
my $opt = $cgi->{'sub_bounced-opt'} || '=';
|
||||
$cond->add(sub_bounced => $opt => $cgi->{sub_bounced});
|
||||
}
|
||||
my $rec = $db->delete($cond);
|
||||
$msg = GList::language('LST_BOUNCED_REMOVED', $rec);
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_unsub_bounced} = __LINE__ . <<'END_OF_SUB';
|
||||
sub lst_unsub_bounced {
|
||||
#--------------------------------------------------------------------
|
||||
# Let you to unsubscribe all bounced users
|
||||
#
|
||||
my $msg = shift;
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
my %hash;
|
||||
my $conditions = '';
|
||||
$hash{sub_list_id_fk} = $cgi->{sub_list_id_fk} || '';
|
||||
$conditions .= ";list_id=$cgi->{sub_list_id_fk}" if $cgi->{sub_list_id_fk};
|
||||
|
||||
if ($cgi->{sub_bounced} and $cgi->{sub_bounced} eq '*') {
|
||||
$conditions .= ';sub_bounced=*';
|
||||
$hash{sub_bounced} = 1;
|
||||
$hash{'sub_bounced-opt'} = '>=';
|
||||
}
|
||||
else {
|
||||
$conditions .= ";sub_bounced=$cgi->{sub_bounced}";
|
||||
$conditions .= ";sub_bounced-opt=$cgi->{'sub_bounced-opt'}";
|
||||
if ($cgi->{'sub_bounced-opt'} and $cgi->{'sub_bounced-opt'} eq '<') {
|
||||
$hash{'sub_bounced-lt'} = $cgi->{sub_bounced};
|
||||
$hash{'sub_bounced-ge'} = 1;
|
||||
}
|
||||
elsif ($cgi->{'sub_bounced-opt'} and $cgi->{'sub_bounced-opt'} eq '<=') {
|
||||
$hash{'sub_bounced-le'} = $cgi->{sub_bounced};
|
||||
$hash{'sub_bounced-ge'} = 1;
|
||||
}
|
||||
else {
|
||||
$hash{sub_bounced} = $cgi->{sub_bounced} || 1;
|
||||
$hash{'sub_bounced-opt'} = $cgi->{'sub_bounced-opt'} || '>=';
|
||||
}
|
||||
}
|
||||
my $results = GList::search(
|
||||
cgi => \%hash,
|
||||
db => $DB->table('Subscribers'),
|
||||
prefix => 'sub',
|
||||
sb => 'sub_email',
|
||||
so => 'ASC',
|
||||
return_msg => 'LST_BOUNCED_RESULTS',
|
||||
int_field => 1,
|
||||
);
|
||||
if (ref $results ne 'HASH') {
|
||||
return ('lst_unsub_bounced.html', { msg => $msg || $results });
|
||||
}
|
||||
|
||||
$results->{msg} = $msg if ($msg);
|
||||
return ('lst_unsub_bounced.html', { %$results, conditions => $conditions });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_sub_add} = <<'END_OF_SUB';
|
||||
sub lst_sub_add {
|
||||
#-------------------------------------------------------------------
|
||||
# Add a subscriber
|
||||
#
|
||||
return ('lst_sub_add.html') if ($IN->param('form'));
|
||||
return ('lst_sub_add.html', { msg => GList::language('LST_IPT_LIST_EMPTY') }) if (!$IN->param('import_to'));
|
||||
|
||||
my $import_to = (ref $IN->param('import_to') eq 'ARRAY') ? $IN->param('import_to') : [$IN->param('import_to')];
|
||||
my $email = $IN->param('new_email');
|
||||
my $name = $IN->param('new_name');
|
||||
if ($email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $email =~ /\s/) { # check email address
|
||||
return ('lst_sub_add.html', { msg => GList::language('LST_IPT_INVALID_EMAIL') });
|
||||
}
|
||||
$email = lc $email;
|
||||
|
||||
# Create stoplist database and load wild cards
|
||||
my $db = $DB->table('Subscribers');
|
||||
my $db_stl = $DB->table('StopLists');
|
||||
my $wild_cards = GList::wild_cards();
|
||||
|
||||
# Setup the language for GT::SQL.
|
||||
local $GT::SQL::ERRORS->{UNIQUE} = GList::language('SYS_DUPLICATE');
|
||||
local $GT::SQL::ERRORS->{NOTNULL} = GList::language('LST_IMP_NOTNULL') if ( GList::language('LST_IMP_NOTNULL') );
|
||||
local $GT::SQL::ERRORS->{ILLEGALVAL} = '';
|
||||
|
||||
my @results;
|
||||
foreach my $id (@$import_to) {
|
||||
my $info = GList::check_owner('Lists', 'lst', $id);
|
||||
push @results, { sub_email => $email, lst_title => $info->{lst_title}, status => lst_subscribers($info) } if ( ref $info ne 'HASH' );
|
||||
|
||||
push @results, { sub_email => $email, lst_title => $info->{lst_title}, status => '' };
|
||||
my $error = _check_subscriber($email, $info->{lst_id}, $db_stl, $wild_cards);
|
||||
if ($error) {
|
||||
$results[-1]->{status} = $error;
|
||||
}
|
||||
elsif ($db->count({ sub_email => $email, sub_list_id_fk => $id })) {
|
||||
$results[-1]->{status} = GList::language('SYS_DUPLICATE');
|
||||
}
|
||||
else {
|
||||
$db->insert({ sub_email => $email, sub_name => $name, sub_list_id_fk => $id, sub_user_id_fk => $info->{lst_user_id_fk} });
|
||||
}
|
||||
}
|
||||
return ('lst_sub_success.html', { results => \@results, msg => GList::language('LST_SUB_ADDED', $email) });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_sub_modify} = <<'END_OF_SUB';
|
||||
sub lst_sub_modify {
|
||||
#-------------------------------------------------------------------
|
||||
# Modify a subscriber
|
||||
#
|
||||
my $sub_id = $IN->param('subid');
|
||||
my $old_data = $DB->table('Lists', 'Subscribers')->select({ sub_id => $sub_id }, [ 'lst_title', 'sub_email as new_email', 'sub_name as new_name', 'sub_validated as new_validated', 'sub_bounced as new_bounced', 'sub_list_id_fk'])->fetchrow_hashref;
|
||||
return lst_subscribers(GList::language('LST_INVALID')) if (!$old_data);
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $old_data->{sub_list_id_fk});
|
||||
return lst_subscribers($info) if (ref $info ne 'HASH');
|
||||
|
||||
return ('lst_sub_modify.html', $old_data) if ($IN->param('form'));
|
||||
|
||||
my $new_email = $IN->param('new_email');
|
||||
my $name = $IN->param('new_name');
|
||||
my $validated = ($IN->param('new_validated')) ? '1' : '0';
|
||||
my $bounced = $IN->param('new_bounced') || 0;
|
||||
|
||||
if ($new_email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $new_email =~ /\s/) { # check email address
|
||||
return ('lst_sub_modify.html', { msg => GList::language('LST_IPT_INVALID_EMAIL'), %$info });
|
||||
}
|
||||
|
||||
require GT::SQL::Condition;
|
||||
if ($DB->table('Subscribers')->count( GT::SQL::Condition->new(
|
||||
sub_email => '=' => $new_email,
|
||||
sub_list_id_fk => '=' => $old_data->{sub_list_id_fk},
|
||||
sub_id => '<>'=> $sub_id,
|
||||
)) == 1 ) {
|
||||
return ('lst_sub_modify.html', { msg => GList::language('LST_IPT_DUPLICATE_EMAIL'), %$info });
|
||||
}
|
||||
else {
|
||||
$DB->table('Subscribers')->update({
|
||||
sub_email => $new_email,
|
||||
sub_name => $name,
|
||||
sub_validated => $validated,
|
||||
sub_bounced => $bounced,
|
||||
}, { sub_id => $sub_id });
|
||||
}
|
||||
return lst_subscribers(GList::language('LST_SUB_MODIFIED', $old_data->{new_email}));
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
|
||||
$COMPILE{lst_sub_delete} = <<'END_OF_SUB';
|
||||
sub lst_sub_delete {
|
||||
#-------------------------------------------------------------------
|
||||
# Delete the subscribers
|
||||
#
|
||||
return lst_subscribers(1);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_sub_validate} = <<'END_OF_SUB';
|
||||
sub lst_sub_validate {
|
||||
#-------------------------------------------------------------------
|
||||
# Validate the subscribers
|
||||
#
|
||||
return lst_subscribers(2);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{lst_sub_unbounced} = <<'END_OF_SUB';
|
||||
sub lst_sub_unbounced {
|
||||
#-------------------------------------------------------------------
|
||||
# Validate the subscribers
|
||||
#
|
||||
my $action = $IN->param('all') ? 4 : 3;
|
||||
return lst_subscribers($action);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_qsort} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _qsort {
|
||||
#------------------------------------------------------------------
|
||||
my ($list_file, $orderby, $sortdown) = @_;
|
||||
my $sorted;
|
||||
@$sorted =
|
||||
sort {
|
||||
my $da = lc $a->{$orderby}; #lower case
|
||||
my $db = lc $b->{$orderby};
|
||||
my $res;
|
||||
if ($orderby eq 'size' or $orderby eq 'date') {
|
||||
$res = $db <=> $da;
|
||||
}
|
||||
else {
|
||||
$res = $db cmp $da;
|
||||
}
|
||||
if ($res == 0 and $orderby ne 'name') {
|
||||
lc $b->{name} cmp lc $a->{name};
|
||||
}
|
||||
else {
|
||||
$res;
|
||||
}
|
||||
} @$list_file;
|
||||
($sortdown) and @$sorted = reverse @$sorted;
|
||||
return $sorted;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_search_bar} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _search_bar {
|
||||
#---------------------------------------------------------------------
|
||||
# create quick search bar
|
||||
#
|
||||
my ($sth, $url) = @_;
|
||||
my $current = $IN->param('alpha') || '';
|
||||
my @alpha = ('All', 'A'..'Z', '0..9', 'Other');
|
||||
|
||||
my ($search_bar, $items);
|
||||
$items->{All} = 'all';
|
||||
while (my ($letter) = $sth->fetchrow_array) {
|
||||
$letter = uc $letter;
|
||||
if ($letter =~ /\d/) {
|
||||
exists $items->{'0..9'} or $items->{'0..9'} = 'number';
|
||||
}
|
||||
elsif ($letter =~ /[\W_]/) {
|
||||
exists $items->{Other} or $items->{Other} = 'other';
|
||||
}
|
||||
else {
|
||||
exists $items->{$letter} or $items->{$letter} = $letter;
|
||||
}
|
||||
}
|
||||
foreach (@alpha) {
|
||||
if ($_ eq 'All') {
|
||||
$search_bar .= ( (!$current or $current eq 'all') and !$IN->param('bsearch') ) ? "<b>$_</b> " : "<a href='$url&alpha=all'>$_</a> ";
|
||||
}
|
||||
elsif ($items->{$_}) {
|
||||
my $l = ($_ eq '0..9') ? 'number' : lc $_;
|
||||
$search_bar .= ( lc $current eq lc $l ) ? "<b>$_</b> " : "<a href='$url;alpha=$l'>$_</a> ";
|
||||
}
|
||||
else {
|
||||
$search_bar .= "$_ ";
|
||||
}
|
||||
}
|
||||
return $search_bar;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_determine_action} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _determine_action {
|
||||
#----------------------------------------------------------------------------
|
||||
# Check valid action
|
||||
#
|
||||
my $action = shift || undef;
|
||||
return if (!$action);
|
||||
return 'lst_home' if ($action eq 'lst_search' );
|
||||
|
||||
my %valid = (
|
||||
map { $_ => 1 } qw(
|
||||
lst_home
|
||||
lst_add
|
||||
lst_modify_form
|
||||
lst_modify
|
||||
lst_search_form
|
||||
lst_delete
|
||||
lst_html
|
||||
lst_import
|
||||
lst_subscribers
|
||||
lst_sub_add
|
||||
lst_sub_modify
|
||||
lst_sub_delete
|
||||
lst_sub_validate
|
||||
lst_sub_unbounced
|
||||
lst_unsub_bounced
|
||||
)
|
||||
);
|
||||
exists $valid{$action} and return $action;
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
|
||||
|
||||
1076
site/glist/lib/GList/Mailer.pm
Normal file
1076
site/glist/lib/GList/Mailer.pm
Normal file
File diff suppressed because it is too large
Load Diff
1185
site/glist/lib/GList/Message.pm
Normal file
1185
site/glist/lib/GList/Message.pm
Normal file
File diff suppressed because it is too large
Load Diff
167
site/glist/lib/GList/Plugins.pm
Normal file
167
site/glist/lib/GList/Plugins.pm
Normal file
@@ -0,0 +1,167 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Plugins.pm,v 1.9 2004/01/13 01:21:56 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 GList::Plugins;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use GList qw/$IN $CFG $USER/;
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Plugin config #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub get_plugin_user_cfg {
|
||||
# --------------------------------------------------------------
|
||||
# Returns the user config hash for a given plugin.
|
||||
#
|
||||
my $class = ($_[0] eq 'GList::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins' );
|
||||
exists $cfg->{$plugin_name} or return {};
|
||||
(ref $cfg->{$plugin_name}->{user} eq 'ARRAY') or return {};
|
||||
|
||||
my $opts = {};
|
||||
foreach my $opt (@{$cfg->{$plugin_name}->{user}}) {
|
||||
$opts->{$opt->[0]} = $opt->[1];
|
||||
}
|
||||
return $opts;
|
||||
}
|
||||
|
||||
sub set_plugin_user_cfg {
|
||||
# --------------------------------------------------------------
|
||||
# Takes a plugin name and config hash and saves it.
|
||||
#
|
||||
my $class = ($_[0] eq 'GList::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $hash = shift || return;
|
||||
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins' );
|
||||
exists $cfg->{$plugin_name} or return;
|
||||
(ref $cfg->{$plugin_name}->{user} eq 'ARRAY') or return {};
|
||||
|
||||
foreach my $opt (@{$cfg->{$plugin_name}->{user}}) {
|
||||
$opt->[1] = $hash->{$opt->[0]};
|
||||
}
|
||||
return GT::Plugins->save_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins', $cfg );
|
||||
}
|
||||
|
||||
sub get_plugin_registry {
|
||||
# --------------------------------------------------------------
|
||||
# Returns the user config hash for a given plugin.
|
||||
#
|
||||
my $class = ($_[0] eq 'GList::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins' );
|
||||
exists $cfg->{$plugin_name} or return {};
|
||||
|
||||
return ( $cfg->{$plugin_name}->{registry} || {} );
|
||||
}
|
||||
|
||||
sub set_plugin_registry {
|
||||
# --------------------------------------------------------------
|
||||
# Takes a plugin name and config hash and saves it.
|
||||
#
|
||||
my $class = ($_[0] eq 'GList::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $hash = shift || return;
|
||||
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins' );
|
||||
|
||||
exists $cfg->{$plugin_name} or return;
|
||||
|
||||
my $registry = ( $cfg->{$plugin_name}->{registry} ||= {} );
|
||||
foreach my $opt ( keys %{$hash} ) {
|
||||
$registry->{$opt} = $hash->{$opt};
|
||||
}
|
||||
|
||||
return GT::Plugins->save_cfg ( $CFG->{priv_path} . '/lib/GList/Plugins', $cfg );
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Displaying #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub manager {
|
||||
# -------------------------------------------------------------------
|
||||
# Manages the plugin installer, basically just creates an installerobject,
|
||||
# and returns the output. Real work is done in GT::Plugins::Installer
|
||||
#
|
||||
|
||||
require GT::Plugins::Manager;
|
||||
my $man = new GT::Plugins::Manager (
|
||||
cgi => $IN,
|
||||
tpl_root => "$CFG->{priv_path}/templates/$CFG->{template_set}",
|
||||
plugin_dir => $CFG->{priv_path} . "/lib/GList/Plugins",
|
||||
prog_name => 'mlist',
|
||||
prog_ver => $CFG->{version},
|
||||
prog_reg => $CFG->{reg_number},
|
||||
prefix => 'GList::Plugins::',
|
||||
base_url => "glist.cgi?do=admin_page&pg=plugin_manager.html".(( $USER->{use_cookie} ) ? '' : "&sid=$USER->{session_id}"),
|
||||
path_to_perl => $CFG->{path_to_perl},
|
||||
perl_args => "-cw -I$CFG->{priv_path}"
|
||||
) or return "Error loading plugin manager: $GT::Plugins::error";
|
||||
return $man->process;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Wizard #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub wizard {
|
||||
# -------------------------------------------------------------------
|
||||
# Manages the plugin wizard, basically just creates a wizard object,
|
||||
# and returns the output. Real work is done in GT::Plugins::Wizard.
|
||||
#
|
||||
require GT::Plugins::Wizard;
|
||||
my $wiz = new GT::Plugins::Wizard (
|
||||
cgi => $IN,
|
||||
tpl_root => "$CFG->{priv_path}/templates/$CFG->{template_set}",
|
||||
plugin_dir => $CFG->{priv_path} . "/lib/GList/Plugins",
|
||||
prog_ver => $CFG->{version},
|
||||
install_header => 'use GList qw/$IN $DB $CFG/;',
|
||||
initial_indent => '',
|
||||
prefix => 'GList::Plugins::',
|
||||
dirs => {
|
||||
user_cgi => '$CFG->{cgi_path}',
|
||||
admin_cgi => '$CFG->{cgi_path}'
|
||||
}
|
||||
);
|
||||
return $wiz->process;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Displaying #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub admin_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Displays the admin menu with the plugin options shown.
|
||||
#
|
||||
require GT::Plugins::Manager;
|
||||
my $man = new GT::Plugins::Manager(
|
||||
cgi => $IN,
|
||||
tpl_root => "$CFG->{priv_path}/templates/$CFG->{template_set}",
|
||||
plugin_dir => $CFG->{priv_path} . "/lib/GList/Plugins",
|
||||
prefix => 'GList::Plugins::',
|
||||
prog_name => 'glist',
|
||||
prog_ver => $CFG->{version},
|
||||
prog_reg => $CFG->{reg_number},
|
||||
base_url => 'glist.cgi?do=admin_page&pg=plugin_manager.html'.(( $USER->{use_cookie} ) ? '' : "&sid=$USER->{session_id}"),
|
||||
path_to_perl => $CFG->{path_to_perl},
|
||||
perl_args => "-cw -I$CFG->{priv_path}"
|
||||
);
|
||||
return { menu => $man->admin_menu, cgi_url => $CFG->{cgi_url} };
|
||||
}
|
||||
1;
|
||||
|
||||
103
site/glist/lib/GList/Plugins/SubscribersMod.pm
Normal file
103
site/glist/lib/GList/Plugins/SubscribersMod.pm
Normal file
@@ -0,0 +1,103 @@
|
||||
# ==================================================================
|
||||
# GList::Plugins::SubscribersMod - Auto Generated Program Module
|
||||
#
|
||||
# GList::Plugins::SubscribersMod
|
||||
# Author : Virginia Lo
|
||||
# Version : 1
|
||||
# Updated : Wed Jun 4 12:24:28 2008
|
||||
#
|
||||
# ==================================================================
|
||||
#
|
||||
|
||||
package GList::Plugins::SubscribersMod;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GT::Base;
|
||||
use GT::Plugins qw/STOP CONTINUE/;
|
||||
use GList qw/$IN $DB $CFG/;
|
||||
|
||||
# Inherit from base class for debug and error methods
|
||||
@GList::Plugins::SubscribersMod::ISA = qw(GT::Base);
|
||||
|
||||
# Your code begins here.
|
||||
|
||||
|
||||
# PLUGIN HOOKS
|
||||
# ===================================================================
|
||||
|
||||
|
||||
sub lst_sub_modify {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This subroutine will be called whenever the hook 'lst_sub_modify' is run. You
|
||||
# should call GT::Plugins->action(STOP) if you don't want the regular
|
||||
# 'lst_sub_modify' code to run, otherwise the code will continue as normal.
|
||||
#
|
||||
my (@args) = @_;
|
||||
|
||||
# Do something useful here
|
||||
GT::Plugins->action(STOP);
|
||||
|
||||
my $sub_id = $IN->param('subid');
|
||||
my $old_data = $DB->table('Lists', 'Subscribers')->select({ sub_id => $sub_id }, [ 'lst_title', 'sub_email as new_email', 'sub_name as new_name', 'sub_validated as new_validated', 'sub_bounced as new_bounced', 'sub_list_id_fk', 'Subscribers.*'])->fetchrow_hashref;
|
||||
return lst_subscribers(GList::language('LST_INVALID')) if (!$old_data);
|
||||
|
||||
my $cols = $DB->table('Subscribers')->cols;
|
||||
foreach (keys %$cols) {
|
||||
next if ($_ eq 'sub_created' or $_ eq 'sub_id' or $_ eq 'sub_user_id_fk' or $_ eq 'sub_list_id_fk' or $_ eq 'sub_val_code');
|
||||
my $key = $_;
|
||||
$key =~ s/sub_/new_/g;
|
||||
$old_data->{$key} ||= $old_data->{$_};
|
||||
delete $old_data->{$_};
|
||||
}
|
||||
|
||||
my $info = GList::check_owner('Lists', 'lst', $old_data->{sub_list_id_fk});
|
||||
return lst_subscribers($info) if (ref $info ne 'HASH');
|
||||
|
||||
return ('lst_sub_modify.html', $old_data) if ($IN->param('form'));
|
||||
|
||||
my $new_email = $IN->param('new_email');
|
||||
my $name = $IN->param('new_name');
|
||||
my $validated = ($IN->param('new_validated')) ? '1' : '0';
|
||||
my $bounced = $IN->param('new_bounced') || 0;
|
||||
|
||||
if ($new_email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $new_email =~ /\s/) { # check email address
|
||||
return ('lst_sub_modify.html', { msg => GList::language('LST_IPT_INVALID_EMAIL'), %$info });
|
||||
}
|
||||
|
||||
require GT::SQL::Condition;
|
||||
if ($DB->table('Subscribers')->count( GT::SQL::Condition->new(
|
||||
sub_email => '=' => $new_email,
|
||||
sub_list_id_fk => '=' => $old_data->{sub_list_id_fk},
|
||||
sub_id => '<>'=> $sub_id,
|
||||
)) == 1 ) {
|
||||
return ('lst_sub_modify.html', { msg => GList::language('LST_IPT_DUPLICATE_EMAIL'), %$info });
|
||||
}
|
||||
else {
|
||||
my $update = {
|
||||
sub_email => $new_email,
|
||||
sub_name => $name,
|
||||
sub_validated => $validated,
|
||||
sub_bounced => $bounced,
|
||||
};
|
||||
foreach (keys %$cols) {
|
||||
my $key = $_;
|
||||
$key =~ s/sub_/new_/g;
|
||||
if ($IN->param($key)) {
|
||||
$update->{$_} ||= $IN->param($key);
|
||||
}
|
||||
}
|
||||
#use Data::Dumper; print $IN->header . "<pre>".Dumper($old_data,$update)."</pre>";
|
||||
$DB->table('Subscribers')->update({
|
||||
%$update
|
||||
}, { sub_id => $sub_id });
|
||||
}
|
||||
require GList::List;
|
||||
return GList::List::lst_subscribers(GList::language('LST_SUB_MODIFIED', $old_data->{new_email}));
|
||||
|
||||
|
||||
return @args;
|
||||
}
|
||||
|
||||
# Always end with a 1.
|
||||
1;
|
||||
393
site/glist/lib/GList/Profile.pm
Normal file
393
site/glist/lib/GList/Profile.pm
Normal file
@@ -0,0 +1,393 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Profile.pm,v 1.39 2004/10/14 22:57:54 bao 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 GList::Profile;
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects :user_type $DEBUG/;
|
||||
use GT::AutoLoader;
|
||||
|
||||
sub process {
|
||||
#--------------------------------------------------
|
||||
# Determine what to do
|
||||
#
|
||||
my $do = $IN->param('do') || '';
|
||||
my $action = _determine_action($do) or die "Error: Invalid Action! ($do)";
|
||||
my ($tpl, $results) = GT::Plugins->dispatch($CFG->{priv_path}.'/lib/GList/Plugins', $action, \&$action);
|
||||
|
||||
if ($tpl) {
|
||||
my $hidden = GList::hidden();
|
||||
$results->{hidden_query} = $hidden->{hidden_query};
|
||||
$results->{hidden_objects} = $hidden->{hidden_objects};
|
||||
GList::display($tpl, $results);
|
||||
}
|
||||
}
|
||||
|
||||
$COMPILE{pro_profile} = <<'END_OF_SUB';
|
||||
sub pro_profile {
|
||||
#-------------------------------------------------------------------------
|
||||
# print account information
|
||||
#
|
||||
my $msg = shift;
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $info = $db->get($USER->{usr_username});
|
||||
my $cols = $db->cols();
|
||||
|
||||
my $hsh = {};
|
||||
foreach (keys %$cols) {
|
||||
$hsh->{"mod_$_"} = $info->{$_};
|
||||
}
|
||||
my $pg = ($IN->param('pro_mailing')) ? 'pro_mailing.html' : 'pro_profile.html';
|
||||
return ($pg, { msg => $msg, %$hsh });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{pro_update} = <<'END_OF_SUB';
|
||||
sub pro_update {
|
||||
#---------------------------------------------------------
|
||||
# Update account information
|
||||
#
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $cols = $db->cols();
|
||||
my $cgi = $IN->get_hash();
|
||||
my %restricted_field = (
|
||||
usr_username => 1,
|
||||
usr_password => 1,
|
||||
usr_status => 1,
|
||||
usr_type => 1,
|
||||
usr_limit_list => 1,
|
||||
usr_limit_sublist=> 1,
|
||||
usr_limit_email30=> 1,
|
||||
usr_validate_code=> 1
|
||||
);
|
||||
|
||||
my $hsh;
|
||||
foreach (keys %$cols) {
|
||||
next if (exists $restricted_field{$_});
|
||||
$hsh->{$_} = $cgi->{"mod_$_"} if (exists $cgi->{"mod_$_"});
|
||||
}
|
||||
|
||||
$hsh->{usr_date_format} = $IN->param('date_preview') if ($IN->param('date_preview'));
|
||||
$hsh->{usr_date_format}||= "%yyyy%-%mm%-%dd%";
|
||||
$hsh->{usr_username} = $USER->{usr_username};
|
||||
$hsh->{usr_updated} = '1';
|
||||
if ($db->modify($hsh)) {
|
||||
my $msg = ($cgi->{pro_mailing}) ? GList::language('USR_TPL_UPDATED') : GList::language('USR_UPDATED', $USER->{usr_username});
|
||||
return pro_profile($msg);
|
||||
}
|
||||
else {
|
||||
local $^W;
|
||||
return pro_profile("<font color=red><b>$GT::SQL::error</b></font>");
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{pro_password} = <<'END_OF_SUB';
|
||||
sub pro_password {
|
||||
#---------------------------------------------------------
|
||||
# Update the new password
|
||||
#
|
||||
return ('pro_password_form.html') if ($IN->param('form'));
|
||||
#------------demo code-----------
|
||||
|
||||
my $old = $IN->param('old_pass');
|
||||
my $new = $IN->param('new_pass');
|
||||
my $con = $IN->param('con_pass');
|
||||
|
||||
return ('pro_password_form.html', { msg => GList::language('ADM_PWD_ERR') }) if (!$old or !$new or !$con);
|
||||
return ('pro_password_form.html', { msg => GList::language('ADM_PWD_NOT_MATCH') }) if ($new ne $con);
|
||||
return ('pro_password_form.html', { msg => GList::language('ADM_PWD_INVALID') }) if ($new ne $con or length $new < 4);
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $user = $db->get($USER->{usr_username});
|
||||
|
||||
return ('pro_password_form.html', { msg => GList::language('ADM_OLDPWD_ERR') }) if ($user->{usr_password} ne GList::encrypt($old, $user->{usr_password}));
|
||||
my $crypted = GList::encrypt($new);
|
||||
if ($db->update({ usr_password => $crypted }, { usr_username => $USER->{usr_username} })) {
|
||||
if ($USER->{usr_type} == ADMINISTRATOR and exists $CFG->{admin}->{$USER->{usr_username}}) { # Update new password in Data.pm
|
||||
$CFG->{admin}->{$USER->{usr_username}}->[0] = $crypted;
|
||||
$CFG->save();
|
||||
}
|
||||
return pro_profile(GList::language('ADM_PWD_CHANGED'));
|
||||
}
|
||||
else {
|
||||
local $^W;
|
||||
return ('pro_password_form.html', { msg => "<font color=red><b>$GT::SQL::error</b></font>" });
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{pro_report} = <<'END_OF_SUB';
|
||||
sub pro_report {
|
||||
#-----------------------------------------------------------
|
||||
# Build report
|
||||
#
|
||||
return ('pro_report_form.html') if ($IN->param('form'));
|
||||
|
||||
my $id = $IN->param('id');
|
||||
if ($USER->{usr_type} != ADMINISTRATOR) {
|
||||
return _report_details($USER->{usr_username});
|
||||
}
|
||||
elsif ($USER->{usr_type} == ADMINISTRATOR and $IN->param('d')) { # Show the details reports
|
||||
my $info = $DB->table('Users')->get($id);
|
||||
return ('pro_report.html', { msg => GList::language('RPT_NOT_FOUND', $id) }) if (!$info);
|
||||
return _report_details($id);
|
||||
}
|
||||
my ($from, $to, $mm, $yy, $msg, $url, $toolbar_query);
|
||||
my $date_format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%';
|
||||
my @items = ('date_to', 'date_from');
|
||||
|
||||
# Create url
|
||||
foreach (@items) {
|
||||
$url .= "&$_=".$IN->param($_) if ($IN->param($_));
|
||||
}
|
||||
|
||||
if ($IN->param('date_from') or $IN->param('date_to')) {
|
||||
require GT::Date;
|
||||
my $date_from = $IN->param('date_from');
|
||||
my $date_to = $IN->param('date_to');
|
||||
my ($valid_from, $valid_to) = (1, 1);
|
||||
if ($date_from) {
|
||||
$toolbar_query .= "date_from=$date_from;";
|
||||
$valid_from = GList::date_to_time($date_from, $date_format);
|
||||
$date_from = GT::Date::date_get($valid_from, $date_format) if ($valid_from);
|
||||
}
|
||||
if ($date_to) {
|
||||
$toolbar_query .= "date_to=$date_to;";
|
||||
$valid_to = GList::date_to_time($date_to, $date_format);
|
||||
$date_to = GT::Date::date_get($valid_to, $date_format) if ($valid_to);
|
||||
}
|
||||
if (!$valid_from or !$valid_to) {
|
||||
$date_format =~ s/\%//g;
|
||||
return ('pro_report_form.html', { msg => GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')) });
|
||||
}
|
||||
|
||||
$from = GT::Date::timelocal(GT::Date::parse_format($date_from, $date_format));
|
||||
$to = GT::Date::timelocal(GT::Date::parse_format($date_to.' 23:59:59', "$date_format %hh%:%MM%:%ss%"));
|
||||
$msg = GList::language('RPT_CUS_FROM', $date_from)
|
||||
. ($IN->param('date_to') ? GList::language('RPT_CUS_TO', $date_to) : '')
|
||||
. '</b></font>';
|
||||
}
|
||||
else {
|
||||
($from, $to) = _period_time();
|
||||
($mm, $yy) = _period_time(1);
|
||||
$toolbar_query .= "month=".$IN->param('month').";" if ($IN->param('month'));
|
||||
$toolbar_query .= "year=".$IN->param('year').";" if ($IN->param('year'));
|
||||
if ($IN->param('month') or $IN->param('year') or !defined $IN->param('flag')) {
|
||||
$msg = GList::language('RPT_SUMARY'). (( $IN->param('flag') and !$IN->param('month') ) ? '' : "$mm/");
|
||||
$msg .= ( $IN->param('flag') and !$IN->param('month') ) ? $IN->param('year') : "$yy</b>";
|
||||
$url .= (( $IN->param('flag') and !$IN->param('month') ) ? '' : "&month=$mm"). "&year=$yy";
|
||||
}
|
||||
else {
|
||||
$msg = GList::language('RPT_TITLE2');
|
||||
}
|
||||
}
|
||||
|
||||
# Load database object
|
||||
require GT::SQL::Condition;
|
||||
my $db = $DB->table('MailingIndex');
|
||||
my $cd = new GT::SQL::Condition('mli_done', '>=', $from, 'mli_done', '<=', $to);
|
||||
$db->select_options('GROUP BY mli_user_id_fk ORDER BY mli_user_id_fk');
|
||||
$cd->add('mli_user_id_fk', 'like', "%$id%") if ( $id );
|
||||
|
||||
my $sth = $db->select($cd, ['mli_user_id_fk as email', 'count(mli_id) as sent']);
|
||||
my $hsh = {};
|
||||
while (my ($id, $sent) = $sth->fetchrow_array) {
|
||||
$hsh->{$id} += $sent;
|
||||
}
|
||||
|
||||
# Get user listings
|
||||
my $db_usr = $DB->table('Users');
|
||||
my $cd_usr = new GT::SQL::Condition();
|
||||
my $sb = $IN->param('sb') || 'usr_username';
|
||||
my $so = $IN->param('so') || 'ASC';
|
||||
$cd_usr->add('usr_username', 'like', "%$id%") if ( $id );
|
||||
|
||||
my $mh = $IN->param('mh') || 25;
|
||||
my $nh = $IN->param('nh') || 1;
|
||||
my $ns = ($nh == 1) ? 0 : ( $nh - 1 ) * $mh;
|
||||
|
||||
$db_usr->select_options("ORDER BY usr_type desc, $sb $so", "LIMIT $ns, $mh");
|
||||
my $users = $db_usr->select($cd_usr);
|
||||
my $hits = $db_usr->hits;
|
||||
return ('pro_report.html', { msg => GList::language('RPT_NO_RESULT') }) if ($hits == 0);
|
||||
|
||||
my @output;
|
||||
while ( my $rs = $users->fetchrow_hashref ) {
|
||||
$rs->{sent} = $hsh->{$rs->{usr_username}} if ($hsh->{$rs->{usr_username}});
|
||||
push @output, $rs;
|
||||
}
|
||||
|
||||
return ('pro_report.html', {
|
||||
msg => $msg,
|
||||
results => \@output,
|
||||
hits => $hits,
|
||||
mh => $mh,
|
||||
nh => $nh,
|
||||
url => $url,
|
||||
toolbar_query => $toolbar_query,
|
||||
});
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_report_details} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _report_details {
|
||||
#-----------------------------------------------------------
|
||||
# Build report details
|
||||
#
|
||||
my $id = shift;
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
my $db = $DB->table('MailingIndex', 'EmailMailings');
|
||||
my $cd = new GT::SQL::Condition(mli_user_id_fk => '=' => $id, eml_sent => '<>' => 0);
|
||||
my $mh = $cgi->{mh} || 25;
|
||||
my $nh = $cgi->{nh} || 1;
|
||||
my $sb = $cgi->{sb} || 'mli_id';
|
||||
my $so = $cgi->{so} || 'DESC';
|
||||
my $ns = ( $nh == 1 ) ? 0 : ( $nh - 1 ) * $mh;
|
||||
|
||||
my $date_format = $USER->{usr_date_format} || '%mm%-%dd%-%yyyy%';
|
||||
|
||||
my $query = "id=$id;d=1;";
|
||||
my ($period, $mm, $yy, $from, $to);
|
||||
if ($cgi->{date_from} or $cgi->{date_to}) { # Searching by date
|
||||
require GT::Date;
|
||||
my ($valid_from, $valid_to) = (1, 1);
|
||||
my $date_from = $cgi->{date_from};
|
||||
my $date_to = $cgi->{date_to};
|
||||
|
||||
if ($date_from) {
|
||||
$query .= "date_from=$cgi->{date_from};";
|
||||
$period = " from <b>$cgi->{date_from}</b>";
|
||||
$valid_from = GList::date_to_time($cgi->{date_from}, $date_format);
|
||||
$date_from = GT::Date::date_get($valid_from, $date_format) if ($valid_from);
|
||||
}
|
||||
if ($date_to) {
|
||||
$query .= "date_to=$cgi->{date_to};";
|
||||
$period .= " to <b>$cgi->{date_to}";
|
||||
$valid_to = GList::date_to_time($date_to, $date_format);
|
||||
$date_to = GT::Date::date_get($valid_to, $date_format) if ($valid_to);
|
||||
}
|
||||
|
||||
if (!$valid_from or !$valid_to) {
|
||||
$date_format =~ s/\%//g;
|
||||
return ('pro_report_form.html', { msg => GList::language('SYS_DATE_FORMAT_INVALID', uc GList::language('SYS_DATE_FORMAT')) });
|
||||
}
|
||||
|
||||
$from = GT::Date::timelocal(GT::Date::parse_format($date_from, $date_format));
|
||||
$to = GT::Date::timelocal(GT::Date::parse_format($date_to.' 23:59:59', "$date_format %hh%:%MM%:%ss%"));
|
||||
}
|
||||
else {
|
||||
($from, $to) = _period_time();
|
||||
($mm, $yy) = _period_time(1);
|
||||
$period = (( $cgi->{month} ) ? "$cgi->{month}/$cgi->{year}" : $cgi->{year});
|
||||
$query .= "month=$cgi->{month};" if ($cgi->{month});
|
||||
$query .= "year=$cgi->{year};" if ($cgi->{year});
|
||||
}
|
||||
require GT::SQL::Condition;
|
||||
$cd->new('mli_done', '>=', $from, 'mli_done', '<=', $to);
|
||||
|
||||
$db->select_options("GROUP BY mli_id, mli_subject, mli_done ORDER BY $sb $so");
|
||||
$db->select($cd, ['mli_id', 'mli_subject', 'mli_done', 'count(eml_mailing_id_fk) as "sent"']);
|
||||
my $hits = $db->hits;
|
||||
return ('pro_report.html', { msg => GList::language('RPT_NO_RESULT') }) if ($hits == 0);
|
||||
|
||||
$db->select_options("GROUP BY mli_id, mli_subject, mli_done ORDER BY $sb $so", "LIMIT $ns, $mh");
|
||||
my $results = $db->select($cd, ['mli_id', 'mli_subject', 'mli_done', 'count(eml_mailing_id_fk) as "sent"'])->fetchall_hashref or die $GT::SQL::error;
|
||||
my ($total) = $db->select($cd, ['count(*) as total'])->fetchrow_array;
|
||||
my $msg = ( $period ) ? GList::language('RPT_TITLE', $period) : GList::language('RPT_TITLE2');
|
||||
return ('pro_report.html', {
|
||||
msg => $msg,
|
||||
results => $results,
|
||||
hits => $hits,
|
||||
mh => $mh,
|
||||
nh => $nh,
|
||||
url => "month=$mm;year=$yy;id=$id;d=1",
|
||||
total_recipients => $total,
|
||||
toolbar_query => $query
|
||||
});
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{pro_template} = <<'END_OF_SUB';
|
||||
sub pro_template {
|
||||
#-------------------------------------------------------------------------
|
||||
# Edit the email template
|
||||
#
|
||||
return ('pro_template.html');
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_period_time} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _period_time {
|
||||
#--------------------------------------------------------------------
|
||||
# Convert a date to unix time
|
||||
#
|
||||
my $type = shift;
|
||||
require GT::Date;
|
||||
require GT::SQL::Condition;
|
||||
my ($from, $to);
|
||||
my $mm = $IN->param('month') || GT::Date::date_get(time, '%mm%');
|
||||
my $yy = $IN->param('year') || GT::Date::date_get(time, '%yyyy%');
|
||||
return ($mm, $yy) if (defined $type and $type == 1);
|
||||
|
||||
if (!$IN->param('month') and $IN->param('flag')) {
|
||||
$type = 2;
|
||||
}
|
||||
|
||||
if ( !$type ) {
|
||||
$from = GT::Date::timelocal(GT::Date::parse_format("$yy-$mm-01", '%yyyy%-%mm%-%dd%'));
|
||||
$to = GT::Date::timelocal(GT::Date::parse_format("$yy-$mm-30 00:00:00", '%yyyy%-%mm%-%dd% %hh%:%MM%:%ss%'));
|
||||
}
|
||||
else {
|
||||
$from = GT::Date::timelocal(GT::Date::parse_format("$yy-01-01", '%yyyy%-%mm%-%dd%'));
|
||||
$to = GT::Date::timelocal(GT::Date::parse_format("$yy-12-31 23:59:59", '%yyyy%-%mm%-%dd% %hh%:%MM%:%ss%'));
|
||||
}
|
||||
return ($from, $to);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_determine_action} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _determine_action {
|
||||
#----------------------------------------------------------------------------
|
||||
# Check valid action
|
||||
#
|
||||
my $action = shift || undef;
|
||||
if ( $action =~ /pro_report/ ) {
|
||||
$MN_SELECTED = 4;
|
||||
}
|
||||
else {
|
||||
$MN_SELECTED = 5;
|
||||
}
|
||||
return if ( !$action );
|
||||
|
||||
my %valid = (
|
||||
map { $_ => 1 } qw(
|
||||
pro_profile
|
||||
pro_update
|
||||
pro_password
|
||||
pro_report
|
||||
pro_template
|
||||
)
|
||||
);
|
||||
exists $valid{$action} and return $action;
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
448
site/glist/lib/GList/SQL.pm
Normal file
448
site/glist/lib/GList/SQL.pm
Normal file
@@ -0,0 +1,448 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: SQL.pm,v 1.40 2004/10/05 22:02:27 bao 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 GList::SQL;
|
||||
|
||||
use strict;
|
||||
use vars qw/@TABLES $EMAIL_RE/;
|
||||
use GList qw/$DB $CFG/;
|
||||
|
||||
@TABLES = qw/Users Users_Sessions EmailTemplates Messages Lists Subscribers
|
||||
MailingIndex EmailMailings CatMessages CatMailing MessageAttachments
|
||||
MailingAttachments StopLists/;
|
||||
|
||||
$EMAIL_RE = '.@\S+\.\S+$';
|
||||
|
||||
# Index naming format:
|
||||
#
|
||||
# a_bcd[_q]
|
||||
#
|
||||
# Where "a" is (usually) the capital letters from the table name (i.e. EmailTemplates gets "et"),
|
||||
# except for CatMailing, which is cml, and MailingAttachments, which is mla.
|
||||
#
|
||||
# b,c,d,... correspond to the following:
|
||||
#
|
||||
# b - sub_bounced
|
||||
# c - *_cat_id_fk | eml_code
|
||||
# d - session_date | mli_delete
|
||||
# e - usr_email | sub_email | stl_email
|
||||
# l - *_list_id_fk
|
||||
# m - *_message_id_fk
|
||||
# n - tpl_name | mli_done
|
||||
# t - lst_title
|
||||
# u - *_user_id_fk
|
||||
# v - sub_validated
|
||||
#
|
||||
# Finally, the optional "_q" is used for unique indices.
|
||||
#
|
||||
|
||||
sub tables {
|
||||
#----------------------------------------------------------------
|
||||
# Defines the SQL tables
|
||||
#
|
||||
my $action = shift || 'warn';
|
||||
my $output = '';
|
||||
|
||||
#---------- Users Table -----------------
|
||||
create_table(\$output, 'Users', $action,
|
||||
cols => [
|
||||
usr_username => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User Name' },
|
||||
usr_email => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Email Address', form_regex => $EMAIL_RE },
|
||||
usr_password => { type => 'CHAR', size => 100, not_null => 1, form_display => 'Password' },
|
||||
usr_type => { type => 'TINYINT', not_null => 1, default => 1, form_display => 'Type' },
|
||||
usr_reply_email => { type => 'CHAR', size => 100, not_null => 0, form_display => 'Reply to Email', form_regex => $EMAIL_RE },
|
||||
usr_bounce_email => { type => 'CHAR', size => 100, not_null => 0, form_display => 'Bounce Email', form_regex => $EMAIL_RE },
|
||||
usr_date_format => { type => 'CHAR', size => 50, form_display => 'Date Format' },
|
||||
usr_compose_mode => { type => 'CHAR', size => 5, form_display => 'Editor Advanced', default => 'text' },
|
||||
usr_editor_advanced => { type => 'TINYINT', not_null => 1, default => 0 },
|
||||
usr_status => { type => 'TINYINT', default => '1', form_display => 'Status' },
|
||||
usr_limit_list => { type => 'INT', default => '0', form_display => 'Limit Number of List' },
|
||||
usr_limit_sublist => { type => 'INT', default => '0', form_display => 'Limit Number of subscriber per List' },
|
||||
usr_limit_email30 => { type => 'INT', default => '0', form_display => 'Limit Number of Email Sending in The Last 30 days' },
|
||||
usr_mail_host => { type => 'CHAR', size => 100, form_display => 'Server Mail hostname' },
|
||||
usr_mail_port => { type => 'CHAR', size => 3, form_display => 'Server Mail port' },
|
||||
usr_mail_account => { type => 'CHAR', size => 50, form_display => 'Mail Account' },
|
||||
usr_mail_password => { type => 'CHAR', size => 20, form_display => 'Mail Password' },
|
||||
usr_validate_code => { type => 'CHAR', size => 32, binary => 1, form_display => 'Validate Code' },
|
||||
usr_updated => { type => 'TINYINT', default => '0', form_display => 'Account Updated' },
|
||||
usr_header_html => { type => 'TEXT', default => '', form_display => 'Mailing Header' },
|
||||
usr_header_text => { type => 'TEXT', default => '', form_display => 'Mailing Header' },
|
||||
usr_footer_html => { type => 'TEXT', default => '', form_display => 'Mailing Footer' },
|
||||
usr_footer_text => { type => 'TEXT', default => '', form_display => 'Mailing Footer' },
|
||||
pro_first_name => { type => 'CHAR', size => 20, not_null => 1, form_display => 'First Name', form_size => '35' },
|
||||
pro_last_name => { type => 'CHAR', size => 30, not_null => 1, form_display => 'Last Name', form_size => '35' },
|
||||
pro_company => { type => 'CHAR', size => 100, form_display => 'Company Name', form_size => '35' },
|
||||
pro_url => { type => 'CHAR', size => 255, form_display => 'URL', form_size => '35' },
|
||||
],
|
||||
pk => 'usr_username',
|
||||
unique => {
|
||||
u_e_q => ['usr_email']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- Users_Sessions Table -----------------
|
||||
create_table(\$output, 'Users_Sessions', $action,
|
||||
cols => [
|
||||
session_id => { type => 'CHAR', binary => 1, size => 32, not_null => 1 },
|
||||
session_user_id => { type => 'CHAR', size => 50 },
|
||||
session_date => { type => 'INT', not_null => 1 },
|
||||
session_data => { type => 'TEXT' }
|
||||
],
|
||||
pk => 'session_id',
|
||||
fk => {
|
||||
Users => { session_user_id => 'usr_username' }
|
||||
},
|
||||
index => {
|
||||
us_d => ['session_date']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- EmailTemplates Table -----------------
|
||||
create_table(\$output, 'EmailTemplates', $action,
|
||||
cols => [
|
||||
tpl_id => { type => 'INT', not_null=> 1, form_display => 'ID' },
|
||||
tpl_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User Name' },
|
||||
tpl_name => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Template Name' },
|
||||
tpl_to => { type => 'CHAR', size => 50, not_null => 1, form_display => 'To' },
|
||||
tpl_subject => { type => 'CHAR', size => 100,not_null => 1, form_display => 'Subject' },
|
||||
tpl_from => { type => 'CHAR', size => 100,not_null => 1, form_display => 'From' },
|
||||
tpl_extra => { type => 'CHAR', size => 255, form_display => 'Extra Header' },
|
||||
tpl_body => { type => 'TEXT', not_null=> 1, form_display => 'Email Body' },
|
||||
],
|
||||
pk => 'tpl_id',
|
||||
ai => 'tpl_id',
|
||||
|
||||
unique => {
|
||||
et_un_q => [qw/tpl_user_id_fk tpl_name/]
|
||||
},
|
||||
fk => { Users => { tpl_user_id_fk => 'usr_username' } }
|
||||
);
|
||||
|
||||
#---------- CatMessages Table -----------------
|
||||
create_table(\$output, 'CatMessages', $action,
|
||||
cols => [
|
||||
cms_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
cms_name => { type => 'CHAR', not_null => 1, size => 30, form_display => 'Folder Name' },
|
||||
cms_user_id_fk => { type => 'CHAR', not_null => 1, size => 50, form_display => 'User ID' },
|
||||
],
|
||||
pk => 'cms_id',
|
||||
ai => 'cms_id',
|
||||
index => {
|
||||
cm_u => ['cms_user_id_fk']
|
||||
},
|
||||
fk => { Users => { cms_user_id_fk => 'usr_username' } }
|
||||
);
|
||||
|
||||
#---------- Messages Table -----------------
|
||||
create_table(\$output, 'Messages', $action,
|
||||
cols => [
|
||||
msg_id => { type => 'INT', not_null => 1, form_display => 'Message ID' },
|
||||
msg_mode => { type => 'CHAR', size => 5, default => 'text', form_display => 'Message Mode' },
|
||||
msg_charset => { type => 'CHAR', size => 15, not_null => 1, default => 'us-ascii', form_display => 'Charset'},
|
||||
msg_subject => { type => 'CHAR', size => 100, not_null => 1, form_display => 'Subject', 'weight' => '1' },
|
||||
msg_from_name => { type => 'CHAR', size => 70, form_display => 'From Name' },
|
||||
msg_from_email => { type => 'CHAR', size => 100, not_null => 1, form_display => 'From Email', form_regex => $EMAIL_RE },
|
||||
msg_reply_to => { type => 'CHAR', size => 100, not_null => 1, form_display => 'Reply to Email', form_regex => $EMAIL_RE },
|
||||
msg_bounce_email => { type => 'CHAR', size => 100, not_null => 1, form_display => 'Bounce Email', form_regex => $EMAIL_RE },
|
||||
msg_created => { type => 'INT', form_display => 'Name' },
|
||||
msg_content_text => { type => 'LONGTEXT', form_display => 'TEXT Content', 'weight' => '1' },
|
||||
msg_content_html => { type => 'LONGTEXT', form_display => 'HTML Content', 'weight' => '1' },
|
||||
msg_cat_id_fk => { type => 'INT', default => 0, not_null => 1, form_display => 'Category ID' },
|
||||
msg_status => { type => 'TINYINT', default => 0, form_display => 'Status' },
|
||||
msg_track_open => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Track Number of Users opening this message' },
|
||||
msg_track_click => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Track Number of Clicks' },
|
||||
msg_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User ID' },
|
||||
],
|
||||
pk => 'msg_id',
|
||||
ai => 'msg_id',
|
||||
fk => {
|
||||
Users => { msg_user_id_fk => 'usr_username' },
|
||||
CatMessages => { msg_cat_id_fk => 'cms_id' }
|
||||
},
|
||||
index => {
|
||||
m_uc => [qw/msg_user_id_fk msg_cat_id_fk/]
|
||||
}
|
||||
);
|
||||
|
||||
#---------- MessageAttachments Table -----------------
|
||||
create_table(\$output, 'MessageAttachments', $action,
|
||||
cols => [
|
||||
att_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
att_message_id_fk => { type => 'INT', not_null => 1, form_display => 'Campaign ID' },
|
||||
att_file_name => { type => 'CHAR', size => 255, form_display => 'File Name' },
|
||||
att_file_size => { type => 'INT', form_display => 'File Size' },
|
||||
],
|
||||
pk => 'att_id',
|
||||
ai => 'att_id',
|
||||
fk => { Messages => { att_message_id_fk => 'msg_id' } },
|
||||
index => {
|
||||
ma_m => ['att_message_id_fk']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- Lists Table -----------------
|
||||
create_table(\$output, 'Lists', $action,
|
||||
cols => [
|
||||
lst_id => { type => 'INT', not_null => 1, form_display => 'List ID' },
|
||||
lst_title => { type => 'CHAR', size => 50, not_null => 1, form_display => 'List Name', weight => '1' },
|
||||
lst_description => { type => 'TEXT', form_display => 'Name', weight => '1' },
|
||||
lst_opt => { type => 'TINYINT', form_display => 'Double Opt In', default => '0' },
|
||||
lst_opt_template => { type => 'CHAR', size => 50, form_display => 'Opt In Template' },
|
||||
lst_subs_template => { type => 'CHAR', size => 50, form_display => 'Subscriber Template' },
|
||||
lst_unsubs_template => { type => 'CHAR', size => 50, form_display => 'Unsubscriber Template' },
|
||||
lst_date_created => { type => 'INT', form_display => 'Created' },
|
||||
lst_url_subscribe_success => { type => 'CHAR', size => 255, form_display => 'Success Subscribe URL' },
|
||||
lst_url_validate_success => { type => 'CHAR', size => 255, form_display => 'Success Validate URL' },
|
||||
lst_url_unsubscribe_success => { type => 'CHAR', size => 255, form_display => 'Success Unsubscribe URL' },
|
||||
lst_url_subscribe_failure => { type => 'CHAR', size => 255, form_display => 'Failure Subscribe URL' },
|
||||
lst_url_unsubscribe_failure => { type => 'CHAR', size => 255, form_display => 'Failure Unsubscribe URL' },
|
||||
lst_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User ID' },
|
||||
],
|
||||
pk => 'lst_id',
|
||||
ai => 'lst_id',
|
||||
fk => { Users => { lst_user_id_fk => 'usr_username' } },
|
||||
index => {
|
||||
l_ut => [qw/lst_user_id_fk lst_title/]
|
||||
}
|
||||
);
|
||||
|
||||
#---------- Subscribers Table -----------------
|
||||
create_table(\$output, 'Subscribers', $action,
|
||||
cols => [
|
||||
sub_id => { type => 'INT', not_null => 1, form_display => 'Subscriber ID' },
|
||||
sub_email => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Subscriber Email', form_regex => $EMAIL_RE, weight => '1' },
|
||||
sub_name => { type => 'CHAR', size => 50, form_display => 'Subscriber Name', weight => '1' },
|
||||
sub_created => { type => 'INT', form_display => 'Created' },
|
||||
sub_list_id_fk => { type => 'INT', not_null => 1, form_display => 'List ID' },
|
||||
sub_validated => { type => 'TINYINT', not_null => 1, default => 1, form_display => 'Validated' },
|
||||
sub_val_code => { type => 'CHAR', size => 50, form_display => 'Validation Code' },
|
||||
sub_bounced => { type => 'INT', not_null => 1, default => 0, form_display => 'Bounced Email' },
|
||||
sub_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User ID' },
|
||||
],
|
||||
|
||||
pk => 'sub_id',
|
||||
ai => 'sub_id',
|
||||
fk => {
|
||||
Lists => { sub_list_id_fk => 'lst_id' },
|
||||
Users => { sub_user_id_fk => 'usr_username' }
|
||||
},
|
||||
index => {
|
||||
s_lb => [qw/sub_list_id_fk sub_bounced/],
|
||||
s_lvb => [qw/sub_list_id_fk sub_validated sub_bounced/],
|
||||
s_ue => [qw/sub_user_id_fk sub_email/],
|
||||
s_e => [qw/sub_email/]
|
||||
},
|
||||
unique => {
|
||||
s_le_q => [qw/sub_list_id_fk sub_email/]
|
||||
}
|
||||
);
|
||||
|
||||
#---------- CatMailing Table -----------------
|
||||
create_table(\$output, 'CatMailing', $action,
|
||||
cols => [
|
||||
cm_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
cm_name => { type => 'CHAR', not_null => 1, size => 30, form_display => 'Folder Name' },
|
||||
cm_type => { type => 'TINYINT', default => '1', form_display => 'Type' },
|
||||
cm_user_id_fk => { type => 'CHAR', not_null => 1, size => 50, form_display => 'User ID' },
|
||||
],
|
||||
pk => 'cm_id',
|
||||
ai => 'cm_id',
|
||||
fk => { Users => { cm_user_id_fk => 'usr_username' } },
|
||||
index => {
|
||||
cml_u => ['cm_user_id_fk']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- MailingIndex Table -----------------
|
||||
create_table(\$output, 'MailingIndex', $action,
|
||||
cols => [
|
||||
mli_id => { type => 'INT', not_null => 1, form_display => 'Mailing ID' },
|
||||
mli_done => { type => 'INT', default => 0, form_display => 'Done' },
|
||||
mli_from => { type => 'CHAR', size => 100, form_display => 'From Email', form_regex => $EMAIL_RE },
|
||||
mli_name => { type => 'CHAR', size => 50, form_display => 'From Name' },
|
||||
mli_reply_to => { type => 'CHAR', size => 100, form_display => 'Reply To Email', form_regex => $EMAIL_RE },
|
||||
mli_bounce_email => { type => 'CHAR', size => 100, form_display => 'Bounce Email', form_regex => $EMAIL_RE },
|
||||
mli_charset => { type => 'CHAR', size => 15, not_null => 1, default => 'us-ascii', form_display => 'Charset'},
|
||||
mli_subject => { type => 'CHAR', size => 100, form_display => 'Subject', 'weight' => '1' },
|
||||
mli_message_text => { type => 'LONGTEXT', form_display => 'TEXT Message', 'weight' => '1' },
|
||||
mli_message_html => { type => 'LONGTEXT', form_display => 'HTML Message', 'weight' => '1' },
|
||||
mli_cat_id_fk => { type => 'INT', not_null => 1, default => 0, form_display => 'Category ID' },
|
||||
mli_delete => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Delete' },
|
||||
mli_track_open => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Track Number of Users opening this message' },
|
||||
mli_track_click => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Track Number of clicks' },
|
||||
mli_num_opened => { type => 'INT', not_null => 1, default => 0, form_display => 'Number of Users opening this message' },
|
||||
mli_num_clicked => { type => 'INT', not_null => 1, default => 0, form_display => 'Number of clicks' },
|
||||
mli_scheduled => { type => 'TINYINT', not_null => 1, default => 0, form_display => 'Scheduled Mailing' },
|
||||
mli_user_id_fk => { type => 'CHAR', size => 50, not_null => 1, form_display => 'User ID' }
|
||||
],
|
||||
pk => 'mli_id',
|
||||
ai => 'mli_id',
|
||||
fk => {
|
||||
Users => { mli_user_id_fk => 'usr_username' },
|
||||
CatMailing => { mli_cat_id_fk => 'cm_id' }
|
||||
},
|
||||
|
||||
index => {
|
||||
mi_ucdn => [qw/mli_user_id_fk mli_cat_id_fk mli_delete mli_done/],
|
||||
mi_c => ['mli_cat_id_fk']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- EmailMailings Table -----------------
|
||||
create_table(\$output, 'EmailMailings', $action,
|
||||
cols => [
|
||||
eml_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
eml_mailing_id_fk => { type => 'INT', not_null => 1, form_display => 'Mailing ID' },
|
||||
eml_email => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Email Address', form_regex => $EMAIL_RE },
|
||||
eml_name => { type => 'CHAR', size => 50, form_display => 'Name' },
|
||||
eml_sent => { type => 'INT', not_null => 1, default => 0 },
|
||||
eml_bounced => { type => 'TINYINT', not_null => 1, default => 0 },
|
||||
eml_skipped => { type => 'TINYINT', not_null => 1, default => 0 },
|
||||
eml_opened => { type => 'INT', not_null => 1, default => 0 },
|
||||
eml_code => { type => 'CHAR', size => 100 => not_null => 1 },
|
||||
eml_lists => { type => 'TEXT', default => '' },
|
||||
],
|
||||
pk => 'eml_id',
|
||||
ai => 'eml_id',
|
||||
fk => { MailingIndex => { eml_mailing_id_fk => 'mli_id' } },
|
||||
index => {
|
||||
em_mb => [qw/eml_mailing_id_fk eml_bounced/],
|
||||
em_ms => [qw/eml_mailing_id_fk eml_sent/],
|
||||
em_mo => [qw/eml_mailing_id_fk eml_opened/],
|
||||
em_e => [qw/eml_email/],
|
||||
em_c => [qw/eml_code/],
|
||||
},
|
||||
unique => {
|
||||
em_me_q => [qw/eml_mailing_id_fk eml_email/]
|
||||
}
|
||||
);
|
||||
|
||||
#---------- ScheduledMailings Table -----------------
|
||||
create_table(\$output, 'ScheduledMailings', $action,
|
||||
cols => [
|
||||
scm_id => { type => 'INT', not_null => 1, form_display => 'Schedule ID'},
|
||||
scm_hour => { type => 'INT', default => 0, form_display => 'Hour' },
|
||||
scm_minute => { type => 'INT', default => 0, form_display => 'Minute' },
|
||||
scm_type => { type => 'TINYINT', default => 0, form_display => 'Schedule Type' },
|
||||
scm_option => { type => 'CHAR', size => 10, default => '', form_display => 'Option' },
|
||||
scm_text_url => { type => 'CHAR', size => 225, default => '', form_display => 'Text URL' },
|
||||
scm_html_url => { type => 'CHAR', size => 225, default => '', form_display => 'Html URL' },
|
||||
scm_inprocess => { type => 'TINYINT', default => 0, form_display => 'In Process' },
|
||||
scm_sent => { type => 'INT', default => 0, form_display => 'Sent Time' },
|
||||
scm_mailing_id_fk => { type => 'INT', default => 0, form_display => 'Mailing ID' },
|
||||
],
|
||||
ai => 'scm_id',
|
||||
pk => 'scm_id',
|
||||
unique => {
|
||||
sm_m_q => [qw/scm_mailing_id_fk/]
|
||||
},
|
||||
fk => { MailingIndex => { scm_mailing_id_fk => 'mli_id' } }
|
||||
);
|
||||
|
||||
#---------- MailingAttachments Table -----------------
|
||||
create_table(\$output, 'MailingAttachments', $action,
|
||||
cols => [
|
||||
mat_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
mat_mailing_id_fk => { type => 'INT', not_null => 1, form_display => 'Mailing ID' },
|
||||
mat_file_name => { type => 'CHAR', size => 255, form_display => 'File Name' },
|
||||
mat_file_size => { type => 'INT', form_display => 'File Size' },
|
||||
],
|
||||
pk => 'mat_id',
|
||||
ai => 'mat_id',
|
||||
fk => { MailingIndex => { mat_mailing_id_fk => 'mli_id' } },
|
||||
index => {
|
||||
mla_m => ['mat_mailing_id_fk']
|
||||
}
|
||||
);
|
||||
|
||||
#---------- StopLists Table -----------------
|
||||
create_table(\$output, 'StopLists', $action,
|
||||
cols => [
|
||||
stl_id => { type => 'INT', not_null => 1, form_display => 'ID' },
|
||||
stl_email => { type => 'CHAR', size => 50, not_null => 1, form_display => 'Email Address', form_regex => $EMAIL_RE },
|
||||
],
|
||||
pk => 'stl_id',
|
||||
ai => 'stl_id',
|
||||
unique => {
|
||||
s_e_q => ['stl_email']
|
||||
}
|
||||
);
|
||||
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub create_table {
|
||||
my ($output, $table, $action, @def) = @_;
|
||||
|
||||
$$output .= "Creating $table table ... ";
|
||||
my $c = $DB->creator($table);
|
||||
$c->clear_schema() if $action eq 'force';
|
||||
|
||||
@def % 2 and die "Odd number of table defs passed to create_table()";
|
||||
while (@def) {
|
||||
my ($meth, $arg) = splice @def, 0, 2;
|
||||
$c->$meth($arg);
|
||||
}
|
||||
|
||||
if ($c->create($action)) {
|
||||
$$output .= "okay\n";
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
$GT::SQL::errcode if 0; # silence "used only once" warnings
|
||||
$$output .= $GT::SQL::errcode eq 'TBLEXISTS' ? "failed (table already exists)\n" : "failed ($GT::SQL::error)\n";
|
||||
$c->set_defaults;
|
||||
$c->save_schema;
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub load_from_sql {
|
||||
# ---------------------------------------------------------------
|
||||
# Creates def files based on existing tables.
|
||||
#
|
||||
my ($output, $return);
|
||||
foreach my $table (@TABLES) {
|
||||
$output .= "$table .. ";
|
||||
my $c = $DB->creator($table);
|
||||
$return = $c->load_table($table);
|
||||
if ($return) {
|
||||
$output .= "ok\n";
|
||||
$c->save_schema();
|
||||
}
|
||||
else {
|
||||
$output .= "failed: $GT::SQL::error\n";
|
||||
}
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub load {
|
||||
# ---------------------------------------------------------------
|
||||
# Return a hash of current connection settings.
|
||||
#
|
||||
my %h = ();
|
||||
$h{prefix} = $DB->prefix();
|
||||
$h{database} = $DB->{connect}->{database};
|
||||
$h{login} = $DB->{connect}->{login};
|
||||
$h{password} = $DB->{connect}->{password};
|
||||
$h{host} = $DB->{connect}->{host};
|
||||
$h{host} .= ":" . $DB->{connect}->{port} if $DB->{connect}->{port};
|
||||
$h{driver} = $DB->{connect}->{driver};
|
||||
return \%h;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
144
site/glist/lib/GList/Template.pm
Normal file
144
site/glist/lib/GList/Template.pm
Normal file
@@ -0,0 +1,144 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Template.pm,v 1.6 2004/03/10 01:04:53 bao 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 GList::Template;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
|
||||
use GList qw/:objects $DEBUG/;
|
||||
use GList::Config;
|
||||
use GT::Template;
|
||||
use vars qw/@ISA %VARS %MVARS/;
|
||||
|
||||
@ISA = qw/GT::Template/;
|
||||
|
||||
# Need to reset %VARS on each access of the page for mod_perl.
|
||||
# Takes no args.
|
||||
sub reset_env {
|
||||
%VARS = ();
|
||||
}
|
||||
|
||||
# Takes no args, returns all the mlist globals
|
||||
sub globals {
|
||||
my $g = {
|
||||
version => $GList::CFG->{version},
|
||||
image_url => $GList::CFG->{image_url},
|
||||
cgi_url => $GList::CFG->{cgi_url},
|
||||
root_path => $GList::CFG->{root_path},
|
||||
priv_path => $GList::CFG->{priv_path}
|
||||
};
|
||||
|
||||
if ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i and $ENV{HTTP_USER_AGENT} !~ /mac/i) {
|
||||
$g->{is_ie} = 1;
|
||||
$g->{ie_version} = $1;
|
||||
}
|
||||
|
||||
$g;
|
||||
}
|
||||
|
||||
# Takes 0 or 1 args - the template set. If not provided, it will try to use hidden 't' or else fall back to the Config default.
|
||||
sub template_globals {
|
||||
|
||||
my $globals = GT::Config->load("$GList::CFG->{priv_path}/templates/common/globals.txt", { create_ok => 1, inheritance => 1, local => 1, compile_subs => 'GList', header => <<HEADER });
|
||||
# This file is auto-generated and contains a perl hash of your
|
||||
# global variables for the template set.
|
||||
# Generated: [localtime]
|
||||
# vim:syn=perl:ts=4
|
||||
|
||||
HEADER
|
||||
|
||||
my $ret = {}; # Since we are converting the values in $globals to scalar references, the cache will become screwed up under mod_perl, so we have to copy them out into this.
|
||||
|
||||
for (keys %$globals) {
|
||||
my $val = $globals->{$_};
|
||||
if (ref $val) {
|
||||
$ret->{$_} = $val;
|
||||
}
|
||||
else {
|
||||
$val =~ s/<%image_url%>/$CFG->{image_url}/g;
|
||||
$ret->{$_} = \$val;
|
||||
}
|
||||
}
|
||||
|
||||
$ret;
|
||||
}
|
||||
|
||||
# This is useful to set variables inside a loop, then retrieve them outside the
|
||||
# loop. It stores them in %VARS.
|
||||
# It takes args as a hash ref.
|
||||
sub store_gvars {
|
||||
my %vars = @_;
|
||||
@MVARS{keys %vars} = values %vars;
|
||||
return;
|
||||
}
|
||||
|
||||
# Takes no args, but returns a reference to the hash containing the "kept"
|
||||
# variables that were set inside some sort of loop
|
||||
sub retrieve_gvars {
|
||||
\%MVARS
|
||||
}
|
||||
|
||||
# Takes all the args of GT::Template, but this changes them a bit before giving them to
|
||||
# GT::Template to add on the variables, globals, and template set globals.
|
||||
sub parse {
|
||||
my $globals = globals();
|
||||
my $set_globals = template_globals();
|
||||
|
||||
my $self = shift;
|
||||
|
||||
local %MVARS; # Localize this so that it will be empty for this parse
|
||||
my $page = $_[0];
|
||||
my ($vars, $opt) = @_[1, 2];
|
||||
my ($retvars, $retopt);
|
||||
if (ref $vars eq 'ARRAY') {
|
||||
# put it on the beginning so that anything else will overwrite it
|
||||
$retvars = [{ ($set_globals ? (%$set_globals) : ()), %$globals, %VARS }, @$vars]
|
||||
}
|
||||
elsif (ref $vars eq 'HASH' or UNIVERSAL::isa($vars, 'GT::Config')) {
|
||||
$retvars = {%$vars};
|
||||
# %VARS is first because it overrides mlist globals and template set globals.
|
||||
for (keys %VARS) {
|
||||
$retvars->{$_} = $VARS{$_} unless exists $retvars->{$_}
|
||||
}
|
||||
# Generally, installation globals should be be overridable by template set globals.
|
||||
for (keys %$globals) {
|
||||
$retvars->{$_} = $globals->{$_} unless exists $retvars->{$_}
|
||||
}
|
||||
# Template set globals are considered last and are only set if nothing else has set them.
|
||||
for (keys %$set_globals) {
|
||||
$retvars->{$_} = $set_globals->{$_} unless exists $retvars->{$_}
|
||||
}
|
||||
}
|
||||
elsif (ref $vars) {
|
||||
$retvars = [{ %$set_globals, %$globals, %VARS }, $vars]
|
||||
}
|
||||
else {
|
||||
$retvars = { %$set_globals, %$globals, %VARS }
|
||||
}
|
||||
|
||||
# Put the "escape" option on by default - it specifically has to be
|
||||
# specified as 0 to disable it.
|
||||
if ($opt) {
|
||||
$retopt = {%$opt};
|
||||
$retopt->{escape} = 1 unless exists $retopt->{escape};
|
||||
$retopt->{compress} = $CFG->{compress} unless exists $retopt->{compress};
|
||||
}
|
||||
else {
|
||||
$retopt = { escape => 1, compress => $CFG->{compress} };
|
||||
}
|
||||
$retopt->{debug_level} = $CFG->{debug_level} if $CFG->{debug_level};
|
||||
$self->SUPER::parse($_[0], $retvars, $retopt, @_[3 .. $#_]);
|
||||
}
|
||||
|
||||
1;
|
||||
532
site/glist/lib/GList/Tools.pm
Normal file
532
site/glist/lib/GList/Tools.pm
Normal file
@@ -0,0 +1,532 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: Tools.pm,v 1.37 2004/10/06 17:58:17 bao 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 GList::Tools;
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects $LANGUAGE $GLOBALS/;
|
||||
|
||||
use constants KB => 1024, MB => 1024 * 1024;
|
||||
|
||||
sub generate_used_bar {
|
||||
#-------------------------------------------------------------------
|
||||
#
|
||||
my ($type, $max_width) = @_;
|
||||
|
||||
my ($percent, $img_width, $msg) = (0, 0, '');
|
||||
if ($type eq 'email30') {
|
||||
require GT::Date;
|
||||
require GT::SQL::Condition;
|
||||
my $last30 = GT::Date::date_sub(GT::Date::date_get(), 30);
|
||||
my $unix_time = GList::date_to_time($last30);
|
||||
my $num_sent = $DB->table('MailingIndex', 'EmailMailings')->count(
|
||||
GT::SQL::Condition->new(
|
||||
mli_user_id_fk => '=' => $USER->{usr_username},
|
||||
eml_sent => '>=' => $unix_time
|
||||
)
|
||||
);
|
||||
if ($num_sent >= $USER->{usr_limit_email30}) {
|
||||
$percent = 100;
|
||||
$img_width = $max_width;
|
||||
}
|
||||
else {
|
||||
$percent = int(100 * $num_sent / $USER->{usr_limit_email30});
|
||||
$img_width = int($num_sent * $max_width / $USER->{usr_limit_email30});
|
||||
}
|
||||
$msg = GList::language('SYS_USEDBAR_EMAIL30', $percent, $USER->{usr_limit_email30});
|
||||
}
|
||||
elsif ($type eq 'sublist') {
|
||||
my $num_lists = $DB->table('Lists')->count({ lst_user_id_fk => $USER->{usr_username} });
|
||||
my $num_subs = $DB->table('Subscribers')->count({ sub_user_id_fk => $USER->{usr_username} });
|
||||
my $sub_limit = ($num_lists) ? $num_lists * $USER->{usr_limit_sublist} : $USER->{usr_limit_sublist};
|
||||
if ($num_subs >= $sub_limit) {
|
||||
$percent = 100;
|
||||
$img_width = $max_width;
|
||||
}
|
||||
else {
|
||||
$percent = int(100 * $num_subs / $sub_limit);
|
||||
$img_width = int($num_subs * $max_width / $sub_limit);
|
||||
}
|
||||
$msg = GList::language('SYS_USEDBAR_SUBLIST', $percent, $sub_limit);
|
||||
}
|
||||
return { used_message => $msg, used_percent => $percent, used_image_width => $img_width };
|
||||
}
|
||||
|
||||
sub generate_list {
|
||||
# ------------------------------------------------------------------
|
||||
# Generates a list of lists
|
||||
#
|
||||
my $object = shift;
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
my $lists = $DB->table('Lists');
|
||||
$lists->select_options('ORDER BY lst_Title');
|
||||
|
||||
my $sth = $lists->select({ lst_user_id_fk => $tags->{usr_username} }) or die $GT::SQL::error;
|
||||
my $html = "";
|
||||
my $current = $tags->{$object};
|
||||
while ( my $rs = $sth->fetchrow_hashref ) {
|
||||
if (ref $current eq 'ARRAY') {
|
||||
my $id = 0;
|
||||
foreach (@$current) {
|
||||
if ($_ == $rs->{lst_id}) {
|
||||
$id = $_;last;
|
||||
}
|
||||
}
|
||||
$html .= ( $id == $rs->{lst_id} ) ? "<option value='$rs->{lst_id}' selected>$rs->{lst_title}</option>"
|
||||
: "<option value='$rs->{lst_id}'>$rs->{lst_title}</option>";
|
||||
}
|
||||
else {
|
||||
$html .= ( $current == $rs->{lst_id} ) ? "<option value='$rs->{lst_id}' selected>$rs->{lst_title}</option>"
|
||||
: "<option value='$rs->{lst_id}'>$rs->{lst_title}</option>";
|
||||
}
|
||||
}
|
||||
return $html;
|
||||
}
|
||||
|
||||
sub default_email_editor {
|
||||
#------------------------------------------------------------------
|
||||
# Load the default email templates editor
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
my $selected_dir = $cgi->{tpl_dir} || $CFG->{template_set} || 'gossamer';
|
||||
|
||||
my $demo;
|
||||
#------------demo code-----------
|
||||
|
||||
# Build the select lists.
|
||||
my $d_select_list = _template_dir_select();
|
||||
my ($f_select_list, $selected_file) = _default_select("$CFG->{priv_path}/templates/$selected_dir", $cgi->{tpl_file});
|
||||
|
||||
return { select_list => $f_select_list, tpl_dir => "$CFG->{priv_path}/templates/", selected_dir => $selected_dir, dir_select => $d_select_list, demo => $demo, tpl_file => $selected_file, bload => ($selected_file) ? 1 : 0 };
|
||||
}
|
||||
|
||||
sub email_editor {
|
||||
#------------------------------------------------------------------
|
||||
# Load the email template editor
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
|
||||
my $tpl = {};
|
||||
my $db = $DB->table('EmailTemplates');
|
||||
my $cols = $db->cols;
|
||||
my ($msg, $error, $demo);
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
# Save the email template
|
||||
my $save_as = $cgi->{save_as};
|
||||
if ( $cgi->{bsave} and $save_as ) {
|
||||
if ( $demo ) {
|
||||
$msg = '<font color="red">Edit email template has been disabled in the demo!</font>';
|
||||
}
|
||||
else {
|
||||
my @required = ('tpl_to', 'tpl_from', 'tpl_subject', 'tpl_body');
|
||||
my $hsh = {};
|
||||
foreach ( @required ) {
|
||||
$hsh->{$_} = $cgi->{$_} if ( defined $cgi->{$_} );
|
||||
}
|
||||
$hsh->{tpl_user_id_fk} = $tags->{usr_username};
|
||||
$hsh->{tpl_name} = $save_as;
|
||||
if ( $cgi->{tpl_extra} ) {
|
||||
for ( split /\s*\n\s*/, $cgi->{tpl_extra} ) { # This will weed out any blank lines
|
||||
my ($key, $value) = split /\s*:\s*/, $_, 2;
|
||||
$hsh->{tpl_extra} .= "$key: $value\n" if $key and $value;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$hsh->{tpl_extra} = '';
|
||||
}
|
||||
|
||||
foreach ( @required ) {
|
||||
if ( !$hsh->{$_} ) {
|
||||
$msg = GList::language('TPL_INVALID');
|
||||
$error = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
if ( !$msg ) {
|
||||
if ( $save_as eq $cgi->{tpl_name} ) { # Update an exist template
|
||||
$db->update($hsh, { tpl_user_id_fk => $tags->{usr_username}, tpl_name => $save_as });
|
||||
$msg = ( $GT::SQL::error ) ? "<font color=red><b>$GT::SQL::error</b></font>" : GList::language('TPL_UPDATED', $save_as);
|
||||
}
|
||||
else { # Add a new template
|
||||
$db->insert($hsh);
|
||||
$msg = ( $GT::SQL::error ) ? "<font color=red><b>$GT::SQL::error</b></font>" : GList::language('TPL_ADDED', $save_as);
|
||||
$cgi->{tpl_name} = $save_as if ( !$GT::SQL::error );
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( $cgi->{txtdelete} ) { # Delete an existing template
|
||||
if ( $demo ) {
|
||||
$msg = '<font color="red">Edit email template has been disabled in the demo !</font>';
|
||||
}
|
||||
else {
|
||||
require GT::SQL::Condition;
|
||||
my $cond = GT::SQL::Condition->new('lst_user_id_fk', '=', $tags->{usr_username});
|
||||
$cond->add(GT::SQL::Condition->new('lst_opt_template', '=', $cgi->{tpl_name}, 'lst_subs_template', '=', $cgi->{tpl_name}, 'lst_unsubs_template', '=', $cgi->{tpl_name}, 'OR'));
|
||||
|
||||
my $sth = $DB->table('Lists')->select($cond);
|
||||
if ( $sth->rows ) {
|
||||
$msg = GList::language('TPL_DELETE_ERROR', $cgi->{tpl_name});
|
||||
}
|
||||
else {
|
||||
$db->delete({ tpl_user_id_fk => $tags->{usr_username}, tpl_name => $cgi->{tpl_name} });
|
||||
$msg = ( $GT::SQL::error ) ? "<font color=red><b>$GT::SQL::error</b></font>" : GList::language('TPL_DELETED', $cgi->{tpl_name});
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ( $cgi->{bdefault} ) { # Load default templates
|
||||
GList::set_default_template('validation.eml', $tags->{usr_username});
|
||||
GList::set_default_template('subscribe.eml', $tags->{usr_username});
|
||||
GList::set_default_template('unsubscribe.eml', $tags->{usr_username});
|
||||
$msg = ( $GT::SQL::error ) ? "<font color=red><b>$GT::SQL::error</b></font>" : GList::language('TPL_LOADED');
|
||||
}
|
||||
|
||||
# Build the select lists.
|
||||
my $f_current_list = _current_select('tpl_name', $cgi->{tpl_name});
|
||||
if ( $cgi->{tpl_name} and !$GT::SQL::error and !$error ) {
|
||||
$tpl = $db->get({ tpl_user_id_fk => $tags->{usr_username}, tpl_name => $cgi->{tpl_name} });
|
||||
if ( !$tpl ) {
|
||||
foreach (keys %$cols) { $tpl->{$_} = ''; }
|
||||
}
|
||||
}
|
||||
|
||||
return { current_list => $f_current_list, msg => $msg, %$tpl };
|
||||
}
|
||||
|
||||
sub template_editor {
|
||||
# ------------------------------------------------------------------
|
||||
# Loads the template editor.
|
||||
#
|
||||
_editor_obj()->process;
|
||||
}
|
||||
|
||||
sub language_editor {
|
||||
# ------------------------------------------------------------------
|
||||
# Loads the language file editor.
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my ($font, $message, $table);
|
||||
my $cgi = $IN->get_hash;
|
||||
my $selected_dir = $cgi->{tpl_dir} || $CFG->{template_set} || 'gossamer';
|
||||
|
||||
$font = 'face="Tahoma,Arial,Helvetica" size="2"';
|
||||
|
||||
my $demo;
|
||||
#------------demo code-----------
|
||||
|
||||
GList::load_language($selected_dir);
|
||||
|
||||
if ($cgi->{save}) {
|
||||
if ($demo) {
|
||||
$message = '<font color="red">The language editor has been disabled in the demo!</font>';
|
||||
}
|
||||
else {
|
||||
my $need_save;
|
||||
foreach my $code (keys %$cgi) {
|
||||
if ($code =~ /^del-(.*)$/) {
|
||||
delete $LANGUAGE->{$1};
|
||||
++$need_save;
|
||||
}
|
||||
elsif ($code =~ /^save-(.*)/) {
|
||||
my $key = $1;
|
||||
next if $cgi->{"del-$key"};
|
||||
my $var = $cgi->{$code};
|
||||
$var =~ s/\r\n/\n/g; # Remove windows linefeeds.
|
||||
next if exists $LANGUAGE->{$key} and $LANGUAGE->{$key} eq $var;
|
||||
$LANGUAGE->{$key} = $var;
|
||||
++$need_save;
|
||||
}
|
||||
}
|
||||
|
||||
if (my $key = $cgi->{new} and my $var = $cgi->{'new-val'}) {
|
||||
$var =~ s/\r\n/\n/g;
|
||||
if ($key =~ /^([^_]*)_/) {
|
||||
$LANGUAGE->{$key} = $var;
|
||||
++$need_save;
|
||||
}
|
||||
else {
|
||||
$message = GList::language('TPL_LANG_INVALID');
|
||||
}
|
||||
}
|
||||
elsif ($cgi->{'new-val'}) {
|
||||
$message = GList::language('TPL_LANG_ERROR');
|
||||
}
|
||||
|
||||
if ($need_save) {
|
||||
$LANGUAGE->save();
|
||||
$LANGUAGE = undef; # Force a reload to catch inherited values
|
||||
$message = GList::language('TPL_LANG_SAVED');
|
||||
$tags->{'new-val'} = '';
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $prefix = $cgi->{'prefix'};
|
||||
my %prefix_list;
|
||||
foreach my $code (sort keys %$LANGUAGE) {
|
||||
if ($code =~ /^([^_]*)_/) {
|
||||
$prefix_list{$1}++;
|
||||
}
|
||||
next if $prefix and $code !~ /^$prefix\_/;
|
||||
my $lang = $IN->html_escape($LANGUAGE->{$code});
|
||||
$table .= <<HTML;
|
||||
<tr>
|
||||
<td valign=top><font $font>$code</font></td>
|
||||
<td>
|
||||
<textarea rows="5" cols="50" name="save-$code" class="object">$lang</textarea>
|
||||
</td>
|
||||
<td><input type=checkbox name="del-$code" value="1" /></td>
|
||||
</tr>
|
||||
HTML
|
||||
}
|
||||
my $prefix_output = join " | ",
|
||||
map qq'<a href="$CFG->{cgi_url}/glist.cgi?do=admin_page;pg=admin_template_language.html;prefix=$_;tpl_dir=$selected_dir"><nobr>$_ ($prefix_list{$_})</nobr></a>',
|
||||
sort keys %prefix_list;
|
||||
|
||||
my $d_select_list = _template_dir_select();
|
||||
|
||||
return {
|
||||
language_table => $table,
|
||||
prefix => $prefix,
|
||||
dir_select => $d_select_list,
|
||||
message => $message,
|
||||
prefix_list => $prefix_output
|
||||
};
|
||||
}
|
||||
|
||||
sub global_editor {
|
||||
# ------------------------------------------------------------------
|
||||
# Loads the global template vars.
|
||||
#
|
||||
my $tags = GT::Template->tags;
|
||||
my ($dir, $font, $file, $message, $table);
|
||||
my $cgi = $IN->get_hash();
|
||||
|
||||
my $selected_dir = $cgi->{tpl_dir} || $CFG->{template_set} || 'gossamer';
|
||||
$dir = $CFG->{priv_path} . "/templates/common";
|
||||
|
||||
GList::load_globals(1);
|
||||
|
||||
my $demo;
|
||||
#------------demo code-----------
|
||||
|
||||
if ($cgi->{save}) {
|
||||
if ($demo) {
|
||||
$message = '<font color="red">The global editor has been disabled in the demo!</font>';
|
||||
}
|
||||
else {
|
||||
my $need_save;
|
||||
foreach my $code (keys %$cgi) {
|
||||
if ($code =~ /^del-(.*)$/) {
|
||||
delete $GLOBALS->{$1};
|
||||
++$need_save;
|
||||
}
|
||||
elsif ($code =~ /^save-(.*)/) {
|
||||
my $key = $1;
|
||||
next if $cgi->{"del-$key"};
|
||||
my $var = $cgi->{$code};
|
||||
$var =~ s/\r\n/\n/g; # Remove windows linefeeds.
|
||||
next if exists $GLOBALS->{$key} and $GLOBALS->{$key} eq $var;
|
||||
$GLOBALS->{$key} = $var;
|
||||
++$need_save;
|
||||
}
|
||||
}
|
||||
|
||||
if (my $key = $cgi->{new} and my $var = $cgi->{'new-val'}) {
|
||||
$var =~ s/\r\n/\n/g;
|
||||
$GLOBALS->{$key} = $var;
|
||||
++$need_save;
|
||||
}
|
||||
elsif ($cgi->{'new-val'}) {
|
||||
$message = GList::language('TPL_GLOBAL_ERROR');
|
||||
}
|
||||
|
||||
if ($need_save) {
|
||||
$GLOBALS->save();
|
||||
$GLOBALS = undef; # Force a reload, to catch inherited/local values
|
||||
GList::load_globals(1);
|
||||
$message = GList::language('TPL_GLOBAL_SAVED');
|
||||
$tags->{'new-val'} = '';
|
||||
}
|
||||
}
|
||||
}
|
||||
for my $code (sort keys %$GLOBALS) {
|
||||
my $val = $IN->html_escape($GLOBALS->{$code});
|
||||
$table .= <<HTML;
|
||||
<tr>
|
||||
<td valign="top" class="body">$code</td>
|
||||
<td>
|
||||
<textarea rows="5" cols="50" name="save-$code" wrap="off" class="object">$val</textarea>
|
||||
</td>
|
||||
<td><input type="checkbox" name="del-$code" value="1"></td>
|
||||
</tr>
|
||||
HTML
|
||||
}
|
||||
return { global_table => $table, message => $message };
|
||||
}
|
||||
|
||||
sub convert_date {
|
||||
#----------------------------------------------------------------------
|
||||
my $time = shift or return GList::language('ADMNEVER_LOGIN');
|
||||
my $format = "%mm%-%dd%-%yyyy% %hh%:%MM%:%ss%";
|
||||
|
||||
require GT::Date;
|
||||
return GT::Date::date_get($time, $format);
|
||||
}
|
||||
|
||||
sub friendly_size {
|
||||
my $size = shift;
|
||||
return $size <= 100
|
||||
? "$size " . GList::language('FILESIZE_BYTES')
|
||||
: $size < 10 * KB
|
||||
? sprintf("%.2f ", $size / KB) . GList::language('FILESIZE_KILOBYTES')
|
||||
: $size < 100 * KB
|
||||
? sprintf("%.1f ", $size / KB) . GList::language('FILESIZE_KILOBYTES')
|
||||
: $size < MB
|
||||
? sprintf("%.0f ", $size / KB) . GList::language('FILESIZE_KILOBYTES')
|
||||
: $size < 10 * MB
|
||||
? sprintf("%.2f ", $size / MB) . GList::language('FILESIZE_MEGABYTES')
|
||||
: $size < 100 * MB
|
||||
? sprintf("%.1f ", $size / MB) . GList::language('FILESIZE_MEGABYTES')
|
||||
: sprintf("%.0f ", $size / MB) . GList::language('FILESIZE_MEGABYTES');
|
||||
}
|
||||
|
||||
sub list_title {
|
||||
my $list_id = shift;
|
||||
return if (!$list_id);
|
||||
|
||||
my $info = $DB->table('Lists')->get($list_id);
|
||||
return $info->{lst_title};
|
||||
}
|
||||
|
||||
sub _editor_obj {
|
||||
my ($name, $skip) = @_;
|
||||
$skip ||= [qw/CVS safe help/];
|
||||
require GT::Template::Editor;
|
||||
my $demo = 0;
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
GT::Template::Editor->new(
|
||||
root => "$CFG->{priv_path}/templates",
|
||||
backup => $CFG->{template_backups},
|
||||
cgi => $IN,
|
||||
demo => $demo,
|
||||
class => "object",
|
||||
default_dir => $CFG->{template_set} || 'gossamer',
|
||||
skip_dir => $skip,
|
||||
skip_file => [qw/*.eml/],
|
||||
$name ? (select_dir => $name) : ()
|
||||
);
|
||||
}
|
||||
|
||||
sub _template_dir_select {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a select list of template directories.
|
||||
#
|
||||
my $name = shift;
|
||||
_editor_obj($name, [qw/CVS help safe common/])->template_dir_select;
|
||||
}
|
||||
|
||||
sub _current_select {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a select list of user email templates
|
||||
#
|
||||
my ($name, $selected_file) = @_;
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my $sth = $DB->table('EmailTemplates')->select({ tpl_user_id_fk => $tags->{usr_username} }, ['tpl_name']);
|
||||
return if ( !$sth->rows );
|
||||
$selected_file ||= $tags->{$name};
|
||||
|
||||
my $f_select_list = "<select name='$name' class=object><option value=''>".GList::language('TPL_SELECT_TITLE')."</option>";
|
||||
while ( my $name = $sth->fetchrow_array ) {
|
||||
( $selected_file eq $name ) ? ($f_select_list .= "<option selected>$name") : ($f_select_list .= "<option>$name");
|
||||
}
|
||||
|
||||
return "$f_select_list</select>";
|
||||
}
|
||||
|
||||
sub _default_select {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a select list of email templates in a given dir.
|
||||
#
|
||||
my ( $dir, $selected_file ) = @_;
|
||||
|
||||
my ($file, @files);
|
||||
opendir (TPL, $dir) or die GList::language('DIR_OPEN_ERR', $dir, $!);
|
||||
|
||||
while (defined($file = readdir TPL)) {
|
||||
my ($ext) = $file =~ /\.([^.]+)$/;
|
||||
next unless $ext and $ext eq 'eml';
|
||||
push @files, $file;
|
||||
}
|
||||
closedir TPL;
|
||||
|
||||
my $f_select_list = "<select name='tpl_file' class=object><option value=''>".GList::language('TPL_SELECT_TITLE')."</option>";
|
||||
my $count = 0;
|
||||
foreach (sort @files) {
|
||||
$selected_file = $_ if (!$selected_file and !$count);
|
||||
($selected_file eq $_) ? ($f_select_list .= "<option selected>$_</option>") : ($f_select_list .= "<option>$_</option>");
|
||||
}
|
||||
$f_select_list .= "</select>";
|
||||
|
||||
return ($f_select_list, $selected_file);
|
||||
}
|
||||
|
||||
sub schedule_status {
|
||||
my $tags = GT::Template->tags;
|
||||
my ($scm_id, $scm_sent, $scm_type) = ($tags->{scm_id}, $tags->{scm_sent}, $tags->{scm_type});
|
||||
|
||||
my $schedule = $DB->table('ScheduledMailings')->get({ scm_id => $scm_id });
|
||||
return unless $schedule;
|
||||
return unless $scm_sent;
|
||||
|
||||
require GT::Date;
|
||||
if ($scm_type == 2) {
|
||||
return 1 if GT::Date::date_get(time, "%yyyy%-%mm%-%dd%") eq GT::Date::date_get($scm_sent, "%yyyy%-%mm%-%dd%");
|
||||
}
|
||||
elsif ($scm_type == 3) {
|
||||
my $today = GT::Date::date_get(time, "%yyyy%-%mm%-%dd%");
|
||||
my $next_7days = GT::Date::date_add(GT::Date::date_get($scm_sent, "%yyyy%-%mm%-%dd%"), 7);
|
||||
return GT::Date::date_is_greater($next_7days, $today);
|
||||
}
|
||||
elsif ($scm_type == 4) {
|
||||
return 1 if GT::Date::date_get(time, "%mm%") eq GT::Date::date_get($scm_sent, "%mm%");
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub schedule_info {
|
||||
my $mli_id = shift;
|
||||
|
||||
return unless $mli_id;
|
||||
my $info = $DB->table('ScheduledMailings')->get({ scm_mailing_id_fk => $mli_id });
|
||||
if ($info->{scm_type} == 1) {
|
||||
require GT::Date;
|
||||
my $format = $USER->{usr_date_format} || '%yyyy%-%mm%-%dd%';
|
||||
$info->{scm_option} = GT::Date::date_get($info->{scm_option}, $format);
|
||||
}
|
||||
return $info;
|
||||
}
|
||||
1;
|
||||
879
site/glist/lib/GList/User.pm
Normal file
879
site/glist/lib/GList/User.pm
Normal file
@@ -0,0 +1,879 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: User.pm,v 1.49 2004/10/14 22:57:54 bao 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 GList::User;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use GList qw/:objects :user_type $DEBUG/;
|
||||
use GT::AutoLoader;
|
||||
|
||||
sub process {
|
||||
#-------------------------------------------------------------------
|
||||
# Determine what to do
|
||||
#
|
||||
my $do = shift;
|
||||
|
||||
my $action = _determine_action($do) or die "Error: Invalid Action! ($do)";
|
||||
|
||||
my ($tpl, $results) = GT::Plugins->dispatch($CFG->{priv_path}.'/lib/GList/Plugins', $action, \&$action);
|
||||
$tpl ||= 'user_login.html';
|
||||
GList::display($tpl, $results);
|
||||
}
|
||||
|
||||
$COMPILE{user_click} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_click {
|
||||
#--------------------------------------------------------------------
|
||||
# Track number of clicks
|
||||
#
|
||||
my $id = $IN->param('mailing');
|
||||
my $url = $IN->param('url') || "$CFG->{cgi_url}/glist.cgi";
|
||||
my $db = $DB->table('MailingIndex');
|
||||
if ($db->count({ mli_id => $id })) {
|
||||
$db->update({ mli_num_clicked => \'mli_num_clicked + 1' }, { mli_id => $id });
|
||||
}
|
||||
print $IN->header( -url => $url );
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_open} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_open {
|
||||
#--------------------------------------------------------------------
|
||||
# Track number of users who open message
|
||||
#
|
||||
my $code = $IN->param('eml_code');
|
||||
my $mailing = $IN->param('mailing');
|
||||
my $db = $DB->table('EmailMailings');
|
||||
if ($code and $mailing and $db->count({ eml_mailing_id_fk => $mailing, eml_code => $code, eml_opened => 0 })) {
|
||||
$db->update({ eml_opened => time }, { eml_mailing_id_fk => $mailing, eml_code => $code });
|
||||
$DB->table('MailingIndex')->update({ mli_num_opened => \'mli_num_opened + 1' }, { mli_id => $mailing });
|
||||
}
|
||||
if (open DATA, "$CFG->{image_path}/pics/1pixel.gif") {
|
||||
print $IN->header({
|
||||
'-type' => 'image/gif',
|
||||
'-Content-Length' => -s "$CFG->{image_path}/pics/1pixel.gif",
|
||||
});
|
||||
binmode STDOUT;
|
||||
binmode DATA;
|
||||
my $buffer;
|
||||
print $buffer while (read(DATA, $buffer, 50000));
|
||||
close DATA;
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_signup} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_signup {
|
||||
# -------------------------------------------------------------------
|
||||
# User Sign-up
|
||||
#
|
||||
return ('user_login.html', { msg => GList::language('USR_SIGNUP_DISABLE') }) if (!$CFG->{signup_enable});
|
||||
|
||||
return ('user_signup.html') if ($IN->param('form'));
|
||||
|
||||
my $cgi = $IN->get_hash();
|
||||
|
||||
my $error = _signup_check($cgi);
|
||||
return ('user_signup.html', { msg => $error }) if ($error);
|
||||
|
||||
$cgi->{usr_password} = GList::encrypt($cgi->{usr_password});
|
||||
$cgi->{usr_date_format}||= "%yyyy%-%mm%-%dd%";
|
||||
$cgi->{usr_bounce_email} = $cgi->{usr_email};
|
||||
$cgi->{usr_reply_email} = $cgi->{usr_email};
|
||||
$cgi->{usr_limit_list} = $CFG->{signup_limit_list} || 10;
|
||||
$cgi->{usr_limit_sublist}= $CFG->{signup_limit_sublist} || 10;
|
||||
$cgi->{usr_limit_email30}= $CFG->{signup_limit_email30} || 100;
|
||||
$cgi->{usr_type} = (!$CFG->{signup_email_validate} and !$CFG->{signup_admin_validate}) ? LIMITED_USER : UNVALIDATED_USER;
|
||||
my $info = $cgi;
|
||||
|
||||
# if it requires email validate
|
||||
if ($CFG->{signup_email_validate}) {
|
||||
my $val_code = join '', ('a'..'z', 'A'..'Z', 0..9)[map rand(62), 1 .. 30];
|
||||
$cgi->{usr_validate_code} = "GT$val_code";
|
||||
$info->{validate_code} = $val_code;
|
||||
}
|
||||
|
||||
GList::add('Users', 'usr', $cgi);
|
||||
return ('user_signup.html', { msg => "<font color=red><b>$GList::error</b></font>" }) if ($GList::error);
|
||||
|
||||
# Send a validate email
|
||||
my $msg = GList::language('USR_SIGNUP_SUCCESSFUL');
|
||||
if ($CFG->{signup_email_validate}) {
|
||||
foreach (keys %{$CFG->{admin}}) {
|
||||
next if (!$_);
|
||||
$info->{admin_email} = $CFG->{admin}->{$_}->[1]; last;
|
||||
}
|
||||
|
||||
my ($head, $body) = _parse_file('account_validation.eml', $info);
|
||||
GList::send($head, { text => $body });
|
||||
$msg = GList::language('USR_SIGNUP_EMAIL_SUCCESSFUL');
|
||||
}
|
||||
return ('user_login.html', { msg => $msg });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_account_validate} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_account_validate {
|
||||
#----------------------------------------------------------
|
||||
# User validate
|
||||
#
|
||||
my $id = $IN->param('id');
|
||||
my $db = $DB->table('Users');
|
||||
my $found= $db->count({ usr_validate_code => $id });
|
||||
return ('user_login.html', { msg => GList::language('USR_VALIDATE_FAILED') }) unless ($found);
|
||||
|
||||
# if it requires admin validate
|
||||
my %hash = (usr_validate_code => '', usr_type => LIMITED_USER);
|
||||
if ($CFG->{signup_admin_validate}) {
|
||||
$hash{usr_type} = UNVALIDATED_USER;
|
||||
}
|
||||
$db->update(\%hash, { usr_validate_code => $id });
|
||||
return ('user_login.html', { msg => GList::language('USR_VALIDATE_SUCCESSFUL') });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_login} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_login {
|
||||
# --------------------------------------------------------
|
||||
# Logs a user in, and creates a session ID.
|
||||
#
|
||||
|
||||
if (!defined $IN->param('username') or !defined $IN->param('password')) {
|
||||
return ('user_login.html', { msg => GList::language('LOG_IN', GList::_load_global('site_title')) });
|
||||
}
|
||||
|
||||
my $username = $IN->param('username') || shift;
|
||||
my $password = $IN->param('password') || shift;
|
||||
|
||||
# Make sure we have both a username and password.
|
||||
return ('user_login.html', { msg => GList::language('LOG_ERROR') }) if (!$username or !$password);
|
||||
|
||||
unless (GList::test_connection()) { # Database connection is failed
|
||||
if (GList::Authenticate::auth('admin_valid_user', { username => $username, password => $password })) {
|
||||
my $session = GList::Authenticate::auth('admin_create_session', { username => $username });
|
||||
if ($session) {
|
||||
$USER->{admin_user} = $username;
|
||||
$USER->{admin_pass} = $password;
|
||||
$USER->{session_id} = $session->{session_id};
|
||||
$USER->{use_cookie} = $session->{use_cookie};
|
||||
require GList::Admin;
|
||||
return GList::Admin::admin_initial_sql();
|
||||
}
|
||||
}
|
||||
return ('user_login.html', { msg => GList::language('LOG_ERROR') });
|
||||
}
|
||||
|
||||
# Check that the user exists, and that the password is valid.
|
||||
my $user = GList::init_user($username, $password);
|
||||
return ('user_login.html', { msg => GList::language('LOG_DEACTIVATE') }) if ($user and $user == 1);
|
||||
return ('user_login.html', { msg => GList::language('LOG_NOT_EMAIL_VALIDATED') }) if ($user and $user == 2);
|
||||
return ('user_login.html', { msg => GList::language('LOG_NOT_ADMIN_VALIDATED') }) if ($user and $user == 3);
|
||||
return ('user_login.html', { msg => GList::language('LOG_ERROR') }) if (ref $user ne 'HASH');
|
||||
|
||||
# Store the session in either a cookie or url based.
|
||||
my $results = GList::Authenticate::auth('create_session', { username => $user->{usr_username} });
|
||||
|
||||
return ('user_login.html', { msg => "<font color=red><b>$results->{error}</b></font>" }) if ($results->{error});
|
||||
$USER->{session_id} = $results->{session_id};
|
||||
$USER->{use_cookie} = $results->{use_cookie};
|
||||
|
||||
_cleanup_files();
|
||||
|
||||
if ($USER->{usr_updated}) {
|
||||
$MN_SELECTED = 1;
|
||||
require GList::Message;
|
||||
return GList::Message::msg_home(GList::language('LOG_WELCOME', "$USER->{pro_first_name} $USER->{pro_last_name}"));
|
||||
}
|
||||
else {
|
||||
$MN_SELECTED = 5;
|
||||
require GList::Profile;
|
||||
return GList::Profile::pro_profile(GList::language('LOG_UPDATE_REMIND'));
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_logout} = <<'END_OF_SUB';
|
||||
sub user_logout {
|
||||
#-----------------------------------------------------------
|
||||
#
|
||||
require GList::Authenticate;
|
||||
GList::Authenticate::auth('delete_session');
|
||||
return ('user_login.html', { msg => GList::language('LOG_LOGGED_OFF', GList::_load_global('site_title')) });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_remind} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_remind {
|
||||
#---------------------------------------------------------
|
||||
# Send password to a user
|
||||
#
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
return ('user_remind_form.html') if (!defined $IN->param('email'));
|
||||
|
||||
my $email = $IN->param('email');
|
||||
return ('user_remind_form.html', { msg => GList::language('LOG_REM_ERROR') }) unless ($email);
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $user = $db->get({ usr_email => $email });
|
||||
return ('user_remind_form.html', { msg => GList::language('LOG_REM_NOT_FOUND') }) if (!$user);
|
||||
|
||||
# Get Administrator info
|
||||
my $info;
|
||||
my $admin = $db->get({ usr_type => LIMITED_USER });
|
||||
if ($admin) {
|
||||
$info->{admin_email} = $admin->{usr_email};
|
||||
}
|
||||
|
||||
my @letters = (0 .. 9, 'a' .. 'z', 'A' .. 'Z');
|
||||
my $temp = '';
|
||||
for (1 .. 6) { $temp .= $letters[rand @letters]; }
|
||||
my $temp_enc = GList::encrypt($temp);
|
||||
$db->update({ usr_password => $temp_enc }, { usr_username => $user->{usr_username} });
|
||||
|
||||
$info->{usr_username} = $user->{usr_username};
|
||||
$info->{usr_email} = $user->{usr_email};
|
||||
$info->{usr_password} = $temp;
|
||||
$info->{usr_name} = "$user->{pro_first_name} $user->{pro_last_name}";
|
||||
$info->{usr_name} ||= $user->{usr_username};
|
||||
|
||||
my ($head, $body) = _parse_file('remindme.eml', $info);
|
||||
GList::send($head, { text => $body });
|
||||
|
||||
return ('user_login.html', { msg => GList::language('LOG_REM_SUCCESS', $email) });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_validate} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_validate {
|
||||
#-----------------------------------------------------------
|
||||
# Validate a subscriber
|
||||
#
|
||||
|
||||
my $admin = $db->get({ usr_type => LIMITED_USER });
|
||||
if ($admin) {
|
||||
$info->{admin_email} = $admin->{usr_email};
|
||||
}
|
||||
|
||||
my @letters = (0 .. 9, 'a' .. 'z', 'A' .. 'Z');
|
||||
my $temp = '';
|
||||
for (1 .. 6) { $temp .= $letters[rand @letters]; }
|
||||
my $temp_enc = GList::encrypt($temp);
|
||||
$db->update({ usr_password => $temp_enc }, { usr_username => $user->{usr_username} });
|
||||
|
||||
$info->{usr_username} = $user->{usr_username};
|
||||
$info->{usr_email} = $user->{usr_email};
|
||||
$info->{usr_password} = $temp;
|
||||
$info->{usr_name} = "$user->{pro_first_name} $user->{pro_last_name}";
|
||||
$info->{usr_name} ||= $user->{usr_username};
|
||||
|
||||
my ($head, $body) = _parse_file('remindme.eml', $info);
|
||||
GList::send($head, { text => $body });
|
||||
|
||||
return ('user_login.html', { msg => GList::language('LOG_REM_SUCCESS', $email) });
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_validate} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_validate {
|
||||
#-----------------------------------------------------------
|
||||
# Validate a subscriber
|
||||
#
|
||||
|
||||
#------------demo code-----------
|
||||
|
||||
my $id = $IN->param('id');
|
||||
my $db = $DB->table('Subscribers');
|
||||
my $info = $db->get({ sub_val_code => $id });
|
||||
|
||||
return ('error_form.html', { msg => GList::language('LOG_VAL_ERROR') }) if (!$info);
|
||||
return ('error_form.html', { msg => GList::language('LOG_VAL_ERROR2') }) if ($info->{sub_validated});
|
||||
|
||||
$db->update({ sub_validated => '1' }, { sub_val_code => $id });
|
||||
|
||||
my $lst_info = $DB->table('Lists')->get($info->{sub_list_id_fk});
|
||||
return ('user_success_form.html', { msg => GList::language('LOG_VALIDATED') }) if (!$lst_info->{lst_url_validate_success});
|
||||
|
||||
print $IN->header( -url => $lst_info->{lst_url_validate_success} );
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_subscribe} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_subscribe {
|
||||
#-----------------------------------------------------------
|
||||
# Subscribe a email address
|
||||
#
|
||||
# get subscribe success URLs
|
||||
my $url_success = "$CFG->{static_url}/page/subscribe_success.html";
|
||||
my $url_failure = "$CFG->{static_url}/page/subscribe_failure.html";
|
||||
# get the hash for this CGI instance
|
||||
my $cgi = $IN->get_hash();
|
||||
my $demo = 0;
|
||||
# errors if we don't have an accurate list ID
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR') }) unless ($cgi->{lid});
|
||||
|
||||
#------------demo code-----------
|
||||
# $demo = 1;
|
||||
|
||||
# Get the relevant table lsits (Subscribers). StopLists is the unknown one--doesn't look like it's used anymore
|
||||
my $db_sub = $DB->table('Subscribers');
|
||||
my $db_stl = $DB->table('StopLists');
|
||||
my $wild_cards = GList::wild_cards();
|
||||
my $email;
|
||||
if ($cgi->{eml_code}) {
|
||||
my $eml = $DB->table('EmailMailings')->get({ eml_code => $cgi->{eml_code} });
|
||||
$email = lc $eml->{eml_email};
|
||||
}
|
||||
else {
|
||||
$email = lc $cgi->{email};
|
||||
}
|
||||
|
||||
# if there's an array of IDs, loop over them
|
||||
if (ref $cgi->{lid} eq 'ARRAY') {
|
||||
foreach my $id (@{$cgi->{lid}}) {
|
||||
my $info = $DB->table('Lists')->get($id);
|
||||
next unless ($info);
|
||||
|
||||
my $error = _check_subscriber($email, $id, $db_stl, $wild_cards);
|
||||
next if ($error);
|
||||
|
||||
# if it has been subscribed to the list
|
||||
next if ($db_sub->count({ sub_email => $email, sub_list_id_fk => $id }));
|
||||
|
||||
my ($template, $data) = _generate_info($info, $email, $cgi->{name});
|
||||
next unless ($data);
|
||||
|
||||
$db_sub->insert($data);
|
||||
if ($template and !$demo) { # sending a confirmation or validation email
|
||||
GList::send($template->{head}, { text => $template->{body} });
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $info = $DB->table('Lists')->get($cgi->{lid});
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR2', $cgi->{lid}, GList::_load_global('site_title')) }) if (!$info);
|
||||
|
||||
$url_success = $info->{lst_url_subscribe_success} if ($info->{lst_url_subscribe_success});
|
||||
$url_failure = $info->{lst_url_subscribe_failure} if ($info->{lst_url_subscribe_failure});
|
||||
my $error = _check_subscriber($email, $info->{lst_id}, $db_stl, $wild_cards);
|
||||
return ('error_form.html', { msg => $error }) if ($error);
|
||||
|
||||
# if it has been subscribed to the list
|
||||
if ($db_sub->count({ sub_email => $email, sub_list_id_fk => $cgi->{lid} })) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
my ($template, $data) = _generate_info($info, $email, $cgi->{name});
|
||||
unless ($data) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
$db_sub->insert($data);
|
||||
|
||||
if ($template and !$demo) { # sending a confirmation or validation email
|
||||
GList::send($template->{head}, { text => $template->{body} });
|
||||
}
|
||||
}
|
||||
|
||||
print $IN->header( -url => $url_success );
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_rm} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_rm {
|
||||
user_unsubscribe();
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_unsubscribe} = __LINE__ . <<'END_OF_SUB';
|
||||
sub user_unsubscribe {
|
||||
#-----------------------------------------------------------
|
||||
# Unsubscribe a email address
|
||||
#
|
||||
my $url_success = "$CFG->{static_url}/page/unsubscribe_success.html";
|
||||
my $url_failure = "$CFG->{static_url}/page/unsubscribe_failure.html";
|
||||
|
||||
my ($info, $email);
|
||||
# Gets hash from $IN? -> Global variable that's defined as what? I think it's the whole query parameter
|
||||
my $cgi = $IN->get_hash();
|
||||
# Get subscribers table -> We'll need this
|
||||
my $db_sub = $DB->table('Subscribers');
|
||||
# If lid is an array, return it as such, otherwise return the single array as an array
|
||||
my $lists = (ref $cgi->{lid} eq 'ARRAY') ? $cgi->{lid} : [$cgi->{lid}];
|
||||
# if this $cgi global has an eml_code (it should if cliked from a link)
|
||||
if ($cgi->{eml_code}) {
|
||||
# Get the e-mail Mailings table and then get the EML_CODE equal to this one
|
||||
# eml_code is equal to the hash that's sent -> Can use this again
|
||||
my $eml = $DB->table('EmailMailings')->get({ eml_code => $cgi->{eml_code} });
|
||||
# From the eml-code (hash), get the actual e-maile lowercased (this is probably a row)
|
||||
$email = lc $eml->{eml_email};
|
||||
}
|
||||
else {
|
||||
# Otherwise if not clicked from this, we're just going to try to get the e-mail from this instance
|
||||
$email = lc $cgi->{email};
|
||||
}
|
||||
|
||||
# If we don't have an e-mail, go to the failure url
|
||||
if (!$email or $#$lists < 0) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
# This looks like it gets at the meat
|
||||
|
||||
# make sure we have our SQL condition command
|
||||
require GT::SQL::Condition;
|
||||
|
||||
# Look/create new for sub_email with e-mail
|
||||
my $cd = GT::SQL::Condition->new(sub_email => '=' => $email);
|
||||
|
||||
# if we only have one entry in our list
|
||||
if ($#$lists == 0) {
|
||||
# From "Lists" get our value
|
||||
$info = $DB->table('Lists')->get($lists->[0]);
|
||||
# if no results, return an error
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR2', $lists->[0]) }) if (!$info);
|
||||
|
||||
# depending on $info, go to success/failure ($info dpeendent failure/success)
|
||||
$url_success = $info->{lst_url_unsubscribe_success} if ($info->{lst_url_unsubscribe_success});
|
||||
$url_failure = $info->{lst_url_unsubscribe_failure} if ($info->{lst_url_unsubscribe_failure});
|
||||
|
||||
# to our foreign key list add this e-mail
|
||||
$cd->add(sub_list_id_fk => '=' => $lists->[0]);
|
||||
}
|
||||
else {
|
||||
# same thing as above, just do it if we have any in the list
|
||||
$cd->add(sub_list_id_fk => 'IN' => $lists);
|
||||
}
|
||||
|
||||
# if we didn't do any adding, go to the failure
|
||||
if (!$db_sub->count($cd)) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
# looks like this is in testing
|
||||
#------------demo code-----------
|
||||
# return ('user_success_form.html', { msg => GList::language('LOG_UNSUBS_SUCCESS', $info->{lst_title}) });
|
||||
|
||||
# from "Subscribers", delete this added unsubscription
|
||||
if ($db_sub->delete($cd)) {
|
||||
# from our #info get the unsubscribe tempalte
|
||||
if ($info->{lst_unsubs_template}) {
|
||||
# get the e-mail from this info and lowercase and send
|
||||
$info->{sub_email} = lc $cgi->{email};
|
||||
# now parse and unsubscribe
|
||||
my $unsubs_template = _parse($info, $info->{lst_unsubs_template});
|
||||
# from template, send the header/body of the unsubscription
|
||||
GList::send($unsubs_template->{head}, { text => $unsubs_template->{body} });
|
||||
}
|
||||
}
|
||||
# go to success
|
||||
print $IN->header( -url => $url_success );
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{user_move} = __LINE__ . << 'END_OF_SUB';
|
||||
sub user_move {
|
||||
#-----------------------------------------------------------
|
||||
# Remove a subscription and then create a new one
|
||||
#
|
||||
#----------------------------------
|
||||
# First, let's get the list information we're moving
|
||||
#----------------------------------
|
||||
my $cgi = $IN->get_hash();
|
||||
my @values = split('-', $cgi->{from_to_lid});
|
||||
my $element_count = scalar(@values);
|
||||
|
||||
# If invalid params, return an error
|
||||
return ('error_form.html', { msg => GList::language('LOG_ERROR') }) unless ($element_count == 2);
|
||||
|
||||
my $unsub = $values[0];
|
||||
my $sub = $values[1];
|
||||
|
||||
#----------------------------------
|
||||
# Prepare the unsubscription and do so
|
||||
#----------------------------------
|
||||
$cgi->{lid} = $unsub;
|
||||
|
||||
my $url_success = "$CFG->{static_url}/page/unsubscribe_success.html";
|
||||
my $url_failure = "$CFG->{static_url}/page/unsubscribe_failure.html";
|
||||
|
||||
my ($info, $email);
|
||||
my $db_sub = $DB->table('Subscribers');
|
||||
my $lists = (ref $cgi->{lid} eq 'ARRAY') ? $cgi->{lid} : [$cgi->{lid}];
|
||||
if ($cgi->{eml_code}) {
|
||||
my $eml = $DB->table('EmailMailings')->get({ eml_code => $cgi->{eml_code} });
|
||||
$email = lc $eml->{eml_email};
|
||||
}
|
||||
else {
|
||||
$email = lc $cgi->{email};
|
||||
}
|
||||
|
||||
# If we don't have an e-mail, go to the failure url
|
||||
if (!$email or $#$lists < 0) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
require GT::SQL::Condition;
|
||||
|
||||
# Look/create new for sub_email with e-mail
|
||||
my $cd = GT::SQL::Condition->new(sub_email => '=' => $email);
|
||||
|
||||
# if we only have one entry in our list
|
||||
if ($#$lists == 0) {
|
||||
$info = $DB->table('Lists')->get($lists->[0]);
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR2', $lists->[0]) }) if (!$info);
|
||||
|
||||
$url_success = $info->{lst_url_unsubscribe_success} if ($info->{lst_url_unsubscribe_success});
|
||||
$url_failure = $info->{lst_url_unsubscribe_failure} if ($info->{lst_url_unsubscribe_failure});
|
||||
|
||||
$cd->add(sub_list_id_fk => '=' => $lists->[0]);
|
||||
}
|
||||
else {
|
||||
$cd->add(sub_list_id_fk => 'IN' => $lists);
|
||||
}
|
||||
|
||||
if (!$db_sub->count($cd)) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
# Remove them from this list
|
||||
my $unsubs_template;
|
||||
if ($db_sub->delete($cd)) {
|
||||
# from our #info get the unsubscribe tempalte
|
||||
if ($info->{lst_unsubs_template}) {
|
||||
# get the e-mail from this info and lowercase and send
|
||||
$info->{sub_email} = lc $cgi->{email};
|
||||
# now parse and unsubscribe
|
||||
$unsubs_template = _parse($info, $info->{lst_unsubs_template});
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------
|
||||
# Success means we proceed with the subscription
|
||||
#----------------------------------
|
||||
|
||||
# Prepare the subscription and so so
|
||||
$cgi->{lid} = $sub;
|
||||
|
||||
# get subscribe success URLs
|
||||
$url_success = "$CFG->{static_url}/page/subscribe_success.html";
|
||||
$url_failure = "$CFG->{static_url}/page/subscribe_failure.html";
|
||||
my $demo = 0;
|
||||
# errors if we don't have an accurate list ID
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR') }) unless ($cgi->{lid});
|
||||
|
||||
# Get the relevant table lsits (Subscribers). StopLists is the unknown one--doesn't look like it's used anymore
|
||||
my $db_stl = $DB->table('StopLists');
|
||||
my $wild_cards = GList::wild_cards();
|
||||
|
||||
# if there's an array of IDs, loop over them
|
||||
if (ref $cgi->{lid} eq 'ARRAY') {
|
||||
foreach my $id (@{$cgi->{lid}}) {
|
||||
$info = $DB->table('Lists')->get($id);
|
||||
next unless ($info);
|
||||
|
||||
my $error = _check_subscriber($email, $id, $db_stl, $wild_cards);
|
||||
next if ($error);
|
||||
|
||||
# if it has been subscribed to the list
|
||||
next if ($db_sub->count({ sub_email => $email, sub_list_id_fk => $id }));
|
||||
|
||||
my ($template, $data) = _generate_info($info, $email, $cgi->{name});
|
||||
next unless ($data);
|
||||
|
||||
$db_sub->insert($data);
|
||||
if ($template and !$demo) { # sending a confirmation or validation email
|
||||
GList::send($template->{head}, { text => $template->{body} });
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$info = $DB->table('Lists')->get($cgi->{lid});
|
||||
return ('error_form.html', { msg => GList::language('LOG_SUBSCRIBE_ERROR2', $cgi->{lid}, GList::_load_global('site_title')) }) if (!$info);
|
||||
|
||||
$url_success = $info->{lst_url_subscribe_success} if ($info->{lst_url_subscribe_success});
|
||||
$url_failure = $info->{lst_url_subscribe_failure} if ($info->{lst_url_subscribe_failure});
|
||||
my $error = _check_subscriber($email, $info->{lst_id}, $db_stl, $wild_cards);
|
||||
return ('error_form.html', { msg => $error }) if ($error);
|
||||
|
||||
# if it has been subscribed to the list
|
||||
if ($db_sub->count({ sub_email => $email, sub_list_id_fk => $cgi->{lid} })) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
|
||||
my ($template, $data) = _generate_info($info, $email, $cgi->{name});
|
||||
unless ($data) {
|
||||
print $IN->header( -url => $url_failure );
|
||||
return;
|
||||
}
|
||||
$db_sub->insert($data);
|
||||
|
||||
if ($template and !$demo) { # sending a confirmation or validation email
|
||||
GList::send($template->{head}, { text => $template->{body} });
|
||||
}
|
||||
}
|
||||
|
||||
if ($unsubs_template) {
|
||||
# from template, send the header/body of the unsubscription
|
||||
GList::send($unsubs_template->{head}, { text => $unsubs_template->{body} });
|
||||
}
|
||||
|
||||
print $IN->header( -url => $url_success );
|
||||
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_generate_info} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _generate_info {
|
||||
my ($info, $email, $name) = @_;
|
||||
my %data = ( sub_email => $email, sub_name => $name, sub_created => time, sub_list_id_fk => $info->{lst_id}, sub_user_id_fk => $info->{lst_user_id_fk} );
|
||||
$info->{sub_email} = $email;
|
||||
$info->{sub_name} = $name;
|
||||
|
||||
my $template;
|
||||
if ($info->{lst_opt}) {
|
||||
my $val_code = join '', ('a'..'z', 'A'..'Z', 0..9)[map rand(62), 1 .. 30];
|
||||
$data{sub_validated} = '0';
|
||||
$data{sub_val_code} = "GT$val_code";
|
||||
$info->{validate_code} = $val_code;
|
||||
$template = _parse($info, $info->{lst_opt_template});
|
||||
}
|
||||
elsif ($info->{lst_subs_template}) {
|
||||
$template = _parse($info, $info->{lst_subs_template});
|
||||
}
|
||||
return ($template, \%data);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_signup_check} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _signup_check {
|
||||
#-------------------------------------------------------------------
|
||||
#
|
||||
my $data = shift;
|
||||
|
||||
my $db = $DB->table('Users');
|
||||
my $refix = $CFG->{signup_username_regex} || '^[\w\-\.]{3,}$';
|
||||
|
||||
length $data->{usr_username} < 3 and return GList::language('USR_SIGNUP_USERNAME_INVALID');
|
||||
$data->{usr_username} =~ /$refix/ or return GList::language('USR_INVALID');
|
||||
$db->count({ usr_username => $data->{usr_username} }) and return GList::language('USR_SIGNUP_USERNAME_TAKEN');
|
||||
length $data->{usr_password} < 4 and return GList::language('ADM_PWD_INVALID');
|
||||
$data->{usr_password} ne $data->{con_password} and return GList::language('USR_SIGNUP_CONFIRM_PASS');
|
||||
$data->{usr_email} =~ /.@\S+\.\S+$/ or return GList::language('USR_SIGNUP_EMAIL_INVALID', $data->{usr_email});
|
||||
$db->count({ usr_email => $data->{usr_email} }) and return GList::language('USR_SIGNUP_EMAIL_INUSE', $data->{usr_email});
|
||||
|
||||
if ($CFG->{signup_restricted_email} and ref $CFG->{signup_restricted_email} eq 'ARRAY') {
|
||||
foreach my $e (@{$CFG->{signup_restricted_email}}) {
|
||||
$data->{usr_email} eq $e and return GList::language('USR_SIGNUP_EMAIL_RESTRICTED', $data->{usr_email});
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_check_subscriber} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _check_subscriber {
|
||||
#-----------------------------------------------------------------
|
||||
#
|
||||
my ($email, $lst_id, $db_stl, $wild_cards) = @_;
|
||||
|
||||
# trim blank spaces
|
||||
if ($email) {
|
||||
$email =~ s,^\s+,,g;
|
||||
$email =~ s,\s+$,,g;
|
||||
}
|
||||
|
||||
return GList::language('USR_SUB_OVERLIMIT') if (GList::check_limit('sublist', $lst_id));
|
||||
return GList::language('USR_SUB_INVALID_EMAIL') if ($email !~ /^(?:(?:.+\@.+\..+)|\s*)$/ or $email =~ /\s/ );
|
||||
return GList::language('USR_SUB_STOPLIST') if ($db_stl->count({ stl_email => $email }));
|
||||
foreach (@$wild_cards) {
|
||||
my $e = $_->[0];
|
||||
my $re = quotemeta $e;
|
||||
$re =~ s/\\\*/.*/;
|
||||
$re =~ s/\\\?/./;
|
||||
return GList::language('USR_SUB_STOPLIST') if ($email =~ /$re/i);
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_parse} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _parse {
|
||||
#-----------------------------------------------------------
|
||||
# Load email template
|
||||
#
|
||||
my ($info, $name) = @_;
|
||||
|
||||
require GList::Template;
|
||||
my $db = $DB->table('EmailTemplates');
|
||||
my $template = $db->get({ tpl_user_id_fk => $info->{lst_user_id_fk}, tpl_name => $name });
|
||||
return if (!$template);
|
||||
|
||||
my $sth = $DB->table('Users')->select({ usr_username => $info->{lst_user_id_fk} });
|
||||
return unless $sth;
|
||||
|
||||
my $uinfo = $sth->fetchrow_hashref;
|
||||
@{$info}{keys %$uinfo} = (values %$uinfo);
|
||||
|
||||
foreach (keys %$template) {
|
||||
$template->{$_} = GList::Template->parse(
|
||||
"string",
|
||||
[$info],
|
||||
{
|
||||
string => $template->{$_},
|
||||
disable => { functions => 1 }
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
my $headers;
|
||||
if ($template->{tpl_extra}) {
|
||||
for (split /\s*\n\s*/, $template->{tpl_extra}) { # This will weed out any blank lines
|
||||
my ($key, $value) = split /\s*:\s*/, $_, 2;
|
||||
$headers->{$key} = $value if $key and $value;
|
||||
}
|
||||
}
|
||||
$headers->{From} = $template->{tpl_from};
|
||||
$headers->{To} = $template->{tpl_to};
|
||||
$headers->{Subject} = $template->{tpl_subject};
|
||||
|
||||
return { body => $template->{tpl_body}, head => $headers };
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_parse_file} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _parse_file {
|
||||
my ($file, $info) = @_;
|
||||
require GT::Mail::Editor;
|
||||
require GList::Template;
|
||||
|
||||
my $tpl = GT::Mail::Editor->new( dir => "$CFG->{priv_path}/templates", template => $CFG->{template_set} );
|
||||
$tpl->load($file);
|
||||
|
||||
my %head;
|
||||
my $headers = $tpl->headers;
|
||||
while (my ($k, $v) = each %$headers) {
|
||||
my $val = $v;
|
||||
$val = GList::Template->parse(
|
||||
"string",
|
||||
[$info],
|
||||
{
|
||||
string => $val,
|
||||
disable => { functions => 1 }
|
||||
}
|
||||
);
|
||||
$head{$k} = $val;
|
||||
}
|
||||
my $body = GList::Template->parse(
|
||||
"string",
|
||||
[$info],
|
||||
{
|
||||
string => $tpl->{body},
|
||||
disable => { functions => 1 }
|
||||
}
|
||||
);
|
||||
return (\%head, $body);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_cleanup_files} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _cleanup_files {
|
||||
#----------------------------------------------------------
|
||||
# Clear out old temporary attachments.
|
||||
#
|
||||
my $second = $CFG->{session_exp} * 3600 || 3600;
|
||||
opendir (DIR, "$CFG->{priv_path}/tmp") or die GList::language('DIR_OPEN_ERR', "$CFG->{priv_path}/tmp");
|
||||
my @files = readdir(DIR);
|
||||
closedir (DIR);
|
||||
foreach my $file (@files) {
|
||||
my $full_file = "$CFG->{priv_path}/tmp/$file";
|
||||
next if ( -d $full_file );
|
||||
|
||||
if ( (-M _) * 86400 > $second ) {
|
||||
$full_file =~ /(.*)/;
|
||||
$full_file = $1;
|
||||
unlink $full_file;
|
||||
}
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_todo} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _todo {
|
||||
#---------------------------------------------------------------------------
|
||||
#
|
||||
my $do = shift;
|
||||
my %actions = (
|
||||
user_open => 1,
|
||||
user_click => 1,
|
||||
user_signup => 1,
|
||||
user_remind => 1,
|
||||
user_validate => 1,
|
||||
user_subscribe => 1,
|
||||
user_rm => 1,
|
||||
user_unsubscribe=> 1,
|
||||
user_account_validate => 1,
|
||||
# add in account updating
|
||||
user_move => 1
|
||||
);
|
||||
if (exists $actions{$do}) {
|
||||
return 1;
|
||||
}
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{_determine_action} = __LINE__ . <<'END_OF_SUB';
|
||||
sub _determine_action {
|
||||
#----------------------------------------------------------------------------
|
||||
# Check valid action
|
||||
#
|
||||
my $action = shift || undef;
|
||||
return if ( !$action );
|
||||
return 'user_login' if ( !$USER and !_todo($action) );
|
||||
|
||||
my %valid = (
|
||||
map { $_ => 1 } qw(
|
||||
user_open
|
||||
user_click
|
||||
user_signup
|
||||
user_login
|
||||
user_logout
|
||||
user_remind
|
||||
user_validate
|
||||
user_subscribe
|
||||
user_rm
|
||||
user_unsubscribe
|
||||
user_account_validate
|
||||
# Add in ability to update account
|
||||
user_move
|
||||
)
|
||||
);
|
||||
exists $valid{$action} and return $action;
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
63
site/glist/lib/GList/mod_perl.pm
Normal file
63
site/glist/lib/GList/mod_perl.pm
Normal file
@@ -0,0 +1,63 @@
|
||||
# ==================================================================
|
||||
# Gossamer List - enhanced mailing list management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: mod_perl.pm,v 1.7 2004/09/13 23:12:25 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 GList::mod_perl;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use lib '/home/slowtwitch/glist/lib';
|
||||
|
||||
# If under mod_perl, we use Apache::DBI to cache connections.
|
||||
use GT::Base qw/MOD_PERL/;
|
||||
BEGIN {
|
||||
require Apache::DBI if MOD_PERL;
|
||||
print STDERR "\nPreloading Gossamer List modules into mod_perl:\n\t"
|
||||
}
|
||||
|
||||
use GList();
|
||||
BEGIN { print STDERR " ." }
|
||||
|
||||
# Preload commonly used GT libs.
|
||||
use GT::CGI();
|
||||
use GT::Template();
|
||||
use GT::Dumper();
|
||||
use GT::Date();
|
||||
use GT::Mail();
|
||||
BEGIN { print STDERR " ." }
|
||||
use GT::SQL();
|
||||
use GT::SQL::Relation();
|
||||
|
||||
# Preload GList modules.
|
||||
BEGIN { print STDERR " ." }
|
||||
use GList::Authenticate();
|
||||
use GList::Admin();
|
||||
use GList::List();
|
||||
use GList::Mailer();
|
||||
use GList::Message();
|
||||
BEGIN { print STDERR " ." }
|
||||
use GList::Profile();
|
||||
use GList::SQL();
|
||||
use GList::Template();
|
||||
use GList::Tools();
|
||||
use GList::User();
|
||||
|
||||
BEGIN { print STDERR " .\nAll modules loaded ok!\n" };
|
||||
|
||||
print STDERR "Compiling all functions ...";
|
||||
|
||||
GT::AutoLoader::compile_all();
|
||||
|
||||
print STDERR " All modules compiled and loaded ok!\n\n";
|
||||
|
||||
1;
|
||||
306
site/glist/lib/GT/AutoLoader.pm
Normal file
306
site/glist/lib/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
|
||||
949
site/glist/lib/GT/Base.pm
Normal file
949
site/glist/lib/GT/Base.pm
Normal file
@@ -0,0 +1,949 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Base
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Base.pm,v 1.132 2005/06/22 19:59:25 jagerman 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.132 $ =~ /(\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;
|
||||
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);
|
||||
if ($raw) {
|
||||
if (defined $ENV{REQUEST_METHOD}) {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
}
|
||||
else {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
}
|
||||
}
|
||||
elsif (defined $ENV{REQUEST_METHOD}) {
|
||||
print STDOUT "Content-type: text/html\n\n";
|
||||
$ls = '<br>';
|
||||
$spc = ' ';
|
||||
$fh = \*STDOUT;
|
||||
}
|
||||
else {
|
||||
$ls = "\n";
|
||||
$spc = ' ';
|
||||
$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 = 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.132 2005/06/22 19:59:25 jagerman Exp $
|
||||
|
||||
=cut
|
||||
838
site/glist/lib/GT/CGI.pm
Normal file
838
site/glist/lib/GT/CGI.pm
Normal file
@@ -0,0 +1,838 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI
|
||||
# Author : Aki Mimoto
|
||||
# CVS Info :
|
||||
# $Id: CGI.pm,v 1.145 2005/06/21 21:02:57 jagerman Exp $
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# Implements CGI.pm's CGI functionality, but faster.
|
||||
#
|
||||
|
||||
package GT::CGI;
|
||||
# ===============================================================
|
||||
use strict;
|
||||
use GT::Base(':persist'); # Imports MOD_PERL, SPEEDY and PERSIST
|
||||
use vars qw/@ISA $DEBUG $VERSION $ATTRIBS $ERRORS $PRINTED_HEAD $EOL
|
||||
$FORM_PARSED %PARAMS @PARAMS %COOKIES @EXPORT_OK %EXPORT_TAGS/;
|
||||
use GT::AutoLoader;
|
||||
require Exporter;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$DEBUG = 0;
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.145 $ =~ /(\d+)\.(\d+)/;
|
||||
$ATTRIBS = {
|
||||
nph => 0,
|
||||
p => ''
|
||||
};
|
||||
$ERRORS = {
|
||||
INVALIDCOOKIE => "Invalid cookie passed to header: %s",
|
||||
INVALIDDATE => "Date '%s' is not a valid date format.",
|
||||
};
|
||||
|
||||
$EOL = ($^O eq 'MSWin32') ? "\n" : "\015\012"; # IIS has problems with \015\012 on nph scripts.
|
||||
$PRINTED_HEAD = 0;
|
||||
$FORM_PARSED = 0;
|
||||
%PARAMS = ();
|
||||
@PARAMS = ();
|
||||
%COOKIES = ();
|
||||
@EXPORT_OK = qw/escape unescape html_escape html_unescape/;
|
||||
%EXPORT_TAGS = (
|
||||
escape => [qw/escape unescape html_escape html_unescape/]
|
||||
);
|
||||
|
||||
# Pre load our compiled if under mod_perl/speedy.
|
||||
if (PERSIST) {
|
||||
require GT::CGI::Cookie;
|
||||
require GT::CGI::MultiPart;
|
||||
require GT::CGI::Fh;
|
||||
}
|
||||
|
||||
sub load_data {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Loads the form information into PARAMS. Data comes from either a multipart
|
||||
# form, a GET Request, a POST request, or as arguments from command line.
|
||||
#
|
||||
my $self = shift;
|
||||
unless ($FORM_PARSED) {
|
||||
|
||||
# If we are under mod_perl we let mod_perl know that it should call reset_env
|
||||
# when a request is finished.
|
||||
GT::Base->register_persistent_cleanup(\&reset_env);
|
||||
|
||||
# Reset all the cache variables
|
||||
%PARAMS = @PARAMS = %COOKIES = ();
|
||||
|
||||
# Load form data.
|
||||
my $method = defined $ENV{REQUEST_METHOD} ? uc $ENV{REQUEST_METHOD} : '';
|
||||
my $content_length = defined $ENV{'CONTENT_LENGTH'} ? $ENV{'CONTENT_LENGTH'} : 0;
|
||||
|
||||
if ($method eq 'GET' or $method eq 'HEAD') {
|
||||
$self->parse_str(defined $ENV{QUERY_STRING} ? $ENV{QUERY_STRING} : '');
|
||||
}
|
||||
elsif ($method eq 'POST') {
|
||||
if ($content_length) {
|
||||
if ($ENV{CONTENT_TYPE} and $ENV{CONTENT_TYPE} =~ /^multipart/) {
|
||||
require GT::CGI::MultiPart;
|
||||
GT::CGI::MultiPart->parse($self);
|
||||
}
|
||||
else {
|
||||
read(STDIN, my $data, $content_length, 0);
|
||||
$data =~ s/\r?\n/&/g;
|
||||
$self->parse_str($data);
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $data = join "&", @ARGV;
|
||||
$self->parse_str($data);
|
||||
}
|
||||
|
||||
# Load cookies.
|
||||
if (defined $ENV{HTTP_COOKIE}) {
|
||||
for (split /;\s*/, $ENV{HTTP_COOKIE}) {
|
||||
/(.*)=(.*)/ or next;
|
||||
my ($key, $val) = (unescape($1), unescape($2));
|
||||
$val = [split '&', $val];
|
||||
$self->{cookies}->{$key} = $val;
|
||||
}
|
||||
}
|
||||
else {
|
||||
%{$self->{cookies}} = ();
|
||||
}
|
||||
|
||||
# Parse form buttons, allowing you to pass in name="foo=bar;a=b;c=d" as a name
|
||||
# tag in the form.
|
||||
for (keys %{$self->{params}}) {
|
||||
if (index($_, '=') >= 0) {
|
||||
next if substr($_, -2) eq '.y';
|
||||
(my $key = $_) =~ s/\.x$//;
|
||||
$self->parse_str($key);
|
||||
}
|
||||
}
|
||||
|
||||
# Save the data for caching
|
||||
while (my ($k, $v) = each %{$self->{params}}) {
|
||||
push @{$PARAMS{$k}}, @$v;
|
||||
}
|
||||
while (my ($k, $v) = each %{$self->{cookies}}) {
|
||||
push @{$COOKIES{$k}}, @$v;
|
||||
}
|
||||
@PARAMS = @{$self->{param_order} || []};
|
||||
|
||||
# Make sure the form is not parsed again during this request
|
||||
$FORM_PARSED = 1;
|
||||
}
|
||||
else { # Load the data from the cache
|
||||
while (my ($k, $v) = each %PARAMS) {
|
||||
push @{$self->{params}->{$k}}, @$v;
|
||||
}
|
||||
while (my ($k, $v) = each %COOKIES) {
|
||||
push @{$self->{cookies}->{$k}}, @$v;
|
||||
}
|
||||
$self->{param_order} = [@PARAMS];
|
||||
}
|
||||
|
||||
|
||||
$self->{data_loaded} = 1;
|
||||
}
|
||||
|
||||
sub class_new {
|
||||
# --------------------------------------------------------------------------------
|
||||
# Creates an object to be used for all class methods, this affects the global
|
||||
# cookies and params.
|
||||
#
|
||||
my $self = bless {} => shift;
|
||||
$self->load_data unless $self->{data_loaded};
|
||||
|
||||
$self->{cookies} = \%COOKIES;
|
||||
$self->{params} = \%PARAMS;
|
||||
$self->{param_order} = \@PARAMS;
|
||||
|
||||
for (keys %{$ATTRIBS}) { $self->{$_} = $ATTRIBS->{$_} }
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub reset_env {
|
||||
# --------------------------------------------------------------------------------
|
||||
# Reset the global environment.
|
||||
#
|
||||
%PARAMS = @PARAMS = %COOKIES = ();
|
||||
$PRINTED_HEAD = $FORM_PARSED = 0;
|
||||
1;
|
||||
}
|
||||
|
||||
sub init {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Called from GT::Base when a new object is created.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
# If we are passed a single argument, then we load our data from
|
||||
# the input.
|
||||
if (@_ == 1) {
|
||||
my $p = $_[0];
|
||||
if (ref $p eq 'GT::CGI') {
|
||||
$p = $p->query_string;
|
||||
}
|
||||
$self->parse_str($p ? "&$p" : "");
|
||||
if (defined $ENV{HTTP_COOKIE}) {
|
||||
for (split /;\s*/, $ENV{HTTP_COOKIE}) {
|
||||
/(.*)=(.*)/ or next;
|
||||
my ($key, $val) = (unescape($1), unescape($2));
|
||||
$val = [split '&', $val];
|
||||
$self->{cookies}->{$key} = $val;
|
||||
}
|
||||
}
|
||||
$self->{data_loaded} = 1;
|
||||
$FORM_PARSED = 1;
|
||||
}
|
||||
elsif (@_) {
|
||||
$self->set(@_);
|
||||
}
|
||||
return $self;
|
||||
}
|
||||
|
||||
$COMPILE{get_hash} = __LINE__ . <<'END_OF_SUB';
|
||||
sub get_hash {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Returns the parameters as a HASH, with multiple values becoming an array
|
||||
# reference.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my $join = defined $_[0] ? $_[0] : 0;
|
||||
|
||||
keys %{$self->{params}} or return {};
|
||||
|
||||
# Construct hash ref and return it
|
||||
my $opts = {};
|
||||
foreach (keys %{$self->{params}}) {
|
||||
my @vals = @{$self->{params}->{$_}};
|
||||
$opts->{$_} = @vals > 1 ? \@vals : $vals[0];
|
||||
}
|
||||
return $opts;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{delete} = __LINE__ . <<'END_OF_SUB';
|
||||
sub delete {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Remove an element from the parameters.
|
||||
#
|
||||
my ($self, $param) = @_;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my @ret;
|
||||
if (exists $self->{params}->{$param}) {
|
||||
@ret = @{delete $self->{params}->{$param}};
|
||||
for (my $i = 0; $i < @{$self->{param_order}}; $i++) {
|
||||
if ($self->{param_order}->[$i] eq $param) {
|
||||
splice @{$self->{param_order}}, $i, 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
return wantarray ? @ret : $ret[0];
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{cookie} = __LINE__ . <<'END_OF_SUB';
|
||||
sub cookie {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Creates a new cookie for the user, implemented just like CGI.pm.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
if (@_ == 0) { # Return keys.
|
||||
return keys %{$self->{cookies}};
|
||||
}
|
||||
elsif (@_ == 1) { # Return value of param passed in.
|
||||
my $param = shift;
|
||||
return unless defined $param and $self->{cookies}->{$param};
|
||||
return wantarray ? @{$self->{cookies}->{$param}} : $self->{cookies}->{$param}->[0];
|
||||
}
|
||||
elsif (@_ == 2) {
|
||||
require GT::CGI::Cookie;
|
||||
return GT::CGI::Cookie->new(-name => $_[0], -value => $_[1]);
|
||||
}
|
||||
elsif (@_ % 2 == 0) {
|
||||
my %data = @_;
|
||||
if (exists $data{'-value'}) {
|
||||
require GT::CGI::Cookie;
|
||||
return GT::CGI::Cookie->new(%data);
|
||||
}
|
||||
}
|
||||
$self->fatal("Invalid arguments to cookie()");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub param {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Mimick CGI's param function for get/set.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
if (@_ == 0) { # Return keys in the same order they were provided
|
||||
return @{$self->{param_order} || []};
|
||||
}
|
||||
elsif (@_ == 1) { # Return value of param passed in.
|
||||
my $param = shift;
|
||||
return unless (defined($param) and $self->{params}->{$param});
|
||||
return wantarray ? @{$self->{params}->{$param}} : $self->{params}->{$param}->[0];
|
||||
}
|
||||
else { # Set parameter.
|
||||
my ($param, $value) = @_;
|
||||
unless ($self->{params}->{$param}) {
|
||||
# If we're not replacing/changing a parameter, we need to add the param to param_order
|
||||
push @{$self->{param_order}}, $param;
|
||||
}
|
||||
$self->{params}->{$param} = [ref $value eq 'ARRAY' ? @$value : $value];
|
||||
}
|
||||
}
|
||||
|
||||
sub header {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Mimick the header function.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
my %p = (ref($_[0]) eq 'HASH') ? %{$_[0]} : ( @_ % 2 ) ? () : @_;
|
||||
my @headers;
|
||||
|
||||
# Don't print headers twice unless -force'd.
|
||||
return '' if not delete $p{-force} and $PRINTED_HEAD;
|
||||
|
||||
# Start by adding NPH headers if requested.
|
||||
if ($self->{nph} || $p{-nph}) {
|
||||
if ($p{-url}) {
|
||||
push @headers, "HTTP/1.0 302 Moved";
|
||||
}
|
||||
else {
|
||||
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
|
||||
unless (MOD_PERL) {
|
||||
push @headers, "$protocol 200 OK";
|
||||
}
|
||||
}
|
||||
}
|
||||
delete $p{-nph};
|
||||
|
||||
# If requested, add a "Pragma: no-cache"
|
||||
my $no_cache = $p{'no-cache'} || $p{'-no-cache'};
|
||||
delete @p{qw/no-cache -no-cache/};
|
||||
if ($no_cache) {
|
||||
require GT::Date;
|
||||
push @headers,
|
||||
"Expires: Tue, 25 Jan 2000 12:00:00 GMT",
|
||||
"Last-Modified: " . GT::Date::date_get_gm(time, "%ddd%, %dd% %mmm% %yyyy% %HH%:%MM%:%ss% GMT"),
|
||||
"Cache-Control: no-cache",
|
||||
"Pragma: no-cache";
|
||||
}
|
||||
|
||||
# Add any cookies, we accept either an array of cookies
|
||||
# or a single cookie.
|
||||
my $add_date = 0;
|
||||
my $cookies = 0;
|
||||
my $container = delete($p{-cookie}) || '';
|
||||
require GT::CGI::Cookie if $container;
|
||||
if (ref $container and UNIVERSAL::isa($container, 'GT::CGI::Cookie')) {
|
||||
my $c = $container->cookie_header;
|
||||
push @headers, $c;
|
||||
$add_date = 1;
|
||||
$cookies++;
|
||||
}
|
||||
elsif (ref $container eq 'ARRAY') {
|
||||
foreach my $cookie (@$container) {
|
||||
next unless (defined $cookie and (ref $cookie eq 'GT::CGI::Cookie'));
|
||||
push @headers, $cookie->cookie_header;
|
||||
$add_date = 1;
|
||||
$cookies++;
|
||||
}
|
||||
}
|
||||
elsif ($container) {
|
||||
$self->error('INVALIDCOOKIE', 'WARN', $container);
|
||||
}
|
||||
|
||||
# Print expiry if requested.
|
||||
if (defined(my $expires = delete $p{-expires})) {
|
||||
require GT::CGI::Cookie;
|
||||
my $date = GT::CGI::Cookie->format_date(' ', $expires);
|
||||
unless ($date) {
|
||||
$self->error('INVALIDDATE', 'WARN', $expires);
|
||||
}
|
||||
else {
|
||||
push @headers, "Expires: $date";
|
||||
$add_date = 1;
|
||||
}
|
||||
}
|
||||
|
||||
# Add a Date header if we printed an expires tag or a cookie tag.
|
||||
if ($add_date) {
|
||||
require GT::CGI::Cookie;
|
||||
my $now = GT::CGI::Cookie->format_date(' ');
|
||||
push @headers, "Date: $now";
|
||||
}
|
||||
|
||||
# Add Redirect Header.
|
||||
my $iis_redirect;
|
||||
if (my $url = delete $p{-url}) {
|
||||
if ($ENV{SERVER_SOFTWARE} =~ m|IIS/(\d+)|i and ($cookies or $1 >= 6)) {
|
||||
$iis_redirect = $url;
|
||||
}
|
||||
else {
|
||||
push @headers, "Location: $url";
|
||||
}
|
||||
}
|
||||
|
||||
# Add the Content-type header.
|
||||
my $type = @_ == 1 && !ref($_[0]) ? $_[0] : delete($p{-type}) || 'text/html';
|
||||
push @headers, "Content-type: $type";
|
||||
|
||||
# Add any custom headers.
|
||||
foreach my $key (keys %p) {
|
||||
$key =~ /^\s*-?(.+)/;
|
||||
push @headers, escape(ucfirst $1) . ": " . (ref $p{$key} eq 'SCALAR' ? ${$p{$key}} : escape($p{$key}));
|
||||
}
|
||||
$PRINTED_HEAD = 1;
|
||||
|
||||
my $headers = join($EOL, @headers) . $EOL . $EOL;
|
||||
|
||||
# Fun hack for IIS
|
||||
if ($iis_redirect) {
|
||||
$iis_redirect =~ y/;/&/; # You can't have semicolons in a meta http-equiv tag.
|
||||
return $headers . <<END_OF_HTML;
|
||||
<html><head><title>Document Moved</title><meta http-equiv="refresh" content="0;URL=$iis_redirect"></head>
|
||||
<body><noscript><h1>Object Moved</h1>This document may be found <a HREF="$iis_redirect">here</a></noscript></body></html>
|
||||
END_OF_HTML
|
||||
}
|
||||
return $headers;
|
||||
}
|
||||
|
||||
$COMPILE{redirect} = __LINE__ . <<'END_OF_SUB';
|
||||
sub redirect {
|
||||
#-------------------------------------------------------------------------------
|
||||
# Print a redirect header.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
|
||||
my (@headers, $url);
|
||||
if (@_ == 0) {
|
||||
return $self->header({ -url => $self->self_url });
|
||||
}
|
||||
elsif (@_ == 1) {
|
||||
return $self->header({ -url => shift });
|
||||
}
|
||||
else {
|
||||
my $opts = ref $_[0] eq 'HASH' ? shift : {@_};
|
||||
$opts->{'-url'} ||= $opts->{'-URL'} || $self->self_url;
|
||||
return $self->header($opts);
|
||||
}
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub unescape {
|
||||
#-------------------------------------------------------------------------------
|
||||
# returns the url decoded string of the passed argument. Optionally takes an
|
||||
# array reference of multiple strings to decode. The values of the array are
|
||||
# modified directly, so you shouldn't need the return (which is the same array
|
||||
# reference).
|
||||
#
|
||||
my $todecode = pop;
|
||||
return unless defined $todecode;
|
||||
for my $str (ref $todecode eq 'ARRAY' ? @$todecode : $todecode) {
|
||||
$str =~ tr/+/ /; # pluses become spaces
|
||||
$str =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge;
|
||||
}
|
||||
$todecode;
|
||||
}
|
||||
|
||||
$COMPILE{escape} = __LINE__ . <<'END_OF_SUB';
|
||||
sub escape {
|
||||
#--------------------------------------------------------------------------------
|
||||
# return the url encoded string of the passed argument
|
||||
#
|
||||
my $toencode = pop;
|
||||
return unless defined $toencode;
|
||||
$toencode =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
|
||||
return $toencode;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{html_escape} = __LINE__ . <<'END_OF_SUB';
|
||||
sub html_escape {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Return the string html_escaped.
|
||||
#
|
||||
my $toencode = pop;
|
||||
return unless defined $toencode;
|
||||
if (ref($toencode) eq 'SCALAR') {
|
||||
$$toencode =~ s/&/&/g;
|
||||
$$toencode =~ s/</</g;
|
||||
$$toencode =~ s/>/>/g;
|
||||
$$toencode =~ s/"/"/g;
|
||||
$$toencode =~ s/'/'/g;
|
||||
}
|
||||
else {
|
||||
$toencode =~ s/&/&/g;
|
||||
$toencode =~ s/</</g;
|
||||
$toencode =~ s/>/>/g;
|
||||
$toencode =~ s/"/"/g;
|
||||
$toencode =~ s/'/'/g;
|
||||
}
|
||||
return $toencode;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{html_unescape} = __LINE__ . <<'END_OF_SUB';
|
||||
sub html_unescape {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Return the string html unescaped.
|
||||
#
|
||||
my $todecode = pop;
|
||||
return unless defined $todecode;
|
||||
if (ref $todecode eq 'SCALAR') {
|
||||
$$todecode =~ s/</</g;
|
||||
$$todecode =~ s/>/>/g;
|
||||
$$todecode =~ s/"/"/g;
|
||||
$$todecode =~ s/'/'/g;
|
||||
$$todecode =~ s/&/&/g;
|
||||
}
|
||||
else {
|
||||
$todecode =~ s/</</g;
|
||||
$todecode =~ s/>/>/g;
|
||||
$todecode =~ s/"/"/g;
|
||||
$todecode =~ s/'/'/g;
|
||||
$todecode =~ s/&/&/g;
|
||||
}
|
||||
return $todecode;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{self_url} = __LINE__ . <<'END_OF_SUB';
|
||||
sub self_url {
|
||||
# -------------------------------------------------------------------
|
||||
# Return full URL with query options as CGI.pm
|
||||
#
|
||||
return $_[0]->url(query_string => 1, absolute => 1);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{url} = __LINE__ . <<'END_OF_SUB';
|
||||
sub url {
|
||||
# -------------------------------------------------------------------
|
||||
# Return the current url. Can be called as GT::CGI->url() or $cgi->url().
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my $opts = $self->common_param(@_);
|
||||
|
||||
my $absolute = exists $opts->{absolute} ? $opts->{absolute} : 0;
|
||||
my $query_string = exists $opts->{query_string} ? $opts->{query_string} : 1;
|
||||
my $path_info = exists $opts->{path_info} ? $opts->{path_info} : 0;
|
||||
my $remove_empty = exists $opts->{remove_empty} ? $opts->{remove_empty} : 0;
|
||||
if ($opts->{relative}) {
|
||||
$absolute = 0;
|
||||
}
|
||||
|
||||
my $url = '';
|
||||
my $script = $ENV{SCRIPT_NAME} || $0;
|
||||
my ($path, $prog) = $script =~ m,^(.+?)[/\\]?([^/\\]*)$,;
|
||||
|
||||
if ($absolute) {
|
||||
my ($protocol, $version) = split('/', $ENV{SERVER_PROTOCOL} || 'HTTP/1.0');
|
||||
$url = lc $protocol . "://";
|
||||
|
||||
my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME} || '';
|
||||
$url .= $host;
|
||||
|
||||
$path =~ s,^[/\\]*|[/\\]*$,,g;
|
||||
$url .= "/$path/";
|
||||
}
|
||||
$prog =~ s,^[/\\]*|[/\\]*$,,g;
|
||||
$url .= $prog;
|
||||
|
||||
if ($path_info and $ENV{PATH_INFO}) {
|
||||
my $path = $ENV{PATH_INFO};
|
||||
if (defined $ENV{SERVER_SOFTWARE} && $ENV{SERVER_SOFTWARE} =~ /IIS/) {
|
||||
$path =~ s/\Q$ENV{SCRIPT_NAME}//;
|
||||
}
|
||||
$url .= $path;
|
||||
}
|
||||
if ($query_string) {
|
||||
my $qs = $self->query_string( remove_empty => $remove_empty );
|
||||
if ($qs) {
|
||||
$url .= "?" . $qs;
|
||||
}
|
||||
}
|
||||
return $url;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{query_string} = __LINE__ . <<'END_OF_SUB';
|
||||
sub query_string {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the query string url escaped.
|
||||
#
|
||||
my $self = shift;
|
||||
$self = $self->class_new unless ref $self;
|
||||
$self->load_data() unless $self->{data_loaded};
|
||||
my $opts = $self->common_param(@_);
|
||||
my $qs = '';
|
||||
foreach my $key (@{$self->{param_order} || []}) {
|
||||
my $esc_key = escape($key);
|
||||
foreach my $val (@{$self->{params}->{$key}}) {
|
||||
next if ($opts->{remove_empty} and ($val eq ''));
|
||||
$qs .= $esc_key . "=" . escape($val) . ";";
|
||||
}
|
||||
}
|
||||
$qs and chop $qs;
|
||||
$qs ? return $qs : return '';
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{browser_info} = __LINE__ . <<'END_OF_SUB';
|
||||
sub browser_info {
|
||||
# -----------------------------------------------------------------------------
|
||||
# my %tags = browser_info();
|
||||
# --------------------------
|
||||
# Returns various is_BROWSER, BROWSER_version tags.
|
||||
#
|
||||
return unless $ENV{HTTP_USER_AGENT};
|
||||
|
||||
my %browser_opts;
|
||||
|
||||
if ($ENV{HTTP_USER_AGENT} =~ m{Opera(?:\s+|/)(\d+\.\d+)}i) {
|
||||
$browser_opts{is_opera} = 1;
|
||||
$browser_opts{opera_version} = $1;
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i) {
|
||||
$browser_opts{is_ie} = 1;
|
||||
$browser_opts{ie_version} = $1;
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ m{Mozilla/(\d+\.\d+)\s+\([^)]*rv:(\d+\.\d+)}i) {
|
||||
if ($1 >= 5.0) {
|
||||
$browser_opts{is_mozilla} = 1;
|
||||
$browser_opts{mozilla_version} = $2;
|
||||
}
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ m{Safari/(\d+(?:\.\d+)?)}i) {
|
||||
$browser_opts{is_safari} = 1;
|
||||
$browser_opts{safari_version} = $1;
|
||||
}
|
||||
elsif ($ENV{HTTP_USER_AGENT} =~ m{Konqueror/(\d+\.\d+)}i) {
|
||||
$browser_opts{is_konqueror} = 1;
|
||||
$browser_opts{konqueror_version} = $1;
|
||||
}
|
||||
return %browser_opts;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub parse_str {
|
||||
#--------------------------------------------------------------------------------
|
||||
# parses a query string and add it to the parameter list
|
||||
#
|
||||
my $self = shift;
|
||||
my @input;
|
||||
for (split /[;&]/, shift) {
|
||||
my ($key, $val) = /([^=]+)=(.*)/ or next;
|
||||
|
||||
# Need to remove cr's on windows.
|
||||
if ($^O eq 'MSWin32') {
|
||||
$key =~ s/%0D%0A/%0A/gi; # \x0d = \r, \x0a = \n
|
||||
$val =~ s/%0D%0A/%0A/gi;
|
||||
}
|
||||
push @input, $key, $val;
|
||||
}
|
||||
unescape(\@input);
|
||||
while (@input) {
|
||||
my ($k, $v) = splice @input, 0, 2;
|
||||
$self->{params}->{$k} or push @{$self->{param_order}}, $k;
|
||||
unshift @{$self->{params}->{$k}}, $v;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
GT::CGI - a lightweight replacement for CGI.pm
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use GT::CGI;
|
||||
my $in = new GT::CGI;
|
||||
foreach my $param ($in->param) {
|
||||
print "VALUE: $param => ", $in->param($param), "\n";
|
||||
}
|
||||
|
||||
use GT::CGI qw/-no_parse_buttons/;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
GT::CGI is a lightweight replacement for CGI.pm. It implements most of the
|
||||
functionality of CGI.pm, with the main difference being that GT::CGI does not
|
||||
provide a function-based interface (with the exception of the escape/unescape
|
||||
functions, which can be called as either function or method), nor does it
|
||||
provide the HTML functionality provided by CGI.pm.
|
||||
|
||||
The primary motivation for this is to provide a CGI module that can be shipped
|
||||
with Gossamer products, not having to depend on a recent version of CGI.pm
|
||||
being installed on remote servers. The secondary motivation is to provide a
|
||||
module that loads and runs faster, thus speeding up Gossamer products.
|
||||
|
||||
Credit and thanks goes to the author of CGI.pm. A lot of the code (especially
|
||||
file upload) was taken from CGI.pm.
|
||||
|
||||
=head2 param - Accessing form input.
|
||||
|
||||
Can be called as either a class method or object method. When called with no
|
||||
arguments a list of keys is returned.
|
||||
|
||||
When called with a single argument in scalar context the first (and possibly
|
||||
only) value is returned. When called in list context an array of values is
|
||||
returned.
|
||||
|
||||
When called with two arguments, it sets the key-value pair.
|
||||
|
||||
=head2 header() - Printing HTTP headers
|
||||
|
||||
Can be called as a class method or object method. When called with no
|
||||
arguments, simply returns the HTTP header.
|
||||
|
||||
Other options include:
|
||||
|
||||
=over 4
|
||||
|
||||
=item -force => 1
|
||||
|
||||
Force printing of header even if it has already been displayed.
|
||||
|
||||
=item -type => 'text/plain'
|
||||
|
||||
Set the type of the header to something other then text/html.
|
||||
|
||||
=item -cookie => $cookie
|
||||
|
||||
Display any cookies. You can pass in a single GT::CGI::Cookie object, or an
|
||||
array of them.
|
||||
|
||||
=item -nph => 1
|
||||
|
||||
Display full headers for nph scripts.
|
||||
|
||||
=back
|
||||
|
||||
If called with a single argument, sets the Content-Type.
|
||||
|
||||
=head2 redirect - Redirecting to new URL.
|
||||
|
||||
Returns a Location: header to redirect a user.
|
||||
|
||||
=head2 cookie - Set/Get HTTP Cookies.
|
||||
|
||||
Sets or gets a cookie. To retrieve a cookie:
|
||||
|
||||
my $cookie = $cgi->cookie ('key');
|
||||
my $cookie = $cgi->cookie (-name => 'key');
|
||||
|
||||
or to retrieve a hash of all cookies:
|
||||
|
||||
my $cookies = $cgi->cookie;
|
||||
|
||||
To set a cookie:
|
||||
|
||||
$c = $cgi->cookie (-name => 'foo', -value => 'bar')
|
||||
|
||||
You can also specify -expires for when the cookie should expire, -path for
|
||||
which path the cookie valid, -domain for which domain the cookie is valid, and
|
||||
-secure if the cookie is only valid for secure sites.
|
||||
|
||||
You would then set the cookie by passing it to the header function:
|
||||
|
||||
print $in->header ( -cookie => $c );
|
||||
|
||||
=head2 url - Retrieve the current URL.
|
||||
|
||||
Returns the current URL of the script. It defaults to display just the script
|
||||
name and query string.
|
||||
|
||||
Options include:
|
||||
|
||||
=over 4
|
||||
|
||||
=item absolute => 1
|
||||
|
||||
Return the full URL: http://domain/path/to/script.cgi
|
||||
|
||||
=item relative => 1
|
||||
|
||||
Return only the script name: script.cgi
|
||||
|
||||
=item query_string => 1
|
||||
|
||||
Return the query string as well: script.cgi?a=b
|
||||
|
||||
=item path_info => 1
|
||||
|
||||
Returns the path info as well: script.cgi/foobar
|
||||
|
||||
=item remove_empty => 0
|
||||
|
||||
Removes empty query= from the query string.
|
||||
|
||||
=back
|
||||
|
||||
=head2 get_hash - Return all form input as hash.
|
||||
|
||||
This returns the current parameters as a hash. Any values that have the same
|
||||
key will be returned as an array reference of the multiple values.
|
||||
|
||||
=head2 escape - URL escape a string.
|
||||
|
||||
Returns the passed in value URL escaped. Can be called as class method or
|
||||
object method.
|
||||
|
||||
=head2 unescape - URL unescape a string.
|
||||
|
||||
Returns the passed in value URL un-escaped. Can be called as class method or
|
||||
object method. Optionally can take an array reference of strings instead of a
|
||||
string. If called in this method, the values of the array reference will be
|
||||
directly altered.
|
||||
|
||||
=head2 html_escape - HTML escape a string
|
||||
|
||||
Returns the passed in value HTML escaped. Translates &, <, > and " to their
|
||||
html equivalants.
|
||||
|
||||
=head2 html_unescape - HTML unescapes a string
|
||||
|
||||
Returns the passed in value HTML unescaped.
|
||||
|
||||
=head1 DEPENDENCIES
|
||||
|
||||
Note: GT::CGI depends on L<GT::Base> and L<GT::AutoLoader>, and if you are
|
||||
performing file uploads, GT::CGI::MultiPart, GT::CGI::Fh, and L<GT::TempFile>.
|
||||
The ability to set cookies requires GT::CGI::Cookie.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
http://www.gossamer-threads.com/
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Revision: $Id: CGI.pm,v 1.145 2005/06/21 21:02:57 jagerman Exp $
|
||||
|
||||
=cut
|
||||
101
site/glist/lib/GT/CGI/Action.pm
Normal file
101
site/glist/lib/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 :
|
||||
# $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/glist/lib/GT/CGI/Action/Common.pm
Normal file
286
site/glist/lib/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 :
|
||||
# $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/glist/lib/GT/CGI/Action/Plugin.pm
Normal file
106
site/glist/lib/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 :
|
||||
# $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__
|
||||
|
||||
|
||||
101
site/glist/lib/GT/CGI/Cookie.pm
Normal file
101
site/glist/lib/GT/CGI/Cookie.pm
Normal file
@@ -0,0 +1,101 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Cookie
|
||||
# CVS Info :
|
||||
# $Id: Cookie.pm,v 1.5 2004/08/19 23:49:30 jagerman 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 => ''
|
||||
};
|
||||
@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});
|
||||
$self->{-path} and $header .= "; path=$self->{-path}";
|
||||
$self->{-domain} and $header .= "; domain=$self->{-domain}";
|
||||
$self->{-secure} and $header .= "; secure";
|
||||
|
||||
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/glist/lib/GT/CGI/EventLoop.pm
Normal file
502
site/glist/lib/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 :
|
||||
# $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/glist/lib/GT/CGI/Fh.pm
Normal file
70
site/glist/lib/GT/CGI/Fh.pm
Normal file
@@ -0,0 +1,70 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::Fh
|
||||
# CVS Info :
|
||||
# $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;
|
||||
254
site/glist/lib/GT/CGI/MultiPart.pm
Normal file
254
site/glist/lib/GT/CGI/MultiPart.pm
Normal file
@@ -0,0 +1,254 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::CGI::MultiPart
|
||||
# CVS Info :
|
||||
# $Id: MultiPart.pm,v 1.5 2004/01/13 01:35:16 jagerman 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) = @_;
|
||||
|
||||
# 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";
|
||||
$header->{'Content-Disposition'} =~ m/ name=(?:"([^"]*)"|((?!")[^;]*))/;
|
||||
$name = $1 || $2;
|
||||
($filename) = $header->{'Content-Disposition'} =~ m/ filename="?([^\";]*)"?/;
|
||||
|
||||
# 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;
|
||||
while (defined($data = $parser->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;
|
||||
}
|
||||
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,$2);
|
||||
$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/glist/lib/GT/Cache.pm
Normal file
245
site/glist/lib/GT/Cache.pm
Normal file
@@ -0,0 +1,245 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Cache
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $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
|
||||
927
site/glist/lib/GT/Config.pm
Normal file
927
site/glist/lib/GT/Config.pm
Normal file
@@ -0,0 +1,927 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Config
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Config.pm,v 1.45 2005/03/21 05:49:39 jagerman 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.45 2005/03/21 05:49:39 jagerman Exp $ - The version.
|
||||
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.45 $ =~ /(\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 {
|
||||
if (-e "$root/$file") {
|
||||
$att->{file_order} = ["$root/$file"];
|
||||
$att->{files}->{"$root/$file"} = [(stat("$root/$file"))[7, 9]];
|
||||
}
|
||||
elsif ($att->{create_ok} or $just_do_ok) {
|
||||
$att->{file_order} = [];
|
||||
}
|
||||
else {
|
||||
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.45 2005/03/21 05:49:39 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1128
site/glist/lib/GT/Date.pm
Normal file
1128
site/glist/lib/GT/Date.pm
Normal file
File diff suppressed because it is too large
Load Diff
180
site/glist/lib/GT/Delay.pm
Normal file
180
site/glist/lib/GT/Delay.pm
Normal file
@@ -0,0 +1,180 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Delay
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $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
|
||||
384
site/glist/lib/GT/Dumper.pm
Normal file
384
site/glist/lib/GT/Dumper.pm
Normal file
@@ -0,0 +1,384 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Dumper
|
||||
# Author: Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Dumper.pm,v 1.38 2005/02/18 04:44:33 jagerman 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;
|
||||
|
||||
$EOL = "\n";
|
||||
$VERSION = sprintf "%d.%03d", q$Revision: 1.38 $ =~ /(\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 $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};
|
||||
if ($obj =~ /ARRAY\(/) { $self->_dump_array($level + 2, \@{$obj}, $ret) }
|
||||
elsif ($obj =~ /HASH\(/) { $self->_dump_hash( $level + 2, \%{$obj}, $ret) }
|
||||
elsif ($obj =~ /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.38 2005/02/18 04:44:33 jagerman Exp $
|
||||
|
||||
=cut
|
||||
865
site/glist/lib/GT/File/Diff.pm
Normal file
865
site/glist/lib/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 :
|
||||
# $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/glist/lib/GT/File/Tools.pm
Normal file
1507
site/glist/lib/GT/File/Tools.pm
Normal file
File diff suppressed because it is too large
Load Diff
285
site/glist/lib/GT/FileMan.pm
Normal file
285
site/glist/lib/GT/FileMan.pm
Normal file
@@ -0,0 +1,285 @@
|
||||
# ==================================================================
|
||||
# File manager - enhanced web based file management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info :
|
||||
# Revision : $Id: FileMan.pm,v 1.121 2005/04/11 17:24:03 jagerman 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/@ISA $DEBUG $HAVE_GZIP $HAVE_AZIP $UNSAFE_PATH/;
|
||||
use GT::Base qw/:persist/;
|
||||
use GT::Template;
|
||||
use GT::FileMan::Commands;
|
||||
|
||||
# Check if Compress::Zlib is available
|
||||
$HAVE_GZIP = eval { local $SIG{__DIE__}; require Compress::Zlib; 1; } ? 1 : 0;
|
||||
|
||||
# Check if Archive::Zip is available
|
||||
$HAVE_AZIP = eval { local $SIG{__DIE__}; require Archive::Zip; 1; } ? 1 : 0;
|
||||
|
||||
$DEBUG = 0;
|
||||
|
||||
@ISA = qw/GT::FileMan::Commands GT::Base/;
|
||||
|
||||
$UNSAFE_PATH = $^O =~ /mswin/i ? '(^|[/\\\\])\.\.?($|[/\\\\])' : '(^|/)\.\.?($|/)';
|
||||
|
||||
sub new {
|
||||
# ------------------------------------------------------------------
|
||||
# Constructor
|
||||
#
|
||||
my ($class,%args) = @_;
|
||||
my $self = bless {%args}, ref $class || $class;
|
||||
|
||||
$self->{cfg} = $self->load_config() if (!$self->{cfg});
|
||||
$self->{cfg}->{winnt} = $^O eq 'MSWin32' ? 1 : 0;
|
||||
$self->{cfg}->{upload_chmod} ||= '644';
|
||||
$self->{cfg}->{template_root} or die('You must pass in your template root !');
|
||||
$self->{cfg}->{root_dir} or die('You must set your root dir !');
|
||||
|
||||
$self->{in} = new GT::CGI;
|
||||
$self->{cgi} = $self->{in}->get_hash;
|
||||
|
||||
my $passwd_dir = $self->{passwd_dir};
|
||||
if ($passwd_dir and !$self->{in}->cookie('def_passwd_dir')) { #store the password directory to cookie
|
||||
$passwd_dir = "$self->{cfg}->{root_dir}/$passwd_dir" if ($self->{cfg}->{passwd_dir_level}); # must be inside root directory
|
||||
|
||||
(-e $passwd_dir and -w _) or die("$passwd_dir does not exist or not writeable");
|
||||
print $self->{in}->header (-cookie => [ $self->{in}->cookie ( -name => 'def_passwd_dir', -value => $passwd_dir, -expires => '+5y') ]);
|
||||
}
|
||||
|
||||
# Set our default working directory.
|
||||
$self->{work_path} = $self->{cgi}->{work_path};
|
||||
if ($self->{cgi}->{def_load} and !$self->{cgi}->{work_path}) {
|
||||
$self->{work_path} = ($self->{in}->cookie('def_working_dir') eq '/') ? '' : $self->{in}->cookie('def_working_dir');
|
||||
(!$self->{work_path} or ($self->{work_path} =~ m,^([-\w/. ]+)$, and $self->{work_path} !~ /$UNSAFE_PATH/)) or ($self->{work_path} = '');
|
||||
}
|
||||
$self->{work_path} ||= '';
|
||||
(!$self->{work_path} or ($self->{work_path} =~ m,^([-\w/. ]+)$, and $self->{work_path} !~ /$UNSAFE_PATH/)) or die ("work_path has invalid characters : $self->{work_path} ");
|
||||
-e "$self->{cfg}->{root_dir}/$self->{work_path}" or ($self->{work_path} = '');
|
||||
|
||||
$self->{http_ref} = $self->{in}->url (absolute => 0, query_string => 0);
|
||||
$self->{results} = '';
|
||||
$self->{data} = {};
|
||||
$self->{status} = '';
|
||||
$self->{input} = '';
|
||||
$self->{debug} and ($DEBUG = $self->{debug});
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub process {
|
||||
# ------------------------------------------------------------------
|
||||
my $self = shift;
|
||||
my $action = $self->{cgi}->{fdo} || $self->{cgi}->{cmd_do};
|
||||
|
||||
return $self->page("home.html") if (!$action or $action eq 'fileman');
|
||||
|
||||
my $command_enable = 1; # default is enable
|
||||
$command_enable = $self->{commands}->{$action} if (exists $self->{commands}->{$action});
|
||||
|
||||
# Determine what to do:
|
||||
if (exists $GT::FileMan::Commands::COMPILE{$action} and $command_enable) {
|
||||
$self->$action();
|
||||
}
|
||||
else {
|
||||
die "<font color=red>Invalid action or command is disable : $action !</font>";
|
||||
}
|
||||
}
|
||||
|
||||
sub page {
|
||||
# ------------------------------------------------------------------
|
||||
# Print out the requested template
|
||||
#
|
||||
my ($self, $file, $args) = @_;
|
||||
$file ||= $self->{cgi}->{page};
|
||||
print $self->{in}->header;
|
||||
|
||||
my $template_path = ($self->{cgi}->{t}) ? "$self->{cfg}->{template_root}/$self->{cgi}->{t}" : $self->{cfg}->{template_root};
|
||||
|
||||
# Check the file name requested.
|
||||
"$template_path/$file" =~ /\\/ and return die "Invalid template '$file' requested (Invalid name)";
|
||||
"$template_path/$file" =~ /$UNSAFE_PATH/ and return die "Invalid template '$file' requested (Invalid name)";
|
||||
$file =~ m,^\s*/, and return die "Invalid template '$file' requested (Invalid name)";
|
||||
-e "$template_path/$file" or return die "Invalid template '$template_path/$file' requested (File does not exist)";
|
||||
-r _ or return die "Invalid template '$file' requested (Permission denied)";
|
||||
|
||||
# Make data available.
|
||||
foreach my $key (keys % {$self->{data}}) {
|
||||
exists $args->{$key} or $args->{$key} = $self->{data}->{$key};
|
||||
}
|
||||
|
||||
# Make cgi input available.
|
||||
foreach my $key (keys % {$self->{cgi}}) {
|
||||
exists $args->{$key} or $args->{$key} = $self->{cgi}->{$key};
|
||||
}
|
||||
|
||||
# Make commands available.
|
||||
my $count = 0;
|
||||
if ($self->{commands}) { #activate or deactivate the commands
|
||||
foreach my $key (keys % {$self->{commands}}) {
|
||||
exists $args->{$key} or $args->{$key} = $self->{commands}->{$key};
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
|
||||
$args->{show_all} = '1' if ($count == 0);
|
||||
$args->{status} ||= $self->{status};
|
||||
$args->{input} = $self->{input};
|
||||
$args->{http_ref} = $self->{http_ref};
|
||||
$args->{url_opts} = $self->{url_opts};
|
||||
$args->{work_path} = $self->{work_path} || $self->{cgi}->{work_path};
|
||||
$args->{template_root} = $self->{cfg}->{template_root};
|
||||
|
||||
$args->{root_dir} = $self->{cfg}->{root_dir};
|
||||
$args->{html_url} = $self->{cfg}->{html_root_url};
|
||||
$args->{root_url} = $self->{cfg}->{root_url};
|
||||
$args->{root_select} = $self->{cfg}->{root_select} if ($self->{cfg}->{root_select});
|
||||
$args->{session_id} = $self->{cfg}->{session_id} if ($self->{cfg}->{session_id});
|
||||
$args->{user_sessions} = $self->{cfg}->{user_sessions} if ($self->{cfg}->{user_sessions});
|
||||
$args->{username} = $self->{cfg}->{username} if ($self->{cfg}->{username});
|
||||
$args->{multi} = $self->{cfg}->{multi} if ($self->{cfg}->{multi});
|
||||
$args->{single} = $self->{cfg}->{single} if ($self->{cfg}->{single});
|
||||
|
||||
$args->{have_gzip} = $HAVE_GZIP;
|
||||
$args->{have_azip} = $HAVE_AZIP;
|
||||
$args->{srv_soft} = ($ENV{SERVER_SOFTWARE} =~ /Apache|Unix/)? 0 : 1 if ($ENV{SERVER_SOFTWARE});
|
||||
$args->{position} = $self->{in}->cookie('readme_position') if ($args->{readme});
|
||||
|
||||
$args->{scheme} = $self->{in}->cookie('scheme') || 'fileman';
|
||||
$args->{font} = $self->{in}->cookie('font') || "<font face='Verdana, Arial, Helvetica, sans-serif' size=2>";
|
||||
$args->{font} =~ s/[\'\"]/\'/g;
|
||||
|
||||
# Used for HTML editor
|
||||
my $brws = $self->get_browser();
|
||||
|
||||
# Export home for using in auto generate HTML.
|
||||
GT::Template->parse ("$template_path/$file", { %$args, %$brws }, { print => 1 });
|
||||
}
|
||||
|
||||
sub get_browser {
|
||||
my ($self, $verify) = @_;
|
||||
my ($version, %brws);
|
||||
if ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ /MSIE (\d+(?:\.\d+)?)/i) {
|
||||
$version = $1;
|
||||
$brws{ie_version} = $version;
|
||||
}
|
||||
$brws{is_ie} = ($version and $version >= 5.5) ? 1 : 0;
|
||||
|
||||
if ($ENV{HTTP_USER_AGENT} and $ENV{HTTP_USER_AGENT} =~ m{Mozilla/(\d+\.\d+)\s+\([^)]*rv:(\d+\.\d+)\)}) {
|
||||
if ($1 >= 5.0) {
|
||||
$brws{is_mozilla} = 1;
|
||||
$brws{mozilla_version} = $2;
|
||||
}
|
||||
}
|
||||
if ( $verify ) {
|
||||
($brws{ie_version} >= 5.5 or $brws{mozilla_version} >= 1.4) ? return 1 : return 0;
|
||||
}
|
||||
else {
|
||||
return \%brws;
|
||||
}
|
||||
}
|
||||
|
||||
sub load_config {
|
||||
# --------------------------------------------------------------------
|
||||
# Load the config file into a hash.
|
||||
#
|
||||
my $self = shift;
|
||||
my $file = $self->{cfg_path} || 'ConfigData.pm';
|
||||
my $cfg = do $file;
|
||||
if (ref $cfg ne 'HASH') {
|
||||
die "Invalid config file: $file. Got: '$cfg' instead of actual data. Error: $@ $!";
|
||||
}
|
||||
return $cfg;
|
||||
}
|
||||
|
||||
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 $msg = shift;
|
||||
my $in = new GT::CGI;
|
||||
print $in->header;
|
||||
|
||||
my $work_path = $in->param('work_path') || '';
|
||||
|
||||
print qq!
|
||||
<font face='Tahoma,Arial,Helvetica' size=2>A fatal error has occured:</font></p><blockquote><pre>$msg</pre></blockquote><p><font face='Tahoma,Arial,Helvetica' size=2>Please enable debugging in setup for more details.</font></p>\n
|
||||
!;
|
||||
if ($DEBUG) {
|
||||
print base_env();
|
||||
}
|
||||
}
|
||||
|
||||
sub base_env {
|
||||
# --------------------------------------------------------------------
|
||||
# Return HTML formatted environment for error messages.
|
||||
#
|
||||
my $info = '<PRE>';
|
||||
|
||||
# Stack trace.
|
||||
my $i = 0;
|
||||
$info .= "<B>Stack Trace</B>\n======================================\n";
|
||||
$info .= GT::Base::stack_trace('FileMan', 1, 1);
|
||||
$info .= "\n\n";
|
||||
|
||||
$info .= "<B>System Information</B>\n======================================\n";
|
||||
$info .= "Perl Version: $]\n";
|
||||
$info .= "FileMan Version: $FileMan::VERSION\n" if ($FileMan::VERSION);
|
||||
$info .= "Persistant Env: mod_perl (" . (MOD_PERL ? 1 : 0) . ") SpeedyCGI (" . (SPEEDY ? 1 : 0) . ")\n";
|
||||
$info .= "Mod Perl Version: " . MOD_PERL . "\n" if MOD_PERL;
|
||||
$info .= "\@INC = \n\t" . join ("\n\t", @INC) . "\n";
|
||||
$info .= "\$\@: $@\n" if ($@);
|
||||
$info .= "\n";
|
||||
|
||||
# Environment info.
|
||||
$info .= "<B>ENVIRONMENT</B>\n======================================\n";
|
||||
foreach (sort keys %ENV) { $info .= "$_ => $ENV{$_}\n"; }
|
||||
$info .= "</PRE>";
|
||||
return $info;
|
||||
}
|
||||
|
||||
sub js_quote_include {
|
||||
# --------------------------------------------------------------------
|
||||
# This uses GT::Template to parse the passed in argument. The results are
|
||||
# javascript escaped, and then returned.
|
||||
#
|
||||
my $file = shift;
|
||||
my $tags = GT::Template->tags;
|
||||
|
||||
my $in = new GT::CGI;
|
||||
my $css_file = $in->cookie('scheme') || 'fileman';
|
||||
my $color;
|
||||
CASE: {
|
||||
($css_file eq 'fileman') and $color = '#D6D6D6', last CASE;
|
||||
($css_file eq 'gt') and $color = '#d9e4f2', last CASE;
|
||||
($css_file eq 'maple') and $color = '#F0E8CE', last CASE;
|
||||
($css_file eq 'rainy') and $color = '#CFD8C2', last CASE;
|
||||
($css_file eq 'rose') and $color = '#DEC9CE', last CASE;
|
||||
}
|
||||
my $parsed = GT::Template->parse("$tags->{template_root}/common/$file",
|
||||
{
|
||||
html_url => $tags->{html_url},
|
||||
http_ref => $tags->{http_ref},
|
||||
filename => $tags->{filename},
|
||||
work_path => $tags->{work_path},
|
||||
scrollbar_arrow_color => 'black',
|
||||
scrollbar_base_color => $color,
|
||||
editor_base_color => $color,
|
||||
advanced_editor_background => 'white',
|
||||
advanced_editor_font => 'arial'
|
||||
});
|
||||
$parsed =~ s{([\\/'"<>])}{\\$1}g;
|
||||
$parsed =~ s/(?:\r\n|\r|\n)/\\n/g;
|
||||
return \$parsed;
|
||||
}
|
||||
|
||||
1;
|
||||
3115
site/glist/lib/GT/FileMan/Commands.pm
Normal file
3115
site/glist/lib/GT/FileMan/Commands.pm
Normal file
File diff suppressed because it is too large
Load Diff
442
site/glist/lib/GT/FileMan/Diff.pm
Normal file
442
site/glist/lib/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 :
|
||||
# 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;
|
||||
520
site/glist/lib/GT/MD5.pm
Normal file
520
site/glist/lib/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 :
|
||||
# $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/glist/lib/GT/MD5/Crypt.pm
Normal file
175
site/glist/lib/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
|
||||
425
site/glist/lib/GT/MIMETypes.pm
Normal file
425
site/glist/lib/GT/MIMETypes.pm
Normal file
@@ -0,0 +1,425 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::MIMETypes
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: MIMETypes.pm,v 1.24 2005/04/02 08:08:46 jagerman 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) {
|
||||
defined(%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};
|
||||
}
|
||||
defined(%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 =~ /\.([^.]+)$/) {
|
||||
defined(%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};
|
||||
}
|
||||
defined(%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
|
||||
defined(%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',
|
||||
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',
|
||||
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',
|
||||
wmv => 'wvideo.gif',
|
||||
wma => 'wvideo.gif',
|
||||
sh => 'shellscript.gif',
|
||||
rpm => 'rpm.gif',
|
||||
ttf => 'font_true.gif',
|
||||
doc => 'doc.gif',
|
||||
xls => 'excel.gif',
|
||||
ppt => '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',
|
||||
ppt => 'application/mspowerpoint',
|
||||
xls => 'application/msexcel',
|
||||
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',
|
||||
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',
|
||||
tsv => 'text/tab-separated-values',
|
||||
etx => 'text/x-setext',
|
||||
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 => 'video/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/mspowerpoint' => 'ppt.gif',
|
||||
'application/msword' => 'word.gif',
|
||||
'application/msexcel' => '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',
|
||||
'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/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',
|
||||
) 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.24 2005/04/02 08:08:46 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
979
site/glist/lib/GT/Mail.pm
Normal file
979
site/glist/lib/GT/Mail.pm
Normal file
@@ -0,0 +1,979 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Mail.pm,v 1.70 2004/11/04 20:23:09 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.70 $ =~ /(\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->{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);
|
||||
# ------------------
|
||||
# $obj->parse('/path/to/file');
|
||||
# -----------------------------
|
||||
# $obj->parse($SCALAR_REF -or- $SCALAR);
|
||||
# --------------------------------------
|
||||
# Takes either a path to a file for a file handle. Returns 1 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) = @_;
|
||||
|
||||
# Require our parser
|
||||
require GT::Mail::Parse;
|
||||
|
||||
# Get a new parser object
|
||||
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
||||
$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);
|
||||
# ------------------------
|
||||
# $obj->parse_head ('/path/to/file');
|
||||
# -----------------------------------
|
||||
# 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) = @_;
|
||||
|
||||
# Require our parser
|
||||
require GT::Mail::Parse;
|
||||
|
||||
# Get a new parser object
|
||||
$self->{parser} ||= new GT::Mail::Parse (debug => $self->{_debug});
|
||||
$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},
|
||||
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 contiue
|
||||
$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 . $GT::Mail::Parse::ENCODED);
|
||||
}
|
||||
|
||||
# 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 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;
|
||||
$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 !~ /\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
|
||||
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};
|
||||
$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.70 2004/11/04 20:23:09 brewt Exp $
|
||||
|
||||
=cut
|
||||
1282
site/glist/lib/GT/Mail/BulkMail.pm
Normal file
1282
site/glist/lib/GT/Mail/BulkMail.pm
Normal file
File diff suppressed because it is too large
Load Diff
524
site/glist/lib/GT/Mail/Editor.pm
Normal file
524
site/glist/lib/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.24 2005/01/18 23:06:40 bao 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.24 $ =~ /(\d+)\.(\d+)/;
|
||||
|
||||
$ERRORS = {
|
||||
PARSE => "An error occured 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.24 2005/01/18 23:06:40 bao Exp $
|
||||
|
||||
267
site/glist/lib/GT/Mail/Editor/HTML.pm
Normal file
267
site/glist/lib/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/glist/lib/GT/Mail/Editor/Text.pm
Normal file
147
site/glist/lib/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/glist/lib/GT/Mail/Encoder.pm
Normal file
429
site/glist/lib/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 :
|
||||
# $Id: Encoder.pm,v 1.40 2004/01/13 01:35:17 jagerman 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 >= 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.40 $ =~ /(\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 (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 (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 (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 (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 !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.40 2004/01/13 01:35:17 jagerman Exp $
|
||||
|
||||
|
||||
672
site/glist/lib/GT/Mail/Message.pm
Normal file
672
site/glist/lib/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 :
|
||||
# $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/glist/lib/GT/Mail/POP3.pm
Normal file
829
site/glist/lib/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 :
|
||||
# $Id: POP3.pm,v 1.56 2004/03/19 00:36:16 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 occured while parsing an email: %s",
|
||||
LOGIN => "An error occured 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.56 2004/03/19 00:36:16 brewt Exp $
|
||||
|
||||
788
site/glist/lib/GT/Mail/Parse.pm
Normal file
788
site/glist/lib/GT/Mail/Parse.pm
Normal file
@@ -0,0 +1,788 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Parse
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Parse.pm,v 1.79 2004/10/23 02:16:39 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2004 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 >= 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 $CRLF $CR_LN @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;
|
||||
|
||||
# The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = substr q$Revision: 1.79 $, 10;
|
||||
|
||||
# The CRLF sequence:
|
||||
$CRLF = "\n";
|
||||
|
||||
# The length of a crlf
|
||||
$CR_LN = 1;
|
||||
|
||||
# Error messages
|
||||
$ERRORS = {
|
||||
PARSE => "An error occured while parsing: %s",
|
||||
DECODE => "An error occured 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,
|
||||
}, $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 {
|
||||
# --------------------------------------------------------------------------
|
||||
$CRLF = pop || return $CRLF;
|
||||
$CR_LN = length($CRLF);
|
||||
}
|
||||
|
||||
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 { $_ . $CRLF } split($CRLF => $$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
|
||||
my $indx;
|
||||
if (($indx = index($$in, $CRLF)) == 0) {
|
||||
substr($$in, 0, $CR_LN) = '';
|
||||
}
|
||||
else {
|
||||
$indx = index($$in, ($CRLF . $CRLF));
|
||||
if ($indx == -1) {
|
||||
$self->debug('Message has no body.') if $self->{_debug};
|
||||
$indx = length($$in);
|
||||
}
|
||||
$part->extract([map { $_ . $CRLF } split($CRLF => substr($$in, 0, $indx))])
|
||||
or return $self->error($GT::Mail::Parts::error, 'WARN');
|
||||
substr($$in, 0, $indx + ($CR_LN * 2)) = '';
|
||||
}
|
||||
|
||||
# Get the mime type
|
||||
my ($type, $subtype) = split('/', $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, $CRLF) == -1 or return $self->error("PARSE", "WARN", "CR or LF 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;
|
||||
($state eq 'EOF') and return $self->error('PARSE', 'WARN', 'Unexpected EOF before close.');
|
||||
|
||||
$parts->mime_type($retype) if $retype;
|
||||
push(@{$part->{parts}}, $parts);
|
||||
|
||||
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:
|
||||
my ($delim, $close) = ("--$bound", "--$bound--");
|
||||
$self->debug("Parsing bounds. Skip until\n\tdelim ($delim)\n\tclose ($close)") if $self->{_debug} > 1;
|
||||
my ($pos, $ret);
|
||||
|
||||
# Place our part in $$out.
|
||||
$$out = undef;
|
||||
if (defined($pos = index($$in, "$CRLF$delim$CRLF")) and $pos != -1) {
|
||||
$$out = substr($$in, 0, $pos);
|
||||
substr($$in, 0, $pos + length("$CRLF$delim$CRLF")) = "";
|
||||
$ret = 'DELIM';
|
||||
}
|
||||
elsif (index($$in, "$delim$CRLF") == 0) {
|
||||
substr($$in, 0, length("$delim$CRLF")) = "";
|
||||
$$out = "";
|
||||
$ret = 'DELIM';
|
||||
}
|
||||
elsif (defined($pos = index($$in, "$CRLF$close$CRLF")) and $pos != -1) {
|
||||
$$out = $$in;
|
||||
substr($$out, -(length($$out) - $pos)) = '';
|
||||
my $len = (length($$in) - (length("$CRLF$close$CRLF") + $pos)) * -1;
|
||||
if ($len == 0) {
|
||||
$$in = '';
|
||||
}
|
||||
else {
|
||||
$$in = substr($$in, $len);
|
||||
}
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
elsif (index($$in, "$CRLF$close") == (length($$in) - length("$CRLF$close"))) {
|
||||
$$out = substr($$in, 0, length($$in) - length("$CRLF$close"));
|
||||
$$in = "";
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
elsif (index($$in, "$close$CRLF") == 0) {
|
||||
$$out = "";
|
||||
substr($$in, 0, length("$close$CRLF")) = "";
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
elsif (index($$in, $close) == 0 and (length($$in) == length($close))) {
|
||||
$$out = "";
|
||||
$$in = "";
|
||||
$ret = 'CLOSE';
|
||||
}
|
||||
|
||||
if (defined $$out) {
|
||||
return $ret;
|
||||
}
|
||||
else {
|
||||
# Broken Email, retype to text/plain
|
||||
$self->{parts}->[$#{$self->{parts}}]->set('content-type' => 'text/plain');
|
||||
$$out = $$in;
|
||||
return 'CLOSE';
|
||||
}
|
||||
}
|
||||
|
||||
sub _parse_preamble {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses preamble and sets it in part.
|
||||
#
|
||||
my ($self, $inner_bound, $in, $part) = @_;
|
||||
|
||||
my $loc;
|
||||
my ($delim, $close) = ("--$inner_bound", "--$inner_bound--");
|
||||
|
||||
$self->debug("Parsing preamble. Skip until\n\tdelim ($delim)\n\tclose ($close)") if $self->{_debug} > 1;
|
||||
my @saved;
|
||||
$part->preamble(\@saved);
|
||||
|
||||
my ($data, $pos, $len);
|
||||
if (index($$in, "$delim$CRLF") == 0) {
|
||||
$data = '';
|
||||
substr($$in, 0, length("$delim$CRLF")) = '';
|
||||
}
|
||||
else {
|
||||
$pos = index($$in, "$CRLF$delim$CRLF");
|
||||
if ($pos >= 0) {
|
||||
$data = substr($$in, 0, $pos);
|
||||
substr($$in, 0, $pos + length("$CRLF$delim$CRLF")) = '';
|
||||
}
|
||||
elsif ($pos == -1) {
|
||||
return $self->error('PARSE', 'WARN', "Unable to find opening boundary: " .
|
||||
"$delim\n" .
|
||||
"Message is probably corrupt.");
|
||||
}
|
||||
}
|
||||
push @saved, split $CRLF => $data;
|
||||
undef $data;
|
||||
return 'DELIM';
|
||||
}
|
||||
|
||||
sub _parse_epilogue {
|
||||
# --------------------------------------------------------------------------
|
||||
# Internal Method
|
||||
# ---------------
|
||||
# Parses epilogue and sets it in part.
|
||||
#
|
||||
my ($self, $outer_bound, $in, $part) = @_;
|
||||
my ($delim, $close, $loc);
|
||||
|
||||
($delim, $close) = ("--$outer_bound", "--$outer_bound--") if defined $outer_bound;
|
||||
|
||||
$self->debug("Parsing epilogue. Skip until\n\tdelim (" . ($delim || '') .
|
||||
")\n\tclose (" . ($close || '') . ")")
|
||||
if $self->{_debug} > 1;
|
||||
my @saved;
|
||||
$part->epilogue(\@saved);
|
||||
if (defined $outer_bound) {
|
||||
if ($$in =~ s/(.*?)(?:\A|$CRLF)\Q$delim\E$CRLF//s) {
|
||||
push(@saved, split($CRLF => $1));
|
||||
$self->debug("Found delim($delim)") if $self->{_debug};
|
||||
return 'DELIM'
|
||||
}
|
||||
elsif ($$in =~ s/(.*?)(?:\A|$CRLF)\Q$close\E(?:\Z|$CRLF)//s) {
|
||||
push(@saved, split($CRLF => $1));
|
||||
$self->debug("Found close($close)") if $self->{_debug};
|
||||
return 'CLOSE'
|
||||
}
|
||||
}
|
||||
push(@saved, split($CRLF => $$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/^(.+$CRLF)//o) {
|
||||
local $_ = $1;
|
||||
last if ($mode, $file) = /^begin\s*(\d*)\s*(\S*)/;
|
||||
}
|
||||
return $self->error("uu decoding: no begin found", 'WARN') if (!defined($_));
|
||||
|
||||
# Decode:
|
||||
while ($$in =~ s/^(.+$CRLF)//o) {
|
||||
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.
|
||||
|
||||
=back
|
||||
|
||||
=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.79 2004/10/23 02:16:39 brewt Exp $
|
||||
|
||||
1225
site/glist/lib/GT/Mail/Parts.pm
Normal file
1225
site/glist/lib/GT/Mail/Parts.pm
Normal file
File diff suppressed because it is too large
Load Diff
481
site/glist/lib/GT/Mail/Send.pm
Normal file
481
site/glist/lib/GT/Mail/Send.pm
Normal file
@@ -0,0 +1,481 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Mail::Send
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $Id: Send.pm,v 1.53 2004/08/23 20:07:44 jagerman 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.53 $ =~ /(\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,
|
||||
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]/;
|
||||
|
||||
$resp = $self->smtp_send($sock, "EHLO localhost") or return $self->error('COMMERROR', 'WARN');
|
||||
if ($resp =~ /^[45]/) {
|
||||
$resp = $self->smtp_send($sock, "HELO localhost") 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 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.53 2004/08/23 20:07:44 jagerman Exp $
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
424
site/glist/lib/GT/Plugins.pm
Normal file
424
site/glist/lib/GT/Plugins.pm
Normal file
@@ -0,0 +1,424 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $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
|
||||
837
site/glist/lib/GT/Plugins/Author.pm
Normal file
837
site/glist/lib/GT/Plugins/Author.pm
Normal file
@@ -0,0 +1,837 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Author.pm,v 1.14 2004/01/13 01:35:18 jagerman 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 lib '../..';
|
||||
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.14 $ =~ /(\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;
|
||||
258
site/glist/lib/GT/Plugins/Installer.pm
Normal file
258
site/glist/lib/GT/Plugins/Installer.pm
Normal file
@@ -0,0 +1,258 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::Plugins
|
||||
# Author : Alex Krohn
|
||||
# CVS Info :
|
||||
# $Id: Installer.pm,v 1.13 2004/08/23 19:54:27 jagerman 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.13 $ =~ /(\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'], ...])");
|
||||
}
|
||||
if (ref $hooks->[0] ne 'ARRAY') {
|
||||
$hooks = [ $hooks ];
|
||||
}
|
||||
foreach my $hook (@$hooks) {
|
||||
my ($hookname, $prepost, $action) = @$hook;
|
||||
if (! ((uc $prepost eq 'PRE') or (uc $prepost eq 'POST'))) {
|
||||
die "Invalid hook argument. Must be pre/post, not: $prepost";
|
||||
}
|
||||
push @{$self->{cfg}->{$plugin}->{hooks}}, [lc $hookname, uc $prepost, $action, 1];
|
||||
}
|
||||
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 %$registry) {
|
||||
$registry->{$key} = $registry->{$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']);
|
||||
$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
|
||||
|
||||
=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.13 2004/08/23 19:54:27 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1170
site/glist/lib/GT/Plugins/Manager.pm
Normal file
1170
site/glist/lib/GT/Plugins/Manager.pm
Normal file
File diff suppressed because it is too large
Load Diff
1098
site/glist/lib/GT/Plugins/Wizard.pm
Normal file
1098
site/glist/lib/GT/Plugins/Wizard.pm
Normal file
File diff suppressed because it is too large
Load Diff
155
site/glist/lib/GT/RDF.pm
Normal file
155
site/glist/lib/GT/RDF.pm
Normal file
@@ -0,0 +1,155 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::RDF
|
||||
# Author : Scott Beck
|
||||
# CVS Info :
|
||||
# $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;
|
||||
}
|
||||
|
||||
715
site/glist/lib/GT/SQL.pm
Normal file
715
site/glist/lib/GT/SQL.pm
Normal file
@@ -0,0 +1,715 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL
|
||||
# CVS Info :
|
||||
# $Id: SQL.pm,v 1.111 2005/04/14 20:22:37 alex 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.111 $ =~ /(\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'",
|
||||
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.111 $
|
||||
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.111 2005/04/14 20:22:37 alex Exp $
|
||||
|
||||
=cut
|
||||
3042
site/glist/lib/GT/SQL/Admin.pm
Normal file
3042
site/glist/lib/GT/SQL/Admin.pm
Normal file
File diff suppressed because it is too large
Load Diff
609
site/glist/lib/GT/SQL/Base.pm
Normal file
609
site/glist/lib/GT/SQL/Base.pm
Normal file
@@ -0,0 +1,609 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Table
|
||||
# CVS Info :
|
||||
# $Id: Base.pm,v 1.69 2004/09/22 02:43:29 jagerman 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.69 $ =~ /(\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} > 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} > 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} > 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 "")) {
|
||||
my $c = new GT::SQL::Condition;
|
||||
$c->add($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 defined %{$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/glist/lib/GT/SQL/Condition.pm
Normal file
404
site/glist/lib/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 :
|
||||
# $Id: Condition.pm,v 1.44 2004/10/12 17:54:30 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.44 $ =~ /(\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 $_[$#_] and (uc $_[$#_] eq 'AND' or uc $_[$#_] eq 'OR' or $_[$#_] 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.44 2004/10/12 17:54:30 jagerman Exp $
|
||||
|
||||
=cut
|
||||
1216
site/glist/lib/GT/SQL/Creator.pm
Normal file
1216
site/glist/lib/GT/SQL/Creator.pm
Normal file
File diff suppressed because it is too large
Load Diff
887
site/glist/lib/GT/SQL/Display/HTML.pm
Normal file
887
site/glist/lib/GT/SQL/Display/HTML.pm
Normal file
@@ -0,0 +1,887 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: HTML.pm,v 1.92 2005/04/05 18:47:08 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;
|
||||
# ===============================================================
|
||||
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.92 $ =~ /(\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' ) {
|
||||
$values->{$col."_filename"} = $self->{values}->{$col."_filename"};
|
||||
}
|
||||
$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 SIZE="$self->{cols}->{$clean_name}->{form_size}"!;
|
||||
}
|
||||
elsif (exists $opts->{multiple} and $opts->{multiple} > 1) {
|
||||
$mult = qq!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}) ? " 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" 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}) ? " 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> ~) 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}) ? " 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$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]} });
|
||||
unless ( ( not $href and not $self->{file_use_path} ) or
|
||||
( not ( -e $opts->{value}) and $self->{file_use_path} ) ) {
|
||||
|
||||
require GT::SQL::File;
|
||||
my $sfname = $values->{$colname."_filename"};
|
||||
$out = $sfname || GT::SQL::File::get_filename($fname ||= $href->{File_Name} );
|
||||
$self->{file_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" type=hidden 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 => ( $self->{file_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 => ( $self->{file_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>!;
|
||||
}
|
||||
$out .= qq~ <input type=checkbox name="$opts->{name}_del" value="delete"> Delete~;
|
||||
}
|
||||
}
|
||||
my $class = ($opts->{def}->{class}) ? " class='$opts->{def}->{class}'" : "";
|
||||
$out .= qq~<p><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}) ? " 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}) ? " 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}) ? " class='$opts->{def}->{class}'" : "";
|
||||
return qq~<textarea rows="$rows" cols="$cols" name="$name"$class>$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', '=', '<>', '>', '<' ], 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 || '';
|
||||
$$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.
|
||||
278
site/glist/lib/GT/SQL/Display/HTML/Relation.pm
Normal file
278
site/glist/lib/GT/SQL/Display/HTML/Relation.pm
Normal file
@@ -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
|
||||
289
site/glist/lib/GT/SQL/Display/HTML/Table.pm
Normal file
289
site/glist/lib/GT/SQL/Display/HTML/Table.pm
Normal file
@@ -0,0 +1,289 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Display::HTML
|
||||
# Author: Scott & Alex
|
||||
# $Id: Table.pm,v 1.26 2004/10/01 21:52:12 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::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.26 $ =~ /(\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);
|
||||
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 (exists $self->{code}->{$col} and (ref $self->{code}->{$col} eq 'CODE')) {
|
||||
$out .= $self->{code}->{$col}->($self, $self->{cols}->{$col}, $values);
|
||||
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 => (defined $field_name ? $field_name : ''),
|
||||
def => $self->{cols}->{$col},
|
||||
value => (defined $value ? $value : '')
|
||||
},
|
||||
($values || {}),
|
||||
$self
|
||||
);
|
||||
$out .= $o if defined $o;
|
||||
$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
|
||||
897
site/glist/lib/GT/SQL/Driver.pm
Normal file
897
site/glist/lib/GT/SQL/Driver.pm
Normal file
@@ -0,0 +1,897 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver
|
||||
# CVS Info :
|
||||
# $Id: Driver.pm,v 2.5 2005/02/25 03:37:29 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.5 $ =~ /(\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, '?';
|
||||
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;
|
||||
521
site/glist/lib/GT/SQL/Driver/MSSQL.pm
Normal file
521
site/glist/lib/GT/SQL/Driver/MSSQL.pm
Normal file
@@ -0,0 +1,521 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::MSSQL
|
||||
# CVS Info :
|
||||
# $Id: MSSQL.pm,v 2.6 2005/06/28 23:36:43 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.
|
||||
for (my $i = 0; $i < @_; $i++) {
|
||||
if (defined $_[$i] and length $_[$i] > 8000) {
|
||||
$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/glist/lib/GT/SQL/Driver/MYSQL.pm
Normal file
226
site/glist/lib/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 :
|
||||
# $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;
|
||||
541
site/glist/lib/GT/SQL/Driver/ORACLE.pm
Normal file
541
site/glist/lib/GT/SQL/Driver/ORACLE.pm
Normal file
@@ -0,0 +1,541 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::ORACLE
|
||||
# CVS Info :
|
||||
# $Id: ORACLE.pm,v 2.1 2005/02/01 02:01:18 jagerman 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;
|
||||
$self->{_lim_rows} = $limit;
|
||||
$self->{_lim_offset} = $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}) {
|
||||
my $begin = $self->{_lim_offset} || 0;
|
||||
my $end = $begin + $self->{_lim_rows};
|
||||
my $i = -1;
|
||||
while (my $rec = $self->{sth}->fetchrow_arrayref) {
|
||||
$i++;
|
||||
next if $i < $begin;
|
||||
last if $i >= $end;
|
||||
push @{$self->{_results}}, [@$rec]; # 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;
|
||||
}
|
||||
|
||||
# -----------------------------------------------------------------------------
|
||||
# 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;
|
||||
643
site/glist/lib/GT/SQL/Driver/PG.pm
Normal file
643
site/glist/lib/GT/SQL/Driver/PG.pm
Normal file
@@ -0,0 +1,643 @@
|
||||
# ==================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::PG
|
||||
# CVS Info :
|
||||
# $Id: PG.pm,v 2.2 2005/02/01 02:00:47 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 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/glist/lib/GT/SQL/Driver/Types.pm
Normal file
191
site/glist/lib/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 :
|
||||
# $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;
|
||||
175
site/glist/lib/GT/SQL/Driver/debug.pm
Normal file
175
site/glist/lib/GT/SQL/Driver/debug.pm
Normal file
@@ -0,0 +1,175 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::debug
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: debug.pm,v 2.0 2004/08/28 03:51:31 jagerman 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;
|
||||
VALUE: for my $val (@args) {
|
||||
SUBSTRING: for my $i (0 .. $#vals) {
|
||||
next SUBSTRING if $i % 2;
|
||||
next VALUE if $vals[$i] =~ s/\?/defined $val ? ( $val =~ m,\D, ? "'".quick_quote($val)."'" : quick_quote($val) ) : 'NULL'/e;
|
||||
}
|
||||
}
|
||||
$query = join '', @vals;
|
||||
}
|
||||
return $query;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
293
site/glist/lib/GT/SQL/Driver/sth.pm
Normal file
293
site/glist/lib/GT/SQL/Driver/sth.pm
Normal file
@@ -0,0 +1,293 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Driver::sth
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: sth.pm,v 2.1 2004/09/30 01:09:46 jagerman 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;
|
||||
}
|
||||
|
||||
$COMPILE{debug} = __LINE__ . <<'END_OF_SUB';
|
||||
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;
|
||||
}
|
||||
return $self->SUPER::debug( "$_[0] from $sub at $file line $line\n" );
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
1;
|
||||
1080
site/glist/lib/GT/SQL/Editor.pm
Normal file
1080
site/glist/lib/GT/SQL/Editor.pm
Normal file
File diff suppressed because it is too large
Load Diff
1079
site/glist/lib/GT/SQL/File.pm
Normal file
1079
site/glist/lib/GT/SQL/File.pm
Normal file
File diff suppressed because it is too large
Load Diff
150
site/glist/lib/GT/SQL/Monitor.pm
Normal file
150
site/glist/lib/GT/SQL/Monitor.pm
Normal file
@@ -0,0 +1,150 @@
|
||||
# ====================================================================
|
||||
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
||||
#
|
||||
# GT::SQL::Monitor
|
||||
# Author: Jason Rhinelander
|
||||
# CVS Info :
|
||||
# $Id: Monitor.pm,v 1.2 2005/04/18 22:10:09 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 SQL escaped and the whole thing surrouned 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 occured
|
||||
# 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},
|
||||
pretty_style => $opts{pretty_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|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) {
|
||||
$table .= join("\t", $opts{html} ? (map html_escape($_), @$_) : @$_) . "\n";
|
||||
}
|
||||
$table .= "</pre>" if $opts{html};
|
||||
}
|
||||
else { # style = 'text'
|
||||
$table = $opts{html} ? '<pre>' : '';
|
||||
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 = $opts{html} ? '<pre>' : '';
|
||||
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
|
||||
$table .= '|';
|
||||
for my $i (0 .. $#$names) {
|
||||
$table .= sprintf " %-$max_width[$i]s |", $opts{html} ? html_escape($names->[$i]) : $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 |", $opts{html} ? html_escape($_->[$i]) : $_->[$i];
|
||||
}
|
||||
$table .= " \n";
|
||||
}
|
||||
$table .= join('+', '', map("-" x ($_ + 2), @max_width), '') . " \n";
|
||||
$table .= $opts{html} ? '</pre>' : '';
|
||||
}
|
||||
$ret{results} = \$table;
|
||||
}
|
||||
else {
|
||||
$ret{results} = "Rows affected: $ret{rows}";
|
||||
}
|
||||
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
1897
site/glist/lib/GT/SQL/Relation.pm
Normal file
1897
site/glist/lib/GT/SQL/Relation.pm
Normal file
File diff suppressed because it is too large
Load Diff
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user