525 lines
17 KiB
Perl
525 lines
17 KiB
Perl
# ==================================================================
|
|
# Gossamer Threads Module Library - http://gossamer-threads.com/
|
|
#
|
|
# GT::Mail::Editor
|
|
#
|
|
# Author: Jason Rhinelander
|
|
# Revision: $Id: Editor.pm,v 1.25 2008/09/23 23:55:26 brewt Exp $
|
|
#
|
|
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
# ==================================================================
|
|
#
|
|
# The backend to a web-based e-mail template editor. See the pod for
|
|
# instructions. This is designed the be used primarily from templates.
|
|
# This module respects local directories on saving, and both local and
|
|
# inheritance directories when loading.
|
|
#
|
|
# Also, any subclasses must be (something)::Editor
|
|
#
|
|
|
|
package GT::Mail::Editor;
|
|
|
|
use strict;
|
|
use vars qw($VERSION $DEBUG $ERRORS @ISA $ATTRIBS);
|
|
|
|
use GT::Base;
|
|
use GT::Template;
|
|
|
|
@ISA = 'GT::Base';
|
|
$DEBUG = 0;
|
|
$VERSION = sprintf "%d.%03d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/;
|
|
|
|
$ERRORS = {
|
|
PARSE => "An error occurred while parsing: %s",
|
|
NODIR => "Template directory not specified",
|
|
BADDIR => "Template directory '%s' does not exist or has the permissions set incorrectly",
|
|
NOFILE => "No template filename specified",
|
|
CANT_CREATE_DIR => "Unable to create directory '%s': %s",
|
|
BADFILE => "Template '%s' does not exist or is not readable",
|
|
SAVEERROR => "Unable to open '%s' for writing: %s",
|
|
LOADERROR => "Unable to open '%s' for reading: %s",
|
|
RECURSION => "Recursive inheritance detected and interrupted: '%s'",
|
|
INVALIDDIR => "Invalid template directory %s",
|
|
INVALIDTPL => "Invalid template %s",
|
|
};
|
|
|
|
$ATTRIBS = {
|
|
dir => '',
|
|
template => '',
|
|
file => '',
|
|
headers => undef,
|
|
extra_headers => '',
|
|
body => ''
|
|
};
|
|
|
|
# GT::Mail::Editor::tpl_save(header => To => $header_to, header => From => $header_from, ..., extra_headers => $extra_headers)
|
|
# ($extra_headers will be parsed). Everything is optional, but you should give something to build headers from.
|
|
# It is not necessary to use To, From, etc. - you can enter them directly in the "extra_headers" field.
|
|
sub tpl_save {
|
|
# Have to extract the three-argument arguments BEFORE getting $self
|
|
my @headers;
|
|
for (my $i = 0; $i < @_; $i++) {
|
|
if ($_[$i] eq 'header') {
|
|
push @headers, (splice @_, $i, 3)[1,2];
|
|
redo;
|
|
}
|
|
}
|
|
my $self = &_get_self;
|
|
for (my $i = 0; $i < @headers; $i += 2) {
|
|
$self->{headers}->{$headers[$i]} = $headers[$i+1];
|
|
}
|
|
if ($self->{extra_headers}) {
|
|
for (split /\s*\n\s*/, $self->{extra_headers}) { # This will weed out any blank lines
|
|
my ($key, $value) = split /\s*:\s*/, $_, 2;
|
|
$self->{headers}->{$key} = $value if $key and $value;
|
|
}
|
|
}
|
|
my $dir;
|
|
if ($self->{dir} and $self->{template}) {
|
|
$dir = "$self->{dir}/$self->{template}/local";
|
|
if (!-d $dir) {
|
|
# Attempt to create the "local" subdirectory
|
|
mkdir($dir, 0777) or return $self->error(CANT_CREATE_DIR => 'FATAL' => $dir => "$!");
|
|
chmod(0777, $dir);
|
|
}
|
|
}
|
|
elsif ($self->{dir}) {
|
|
$dir = $self->{dir};
|
|
}
|
|
|
|
local *FILE;
|
|
$self->{_error} = [];
|
|
if (not $dir) {
|
|
$self->error(NODIR => 'WARN');
|
|
}
|
|
elsif (not -d $dir or not -w $dir) {
|
|
$self->error(BADDIR => WARN => $dir);
|
|
}
|
|
elsif (not $self->{file}) {
|
|
$self->error(NOFILE => 'WARN');
|
|
}
|
|
elsif (-f "$dir/$self->{file}" and not -w _) {
|
|
$self->error(BADFILE => WARN => "$dir/$self->{file}");
|
|
}
|
|
elsif (not open FILE, "> $dir/$self->{file}") {
|
|
$self->error(SAVEERROR => WARN => "$dir/$self->{file}", "$!");
|
|
}
|
|
else { # Everything is good, now we have FILE open to the file.
|
|
$self->debug("Saving $dir/$self->{file}");
|
|
my $headers;
|
|
while (my ($key, $val) = each %{$self->{headers}}) {
|
|
next unless $key and $val;
|
|
$key =~ s/\r?\n//g; $val =~ s/\r?\n//g; # Just in case...
|
|
$headers .= "$key: $val\n";
|
|
}
|
|
print FILE $headers;
|
|
print FILE "" . "\n"; # Blank line
|
|
$self->{body} =~ s/\r\n/\n/g;
|
|
print FILE $self->{body};
|
|
close FILE;
|
|
}
|
|
|
|
if (@{$self->{_error}}) {
|
|
return { error => join("<br>\n", @{$self->{_error}}) };
|
|
}
|
|
else {
|
|
return { success => 1, error => '' };
|
|
}
|
|
}
|
|
|
|
# GT::Mail::Editor::tpl_load(header => To, header => From, header => Subject)
|
|
# In this case, "To", "From" and "Subject" will come to you as header_To,
|
|
# header_From, and header_Subject.
|
|
# What you get back is a hash reference, with either "error" set to an error
|
|
# if something bad happened, or "success" set to 1, and the following template
|
|
# variables:
|
|
#
|
|
# header_To, header_From, header_Subject, header_...
|
|
# => The value of the To, From, Subject, etc. field.
|
|
# -> Only present for individual headers that are requested with "header"
|
|
# extra_headers => A loop of all the other headers with { name => To, From, etc., value => value }
|
|
# body => The body of the e-mail. This will eventually change as this module
|
|
# -> becomes capable of creating e-mails with multiple parts.
|
|
sub tpl_load {
|
|
my $self = &_get_self;
|
|
my %sep_headers;
|
|
for (my $i = 0; $i < @_; $i++) {
|
|
if (lc $_[$i] eq 'header') {
|
|
$sep_headers{$_[++$i]} = 1;
|
|
}
|
|
}
|
|
my $dir;
|
|
if ($self->{dir} and $self->{template} and $self->{file}
|
|
and $self->{template} !~ m[[\\/\x00-\x1f]] and $self->{template} ne '..'
|
|
and $self->{file} !~ m[[\\/\x00-\x1f]]) {
|
|
$dir = "$self->{dir}/$self->{template}";
|
|
if (-f "$dir/local/$self->{file}") {
|
|
$dir .= "/local";
|
|
}
|
|
elsif (!-f "$dir/$self->{file}") {
|
|
my ($tplinfo, %tplinfo);
|
|
while ($tplinfo = GT::Template->load_tplinfo($dir) and my $inherit = $tplinfo->{inheritance}) {
|
|
if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
|
|
$dir = $inherit;
|
|
}
|
|
else {
|
|
$dir .= "/$inherit";
|
|
}
|
|
if (-f "$dir/local/$self->{file}") {
|
|
$dir .= "/local";
|
|
last;
|
|
}
|
|
elsif (-f "$dir/$self->{file}") {
|
|
last;
|
|
}
|
|
if (length $dir > 150 or $tplinfo{$dir}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
|
|
$self->error(RECURSION => WARN => $dir);
|
|
last; # End the loop - there is no more inheritance since we would just be recursing over what we already have
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
my $fh = \do { local *FILE; *FILE };
|
|
$self->{_error} = [];
|
|
my $return = { success => 0, error => '' };
|
|
if ($self->{template} =~ m[[\\/\x00-\x1f]] or $self->{template} eq '..') {
|
|
$self->error(INVALIDDIR => WARN => $self->{template});
|
|
}
|
|
elsif ($self->{file} =~ m[[\\/\x00-\x1f]]) {
|
|
$self->error(INVALIDTPL => WARN => $self->{file});
|
|
}
|
|
elsif (not $dir) {
|
|
$self->error(NODIR => 'WARN');
|
|
}
|
|
elsif (not -d $dir) {
|
|
$self->error(BADDIR => WARN => $dir);
|
|
}
|
|
elsif (not $self->{file}) {
|
|
$self->error(NOFILE => 'WARN');
|
|
}
|
|
elsif (not -r "$dir/$self->{file}") {
|
|
$self->error(BADFILE => WARN => "$dir/$self->{file}");
|
|
}
|
|
elsif (not open $fh, "< $dir/$self->{file}") {
|
|
$self->error(LOADERROR => WARN => "$dir/$self->{file}");
|
|
}
|
|
else { # Everything is good, now we have $fh open to the file.
|
|
$return->{success} = 1;
|
|
$self->load($fh);
|
|
while (my ($name, $val) = each %{$self->{headers}}) {
|
|
if ($sep_headers{$name}) {
|
|
$return->{"header_$name"} = $val;
|
|
}
|
|
else {
|
|
push @{$return->{extra_headers}}, { name => $name, value => $val };
|
|
}
|
|
}
|
|
$return->{body} = $self->{body};
|
|
}
|
|
if ($self->{_error}) {
|
|
$return->{error} = join "<br>\n", @{$self->{_error}};
|
|
}
|
|
return $return;
|
|
}
|
|
|
|
sub tpl_delete {
|
|
my $self = &_get_self;
|
|
|
|
if ($self->{dir} and $self->{template} and $self->{file}
|
|
and $self->{template} !~ m[[\\/\x00-\x1f]] and $self->{template} ne '..'
|
|
and $self->{file} !~ m[[\\/\x00-\x1f]]) {
|
|
my $tpl = "$self->{dir}/$self->{template}/local/$self->{file}";
|
|
if (-f $tpl and not unlink $tpl) {
|
|
return { error => "Unable to remove $tpl: $!" };
|
|
}
|
|
}
|
|
return { success => 1, error => '' };
|
|
}
|
|
|
|
# Loads a template from a filehandle or a file.
|
|
# You must pass in a GLOB reference as a filehandle to be read from.
|
|
# Otherwise, this method will attempt to open the file passed in and then read from it.
|
|
# (the file opened will have directory and template prepended to it).
|
|
sub load {
|
|
my $self = shift;
|
|
my $fh;
|
|
my $file = shift;
|
|
if (ref $file eq 'GLOB' or ref $file eq 'SCALAR' or ref $file eq 'LVALUE') {
|
|
$fh = $file;
|
|
}
|
|
else {
|
|
$fh = \do { local *FILE; *FILE };
|
|
my $dir;
|
|
if ($self->{template}) {
|
|
$dir = "$self->{dir}/$self->{template}";
|
|
if (-f "$dir/local/$file") {
|
|
$dir .= "/local";
|
|
}
|
|
elsif (!-f "$dir/$file") {
|
|
my ($tplinfo, %tplinfo);
|
|
while ($tplinfo = GT::Template->load_tplinfo($dir) and my $inherit = $tplinfo->{inheritance}) {
|
|
if ($inherit =~ m!^(?:[a-zA-Z]:)?[\\/]!) { # Absolute inheritance path
|
|
$dir = $inherit;
|
|
}
|
|
else {
|
|
$dir .= "/$inherit";
|
|
}
|
|
if (-f "$dir/local/$file") {
|
|
$dir .= "/local";
|
|
last;
|
|
}
|
|
elsif (-f "$dir/$file") {
|
|
last;
|
|
}
|
|
if (length $dir > 150 or $tplinfo{$dir}++) { # We've already looked at that directory, or we just have too many relative paths tacked on the end
|
|
$self->error(RECURSION => WARN => $dir);
|
|
last; # End the loop - there is no more inheritance since we would just be recursing over what we already have
|
|
}
|
|
}
|
|
}
|
|
}
|
|
$file = "$dir/$file";
|
|
|
|
open $fh, "< $file" or return $self->error(BADFILE => WARN => $file);
|
|
}
|
|
if (ref $fh eq 'GLOB') {
|
|
while (<$fh>) { # The header
|
|
s/\r?\n$//;
|
|
last if not $_; # An empty line is the end of the headers
|
|
my ($field, $value) = split /:\s*/, $_, 2;
|
|
$self->{headers}->{$field} = $value;
|
|
}
|
|
while (<$fh>) { # The body
|
|
$self->{body} .= $_;
|
|
}
|
|
}
|
|
else {
|
|
(my $header, $self->{body}) = split /\r?\n\r?\n/, $$fh, 2;
|
|
my @h = split /\r?\n/, $header;
|
|
for (@h) {
|
|
my ($field, $value) = split /:\s*/, $_, 2;
|
|
$self->{headers}->{$field} = $value;
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# Creates and returns a $self object. Looks at $_[0] to see if it is already
|
|
# an editor object, and if so uses that. Otherwise it calls new() with @_.
|
|
# Should be called as &_get_self; If called as a class method, the first
|
|
# argument will be removed. So, instead of: 'my $self = shift;' you should
|
|
# use: 'my $self = &_get_self;'
|
|
sub _get_self {
|
|
my $self;
|
|
if (ref $_[0] and substr(ref $_[0], -8) eq '::Editor') { # This will allow any subclass as long as it is something::Editor
|
|
$self = shift;
|
|
}
|
|
elsif (@_ and substr($_[0], -8) eq '::Editor') { # Class methods
|
|
my $class = shift;
|
|
$self = $class->new(@_);
|
|
}
|
|
else {
|
|
$self = __PACKAGE__->new(@_);
|
|
}
|
|
return $self;
|
|
}
|
|
|
|
sub init {
|
|
my $self = shift;
|
|
$self->set(@_);
|
|
tie %{$self->{headers}}, __PACKAGE__ . '::Ordered';
|
|
}
|
|
|
|
|
|
package GT::Mail::Editor::Ordered;
|
|
# Implements a hash that retains the order elements are inserted into it.
|
|
|
|
sub TIEHASH { bless { o => [], h => {}, p => 0 }, $_[0] }
|
|
|
|
sub STORE {
|
|
my ($self, $key, $val) = @_;
|
|
$self->DELETE($key) if exists $self->{h}->{$key};
|
|
$self->{h}->{$key} = $val;
|
|
push @{$self->{o}}, $key;
|
|
}
|
|
|
|
sub FETCH { $_[0]->{h}->{$_[1]} }
|
|
|
|
sub FIRSTKEY {
|
|
my $self = shift;
|
|
$self->{p} = 0;
|
|
$self->{o}->[$self->{p}++]
|
|
}
|
|
|
|
sub NEXTKEY { $_[0]->{o}->[$_[0]->{p}++] }
|
|
|
|
sub EXISTS { exists $_[0]->{h}->{$_[1]} }
|
|
|
|
sub DELETE {
|
|
my ($self, $key) = @_;
|
|
for (0 .. $#{$self->{o}}) {
|
|
if ($self->{o}->[$_] eq $key) {
|
|
splice @{$self->{o}}, $_, 1;
|
|
last;
|
|
}
|
|
}
|
|
delete $self->{h}->{$key};
|
|
}
|
|
sub CLEAR { $_[0] = { o => [], h => {}, p => 0 }; () }
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
GT::Mail::Editor - E-mail template editor
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
Generally used from templates:
|
|
|
|
<%GT::Mail::Editor::tpl_load(
|
|
dir => $template_root,
|
|
template => $template_set,
|
|
file => $filename,
|
|
header => From,
|
|
header => To,
|
|
header => Subject
|
|
)%>
|
|
|
|
<%if error%>
|
|
Unable to load e-mail template: <%error%>
|
|
<%else%>
|
|
From: <input type=text name=header_From value="<%header_From%>">
|
|
To: <input type=text name=header_To value="<%header_To%>">
|
|
Subject: <input type=text name=header_Subject value="<%header_Subject%>">
|
|
Other headers:<br>
|
|
<textarea name=extra_headers>
|
|
<%loop extra_headers%><%name%>: <%value%>
|
|
<%endloop%>
|
|
<%endif%>
|
|
|
|
|
|
- or -
|
|
|
|
|
|
<%GT::Mail::Editor::save(
|
|
dir => $template_root,
|
|
template => $template_set,
|
|
file => $filename,
|
|
header => To => $header_To,
|
|
header => From => $header_From,
|
|
header => Subject => $header_Subject,
|
|
extra_headers => $extra_headers
|
|
)%>
|
|
<%if error%>Unable to save e-mail template: <%error%>
|
|
... Display the above form in here ...
|
|
<%endif%>
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
GT::Mail::Editor is designed to provide a template interface to creating and
|
|
editing a wide variety of e-mail templates. Although not currently supported,
|
|
eventually attachments, HTML, etc. will be supported.
|
|
|
|
=head2 tpl_load - Loads a template (from the templates)
|
|
|
|
Calling GT::Mail::Editor::tpl_load from a template returns variables required to
|
|
display a form to edit the template passed in.
|
|
|
|
=over 4
|
|
|
|
=item dir
|
|
|
|
Defines the base directory of templates.
|
|
|
|
=item template
|
|
|
|
This defines a template set. This is optional. If present, this directory will
|
|
be tacked onto the end of 'dir'. This is simply to provide a more flexible way
|
|
to specify the template directory. For example, if you have 'dir' set to '/a/b'
|
|
and template set to 'c', then the directory '/a/b/c' will be used to save and
|
|
load e-mail templates.
|
|
|
|
=item file
|
|
|
|
Specify the filename of the template inside the directory already specified with
|
|
'dir' and 'template'
|
|
|
|
=item header
|
|
|
|
Multiple "special" headers can be requested with this. The argument following
|
|
each 'header' should be the name of a header, such as "To". Then, in the
|
|
variables returned from tpl_load(), you will have a variable such as 'header_To'
|
|
available, containing the value of the To: field.
|
|
|
|
=back
|
|
|
|
=head2 tpl_save - Save a template
|
|
|
|
=over 4
|
|
|
|
=item dir template file
|
|
|
|
See the entries in L<"tpl_load">
|
|
|
|
=item header
|
|
|
|
Specifies that the two following arguments are the field and value of a header
|
|
field. For example, header => To => "abc@example.com" would specify that the To
|
|
field should be "abc@example.com" (To: abc@example.com).
|
|
|
|
=item extra_headers
|
|
|
|
The value to extra_headers should be a newline-delimited list of headers other
|
|
than those specified with header. These will be parsed, and blank lines skipped.
|
|
|
|
=item body
|
|
|
|
The body of the message. Need I say more? MIME messages are possible by
|
|
inserting them directly into the body, however currently MIME messages cannot
|
|
be created using this editor.
|
|
|
|
=back
|
|
|
|
=head2 load
|
|
|
|
Attempts to load a GT::Mail::Editor object with data passed in. This can take
|
|
either a file handle or a filename. If passing a filename, dir and template
|
|
will be used (if available). You should construct an object with new() prior
|
|
to calling this method.
|
|
|
|
=head2 new
|
|
|
|
Constructs a new GT::Mail::Editor object. This will be done automatically when
|
|
using the template methods L<"tpl_load"> and L<"tpl_save">. Takes the following
|
|
arguments:
|
|
|
|
=over 4
|
|
|
|
=item dir
|
|
|
|
Defines the base directory of templates.
|
|
|
|
=item template
|
|
|
|
This defines a template set. This is optional. If present, this directory will
|
|
be tacked onto the end of 'dir'. This is simply to provide a more flexible way
|
|
to specify the template directory. For example, if you have 'dir' set to '/a/b'
|
|
and template set to 'c', then the directory '/a/b/c' will be used to save and
|
|
load e-mail templates.
|
|
|
|
=back
|
|
|
|
=head1 COPYRIGHT
|
|
|
|
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
|
http://www.gossamer-threads.com/
|
|
|
|
=head1 VERSION
|
|
|
|
Revision: $Id: Editor.pm,v 1.25 2008/09/23 23:55:26 brewt Exp $
|
|
|