saint/discourse-legacysite-perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First pass at adding key files

Browse Source
This commit is contained in:
dsainty
2024-06-17 21:49:12 +10:00
commit aa25e9347f
1274 changed files with 392549 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1275
site/slowtwitch.com/cgi-bin/articles/GT/Mail/BulkMail.pm Normal file
View File

File diff suppressed because it is too large Load Diff

524
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor.pm Normal file
View File

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

267
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor/HTML.pm Normal file
View File

@ -0,0 +1,267 @@
package GT::Mail::Editor::HTML;
use vars qw/$ERROR_MESSAGE/;
use strict;
use bases 'GT::Mail::Editor' => '';
$ERROR_MESSAGE = 'GT::Mail::Editor';
sub display {
# ----------------------------------------------------------------
my ( $self, $tags ) = @_;
my $page = $self->{html_tpl_name};
if ( $self->{fields}{page} and $self->{fields}{page} =~ /^(?:editor|email)_/ ) {
$page = $self->{fields}{page};
}
my $ret = $self->print_page( $page, $tags );
$self->{displayed} = 1;
return $ret;
}
sub message_from_input {
# ----------------------------------------------------------------
my ( $self ) = @_;
$self->set_headers;
# If we have a part ID, this isn't a new text part
my ( $part, $id );
$part = $self->{part};
$part->set( 'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"' );
if ( exists( $self->{fields}{msg} ) ) {
my $msg = $self->{fields}{msg};
$self->urls_to_inlines( $self->{part}, \$msg );
$part->body_data( $msg );
}
}
sub munge_message {
# ----------------------------------------------------------------
my ( $self ) = @_;
my $root_part = $self->{message}->root_part;
# Simple case if the message is not multipart
if ( !$root_part->is_multipart ) {
$self->munge_non_multipart( $root_part );
}
# We have a multipart. First thing we do is look for an alternative part
# to use.
elsif ( my ( $alt ) = $self->{message}->find_multipart( 'alternative' ) ) {
$self->munge_alternative( $alt );
}
else {
$self->munge_other;
}
$self->fix_alt_parts;
$self->fix_related_parts;
$self->delete_empty_multiparts;
my ( $alt_part ) = $self->{message}->find_multipart( 'alternative' );
my @skip = $alt_part->parts;
$self->find_attachments( @skip );
$self->{alt_part} = $alt_part;
$self->{part} = $skip[1];
}
sub html_part {
# ----------------------------------------------------------------
my $self = shift;
return $self->{alt_part}->parts->[1];
}
sub text_part {
# ----------------------------------------------------------------
my $self = shift;
return $self->{alt_part}->parts->[0];
}
sub munge_non_multipart {
# ----------------------------------------------------------------
my ( $self, $root_part ) = @_;
# We need to munge the message into a multipart
my $new_alt = $self->alt_part(
html => $root_part,
charset => $root_part->mime_attr( 'content-type.charset' ),
headers_part => $root_part
);
$root_part->set( 'content-type' => 'multipart/mixed' );
$root_part->parts( $new_alt );
}
sub munge_alternative {
# ----------------------------------------------------------------
my ( $self, $alt_part ) = @_;
my $root_part = $self->{message}->root_part;
# Make anything we can not view an attachment
$self->{message}->move_parts_last(
$root_part,
grep {
$_->content_type ne 'text/plain' and $_->content_type ne 'text/html'
} $alt_part->parts
);
# Anything left is either text or html
my ( $html_part, $text_part );
for ( $alt_part->parts ) {
if ( $_->content_type eq 'text/html' ) {
$html_part = $_;
}
else {
$text_part = $_;
}
}
# If we do not have an editble part we need to make an empty html one
if ( !defined( $text_part ) and !defined( $html_part ) ) {
$html_part = $self->{message}->new_part(
'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"',
-body_data => '<html><body></body></html>'
);
}
my $new_alt = $self->alt_part(
html => $html_part,
text => $text_part,
charset => $self->{fields}{charset}
);
if ( $alt_part == $root_part ) {
$root_part->set( 'content-type' => 'multipart/mixed' );
$self->{message}->delete_parts( $root_part->parts );
$root_part->parts( $new_alt );
}
else {
$self->{message}->replace_part( $alt_part, $new_alt );
}
}
sub munge_other {
# ----------------------------------------------------------------
my ( $self ) = @_;
# Else we need to search through the parts to find the displayable parts
my ( $html_part, $text_part );
for my $part ( $self->{message}->all_parts ) {
if ( !$html_part and $part->content_type eq 'text/html' and $part->mime_attr( 'content-disposition' ) ne 'attachment' ) {
$html_part = $part;
}
elsif ( !$text_part and $part->content_type eq 'text/plain' and $part->mime_attr( 'content-disposition' ) ne 'attachment' ) {
$text_part = $part;
}
last if $html_part and $text_part;
}
# If we do not have an editble part we need to make an empty html one
if ( !defined( $text_part ) and !defined( $html_part ) ) {
$html_part = $self->{message}->new_part(
'content-type' => 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"',
-body_data => '<html><body></body></html>'
);
my $new_alt = $self->alt_part(
html => $html_part,
text => $text_part,
charset => $self->{fields}{charset}
);
$self->{message}->add_parts_start( $self->{message}->root_part, $new_alt );
my $parent = $self->{message}->parent_part( $new_alt );
if ( $parent and $parent->content_type eq 'multipart/related' ) {
$parent->set( 'content-type' => 'multipart/mixed' );
}
}
else {
my $new_alt = $self->alt_part(
html => $html_part,
text => $text_part,
charset => $self->{fields}{charset}
);
my $parent_part = $self->{message}->parent_part( $html_part );
if ( !$parent_part ) { $parent_part = $self->{message}->parent_part( $text_part ) }
if ( $parent_part and $parent_part->content_type eq 'multipart/related' ) {
if ( !$html_part ) {
$parent_part->set( 'content-type' => 'multipart/mixed' );
$self->{message}->add_parts_start( $parent_part, $new_alt );
if ( $text_part ) {
$self->{message}->delete_part( $text_part );
}
}
else {
$self->{message}->replace_part( $parent_part->parts->[0], $new_alt );
}
}
else {
if ( $text_part ) {
$self->{message}->delete_part( $text_part );
}
if ( $html_part ) {
$self->{message}->delete_part( $html_part );
}
$self->{message}->add_parts_start( $self->{message}->root_part, $new_alt );
}
}
}
sub alt_part {
# ----------------------------------------------------------------
my ( $self, %opts ) = @_;
my ( $text, $html, $header_from, $charset ) = @opts{qw/text html headers_part charset/};
my $text_type = 'text/plain; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"';
my $html_type = 'text/html; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"';
if ( defined( $text ) ) {
$text = $self->new_part_from( $text, $text_type );
}
elsif ( defined( $html ) ) {
$text = $self->{message}->new_part(
'content-type' => $text_type,
-body_data => $self->html_to_text( ref( $html ) ? $html->body_data : $html )
);
}
else {
$self->fatal( BADARGS => "Either text or html must be defined" );
}
if ( defined( $html ) ) {
$html = $self->new_part_from( $html, $html_type );
}
elsif ( defined( $text ) ) {
$html = $self->{message}->new_part(
'content-type' => $html_type,
-body_data => $self->text_to_html( $text->body_data )
);
}
# logic error, one must be defined
else {
$self->fatal( BADARGS => "Either text or html must be defined" );
}
my @header = ();
if ( $header_from ) {
@header = map { $_ => [$header_from->get( $_ )] } $header_from->get;
}
return $self->{message}->new_part(
@header,
'content-type' => 'multipart/alternative',
-parts => [$text, $html]
);
}
sub new_part_from {
# ----------------------------------------------------------------
my ( $self, $from, $type ) = @_;
if ( !ref( $from ) ) {
return $self->{message}->new_part(
'content-type' => $type,
-body_data => $from
);
}
elsif ( ref( $from ) ) {
return $self->{message}->new_part(
'content-type' => $type,
-body_data => $from->body_data
);
}
}
1;

147
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Editor/Text.pm Normal file
View File

@ -0,0 +1,147 @@
package GT::Mail::Editor::Text;
use vars qw/$ERROR_MESSAGE/;
use strict;
use bases 'GT::Mail::Editor' => '';
$ERROR_MESSAGE = 'GT::Mail::Editor';
sub display {
# ----------------------------------------------------------------
my ( $self, $tags ) = @_;
my $page = $self->{text_tpl_name};
if ( $self->{fields}{page} and $self->{fields}{page} =~ /^(?:editor|email)_/ ) {
$page = $self->{fields}{page};
}
my $ret = $self->print_page( $page, $tags );
$self->{displayed} = 1;
return $ret;
}
sub message_from_input {
# ----------------------------------------------------------------
my ( $self ) = @_;
$self->set_headers;
# If we have a part ID, this isn't a new text part
my ( $part, $id );
$part = $self->{part};
$part->set( 'content-type' => 'text/plain; charset="'.( $self->{fields}{charset} || 'US-ASCII' ).'"' );
if ( exists( $self->{fields}{msg} ) ) {
$part->body_data( $self->{fields}{msg} );
}
}
sub munge_message {
# ----------------------------------------------------------------
my ( $self ) = @_;
my $root_part = $self->{message}->root_part;
# Simple case if the message is not multipart
my ( $text_part, $html_part, $related_part, $alt_part );
if ( !$root_part->is_multipart ) {
$text_part = $root_part;
}
# We have a multipart. First thing we do is look for an alternative part
# to use.
else {
# First we look for the proper alternative mime parts
$alt_part = ($self->{message}->find_multipart( 'alternative' ))[0];
if ( $alt_part ) {
my @alt_parts = $alt_part->parts;
for ( @alt_parts ) {
if ( $_->content_type eq 'text/plain' ) {
$text_part = $self->{message}->delete_part( $_ );
}
elsif ( $_->content_type eq 'text/html' ) {
$html_part = $self->{message}->delete_part( $_ );
}
}
if ( !$text_part and $html_part ) {
$text_part = $self->{message}->new_part(
'content-type' => 'text/plain',
-body_data => $self->html_to_text( $html_part->body_data )
);
}
elsif ( !$text_part ) {
$text_part = $self->{message}->new_part(
'content-type' => 'text/plain',
-body_data => ''
);
}
# Make anything we can not view an attachment
$self->{message}->move_parts_last(
$root_part,
map {
unless ( $_->is_multipart ) {
$_->set( 'content-disposition' => 'attachment' );
}
$_;
} $alt_part->parts
);
if ( $alt_part == $root_part ) {
$alt_part->set( 'content-type' => 'multipart/mixed' );
}
else {
$self->{message}->delete_part( $alt_part );
}
$self->{message}->add_parts_start( $self->{message}->root_part, $text_part );
}
else {
# Else we can just stick the text part at the beginning
for my $part ( $self->{message}->all_parts ) {
my $disp = $part->mime_attr( 'content-disposition' );
next if $disp and $disp eq 'attachment';
if ( $part->content_type eq 'text/plain' ) {
$text_part = $self->{message}->delete_part( $part );
}
elsif ( $part->content_type eq 'text/html' ) {
$html_part = $self->{message}->delete_part( $part );
}
}
if ( !$text_part and $html_part ) {
$text_part = $self->{message}->new_part(
'content-type' => 'text/plain',
-body_data => $self->html_to_text( $html_part->body_data )
);
}
elsif ( !$text_part ) {
$text_part = $self->{message}->new_part(
'content-type' => 'text/plain',
-body_data => ''
);
}
$self->{message}->add_parts_start( $self->{message}->root_part, $text_part );
}
}
my $parent = $self->{message}->parent_part( $text_part );
if ( $parent and $parent->content_type eq 'multipart/related' ) {
$parent->set( 'content-type' => 'multipart/mixed' );
}
$self->fix_alt_parts;
$self->fix_related_parts;
$self->delete_empty_multiparts;
$self->find_attachments( $text_part );
if ( @{[$self->{message}->all_parts]} == 1 and $self->{message}->root_part->is_multipart ) {
$self->{message}->delete_part( $text_part );
my $root_part = $self->{message}->root_part;
$root_part->set( 'content-type' => 'text/plain' );
$root_part->body_data( $text_part->body_data );
}
$self->{part} = $text_part;
}
sub html_part { return }
sub text_part { return shift()->{part} }
1;

429
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Encoder.pm Normal file
View File

@ -0,0 +1,429 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Mail::Encoder
# Author : Scott Beck
# CVS Info : 087,071,086,086,085
# $Id: Encoder.pm,v 1.44 2008/10/29 23:31:51 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: A general purpose perl interface for encoding data.
#
package GT::Mail::Encoder;
# ==================================================================
# If MIME::Base64 is installed use it - must eval before hand or 5.004_04
# wipes our ISA.
my $have_b64 = eval {
local $SIG{__DIE__};
require MIME::Base64;
import MIME::Base64;
if ($] < 5.005) { local $^W; encode_base64('brok'); }
1;
};
$have_b64 or *encode_base64 = \&gt_old_encode_base64;
my $use_encode_qp;
if ($have_b64 and
$MIME::Base64::VERSION ge 2.16 and
defined &MIME::QuotedPrint::encode_qp and (
not defined &MIME::QuotedPrint::old_encode_qp or
\&MIME::QuotedPrint::encode_qp != \&MIME::QuotedPrint::old_encode_qp
)
) {
$use_encode_qp = 1;
}
# Pragmas
use strict;
use vars qw($VERSION $DEBUG @ISA %EncodeFor $CRLF);
$VERSION = sprintf "%d.%03d", q$Revision: 1.44 $ =~ /(\d+)\.(\d+)/;
$CRLF = "\015\012";
$DEBUG = 0;
@ISA = qw(GT::Base);
my %EncoderFor = (
# Standard...
'7bit' => sub { NBit('7bit', @_) },
'8bit' => sub { NBit('8bit', @_) },
'base64' => \&Base64,
'binary' => \&Binary,
'none' => \&Binary,
'quoted-printable' => \&QuotedPrint,
# Non-standard...
'x-uu' => \&UU,
'x-uuencode' => \&UU,
);
sub new {
# --------------------------------------------------------------------------
my $this = shift;
my $class = ref $this || $this;
my $self = bless {}, $class;
$self->init(@_);
my $encoding = lc($self->{encoding} || '');
defined $EncoderFor{$encoding} or return or return $self->error("NOENCODING", "FATAL");
$self->debug("Set encoding to $encoding") if ($self->{_debug});
$self->{encoding} = $EncoderFor{$encoding};
return $self;
}
sub init {
# --------------------------------------------------------------------------
# $obj->init (%opts);
# -------------------
# Sets the options for the current object.
#
my $self = shift;
my $opt = {};
if (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift }
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
else { return $self->error("BADARGS", "FATAL", "init") }
$self->{_debug} = exists($opt->{debug}) ? $opt->{debug} : $DEBUG;
for my $m (qw(encoding in out)) {
$self->{$m} = $opt->{$m} if defined $opt->{$m};
}
return $self;
}
sub gt_encode {
# --------------------------------------------------------------------------
my $self = shift;
if (!ref $self or ref $self ne 'GT::Mail::Encoder') {
$self = GT::Mail::Encoder->new(@_) or return;
}
$self->{encoding} or return $self->error("NOENCODING", "FATAL");;
return $self->{encoding}->($self->{in}, $self->{out});
}
sub supported { return exists $EncoderFor{pop()} }
sub Base64 {
# --------------------------------------------------------------------------
my ($in, $out) = @_;
my $encoded;
my $nread;
my $buf = '';
# Reading multiples of 57 bytes is recommended by MIME::Base64 as it comes out
# to a line of exactly 76 characters (the max). We use 2299*57 (131043 bytes)
# because it comes out to about 128KB (131072 bytes). Admittedly, this number
# is fairly arbitrary, but should work well for both large and small files, and
# shouldn't be too memory intensive.
my $read_size = 2299 * 57;
if (not ref $in) {
while (1) {
last unless length $in;
$buf = substr($in, 0, $read_size);
substr($in, 0, $read_size) = '';
$encoded = encode_base64($buf, $CRLF);
# Encoding to send over SMTP
$encoded .= $CRLF unless $encoded =~ /$CRLF\Z/; # ensure newline!
$out->($encoded);
}
}
elsif (defined fileno $in) {
while ($nread = read($in, $buf, $read_size)) {
$encoded = encode_base64($buf, $CRLF);
$encoded .= $CRLF unless $encoded =~ /$CRLF\Z/; # ensure newline!
$out->($encoded);
}
}
elsif (ref $in eq 'GLOB') {
die "Glob reference passed in is not an open filehandle";
}
else {
die "Bad arguments passed to Base64, first argument must be a scalar or a filehandle";
}
1;
}
sub Binary {
# --------------------------------------------------------------------------
my ($in, $out) = @_;
if (not ref $in) {
$in =~ s/\015?\012/$CRLF/g;
$out->($in);
}
elsif (defined fileno $in) {
my ($buf, $nread) = ('', 0);
while ($nread = read($in, $buf, 4096)) {
$buf =~ s/\015?\012/$CRLF/g;
$out->($buf);
}
defined ($nread) or return; # check for error
}
elsif (ref $in eq 'GLOB') {
die "Glob reference passed in is not an open filehandle";
}
else {
die "Bad arguments passed to Binary, first argument must be a scalar or a filehandle";
}
1;
}
sub UU {
# --------------------------------------------------------------------------
my ($in, $out, $file) = @_;
my $buf = '';
my $fname = ($file || '');
$out->("begin 644 $fname\n");
if (not ref $in) {
while (1) {
last unless length $in;
$buf = substr($in, 0, 45);
substr($in, 0, 45) = '';
$out->(pack('u', $buf));
}
}
elsif (defined fileno $in) {
while (read($in, $buf, 45)) {
$buf =~ s/\015?\012/$CRLF/g;
$out->(pack('u', $buf))
}
}
elsif (ref $in eq 'GLOB') {
die "Glob reference passed in is not an open filehandle";
}
else {
die "Bad arguments passed to UU, first argument must be a scalar or a filehandle";
}
$out->("end\n");
1;
}
sub NBit {
# --------------------------------------------------------------------------
my ($enc, $in, $out) = @_;
if (not ref $in) {
$in =~ s/\015?\012/$CRLF/g;
$out->($in);
}
elsif (defined fileno $in) {
while (<$in>) {
s/\015?\012/$CRLF/g;
$out->($_);
}
}
elsif (ref $in eq 'GLOB') {
die "Glob reference passed in is not an open filehandle";
}
else {
die "Bad arguments passed to NBit, first argument must be a scalar or a filehandle";
}
1;
}
sub QuotedPrint {
# --------------------------------------------------------------------------
my ($in, $out) = @_;
local $_;
my $ref = ref $in;
if ($ref and not defined fileno($in)) {
if ($ref eq 'GLOB') {
die "Glob reference passed in is not an open filehandle";
}
else {
die "Bad arguments passed to QuotedPrint, first argument must be a scalar or a filehandle";
}
}
$in =~ s/\015?\012/\n/g unless $ref;
while () {
local $_;
if ($ref) {
# Try to get around 32KB at once. This could end up being much larger than
# 32KB if there is a very very long line - up to the length of the line + 32700
# bytes.
$_ = <$in>;
while (my $line = <$in>) {
$_ .= $line;
last if length > 32_700; # Not exactly 32KB, but close enough.
}
last unless defined;
}
else {
# Grab up to just shy of 32KB of the string, plus the following line. As
# above, this could be much longer than 32KB if there is one or more very long
# lines involved.
$in =~ s/^(.{0,32700}.*?(?:\n|\Z))//ms; # Encode somewhere around 32KB at a time
$_ = $1;
last unless defined and length;
}
if ($use_encode_qp) {
$_ = MIME::QuotedPrint::encode_qp($_, $CRLF);
}
else {
s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/eg; # rule #2,#3
s/([ \t]+)$/
join('', map { sprintf("=%02X", ord($_)) }
split('', $1)
)/egm; # rule #3 (encode whitespace at eol)
# rule #5 (lines must be shorter than 76 chars, but we are not allowed
# to break =XX escapes. This makes things complicated :-( )
my $brokenlines = "";
$brokenlines .= "$1=\n"
while s/(.*?^[^\n]{73} (?:
[^=\n]{2} (?! [^=\n]{0,1} $) # 75 not followed by .?\n
|[^=\n] (?! [^=\n]{0,2} $) # 74 not followed by .?.?\n
| (?! [^=\n]{0,3} $) # 73 not followed by .?.?.?\n
))//xsm;
$_ = "$brokenlines$_";
s/\015?\012/$CRLF/g;
}
# Escape 'From ' at the beginning of the line. This is fairly easy - if the
# line is currently 73 or fewer characters, we simply change the F to =46,
# making the line 75 characters long (the max). If the line is longer than 73,
# we escape the F, follow it with "=$CRLF", and put the 'rom ' and the rest of
# the line on the next line - meaning one line of 4 characters, and one of 73
# or 74.
s/^From (.*)/
length($1) <= 68 ? "=46rom $1" : "=46=${CRLF}rom $1"
/emg; # Escape 'From' at the beginning of a line
# The '.' at the beginning of the line is more difficult. The easy case is
# when the line is 73 or fewer characters - just escape the initial . and we're
# done. If the line is longer, the fun starts. First, we escape the initial .
# to =2E. Then we look for the first = in the line; if it is found within the
# first 3 characters, we split two characters after it (to catch the "12" in
# "=12") otherwise we split after the third character. We then add "=$CRLF" to
# the current line, and look at the next line; if it starts with 'From ' or a
# ., we escape it - and since the second line will always be less than 73
# characters long (since we remove at least three for the first line), we can
# just escape it without worrying about splitting the line up again.
s/^\.([^$CRLF]*)/
if (length($1) <= 72) {
"=2E$1"
}
else {
my $ret = "=2E";
my $match = $1;
my $index = index($match, '=');
my $len = $index >= 2 ? 2 : $index + 3;
$ret .= substr($match, 0, $len);
substr($match, 0, $len) = '';
$ret .= "=$CRLF";
substr($match, 0, 1) = "=46" if substr($match, 0, 5) eq 'From ';
substr($match, 0, 1) = "=2E" if substr($match, 0, 1) eq '.';
$ret .= $match;
$ret
}
/emg;
$out->($_);
last unless $ref or length $in;
}
return 1;
}
sub gt_old_encode_base64 {
# --------------------------------------------------------------------------
my $eol = $_[1];
$eol = "\n" unless defined $eol;
my $res = pack("u", $_[0]);
$res =~ s/^.//mg; # Remove first character of each line
$res =~ tr/\n//d; # Remove newlines
$res =~ tr|` -_|AA-Za-z0-9+/|;
# Fix padding at the end
my $padding = (3 - length($_[0]) % 3) % 3;
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
# Break encoded string into lines of no more than 76 characters each
if (length $eol) {
$res =~ s/(.{1,76})/$1$eol/g;
}
$res;
}
1;
__END__
=head1 NAME
GT::Mail::Encoder - MIME Encoder
=head1 SYNOPSIS
open IN, 'decoded.txt' or die $!;
open OUT, '>encoded.txt' or die $!;
if (GT::Mail::Encoder->supported ('7bit')) {
GT::Mail::Encoder->decode (
debug => 1,
encoding => '7bit',
in => \*IN,
out => sub { print OUT $_[0] }
) or die $GT::Mail::Encoder::error;
}
else {
die "Unsupported encoding";
}
close IN;
close OUT;
=head1 DESCRIPTION
GT::Mail::Encoder is a MIME Encoder implemented in perl. It will try to use
the C extension for encoding Base64. If the extension is not there
it will do it in perl (slow!).
=head2 Encoding a stream
The new() constructor and the supported() class method are the only methods that
are public in the interface. The new() constructor takes a hash of params.
The supported() method takes a single string, the name of the encoding you want
to encode and returns true if the encoding is supported and false otherwise.
=over 4
=item debug
Set debugging level. 1 or 0.
=item encoding
Sets the encoding used to encode.
=item in
Set to a file handle or IO handle.
=item out
Set to a code reference, the decoded stream will be passed in at the first
argument for each chunk encoded.
=back
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Encoder.pm,v 1.44 2008/10/29 23:31:51 brewt Exp $

672
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Message.pm Normal file
View File

@ -0,0 +1,672 @@
# ====================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Mail::Message
# Author: Scott Beck
# CVS Info : 087,068,085,094,083
# $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ====================================================================
#
package GT::Mail::Message;
use strict;
use vars qw/$ATTRIBS $CRLF/;
use bases 'GT::Base' => '';
$ATTRIBS = {
root_part => undef,
debug => 0
};
$CRLF = "\012";
sub init {
# --------------------------------------------------------------------------
# Init called from GT::Base
my $self = shift;
$self->set( @_ );
if ( !defined( $self->{root_part} ) ) {
$self->{root_part} = new GT::Mail::Parts;
}
$self->{parts} = _get_parts( $self->{root_part} );
}
sub delete_part {
# --------------------------------------------------------------------------
# Deletes the given part from the email
#
my ( $self, $part ) = @_;
die "Can't delete top level part" if $part == $self->{root_part};
$self->_link;
# We must remove it from the flat list of parts
$self->_delete_part( $part );
# Now we must relink our list
$self->_link;
return $part;
}
sub move_part_before {
# --------------------------------------------------------------------------
# Move a part before another part. The first argument is the part to move
# before, the second is the part to move. No moving the top level part.
#
my ( $self, $before_part, $part ) = @_;
die "Can't move part before the top part" if $before_part == $self->{root_part};
die "Can't move top part" if $part == $self->{root_part};
if ( !$self->_part_in_message( $before_part ) or !$self->_part_in_message( $part ) ) {
die "All parts specified must be in the MIME message";
}
# First remove the part
$self->_delete_part( $part );
# Now we add
$self->add_part_before( $before_part, $part );
}
sub move_part_after {
# --------------------------------------------------------------------------
# Move a part after another part. The first argument is the part to move
# after, the second is the part to move. No moving the top level part.
#
my ( $self, $after_part, $part ) = @_;
die "Can't move part after the top part" if $after_part == $self->{root_part};
die "Can't move top part" if $part == $self->{root_part};
if ( !$self->_part_in_message( $after_part ) or !$self->_part_in_message( $part ) ) {
die "All parts specified must be in the MIME message";
}
# First remove the part
$self->_delete_part( $part );
# Now we add
$self->add_part_after( $after_part, $part );
}
sub move_part_end {
# --------------------------------------------------------------------------
# Move a part to the end of a multipart part. The first part is the
# multipart part to move it to the end of. The second argument is the part
# to move. No moving the top level part.
#
my ( $self, $parent_part, $part ) = @_;
die "Can't move top part" if $part == $self->{root_part};
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
die "All parts specified must be in the MIME message";
}
# First remove the part to be moved
$self->_delete_part( $part );
# Then we add it back in
$self->add_part_end( $parent_part, $part );
}
sub move_part_beginning {
# --------------------------------------------------------------------------
# Move a part to the beginning of a multipart part. The first part is the
# multipart part to move it to the beginning of. The second argument is the
# part to move. No moving the top level part.
#
my ( $self, $parent_part, $part ) = @_;
die "Can't move top part" if $part == $self->{root_part};
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
die "All parts specified must be in the MIME message";
}
# First remove the part to be moved
$self->_delete_part( $part );
# Then we add it back in
$self->add_part_beginning( $parent_part, $part );
}
sub replace_part {
# --------------------------------------------------------------------------
# Replace a part with another part
#
my ( $self, $old_part, $new_part ) = @_;
$self->_link;
splice( @{$self->{parts}}, $old_part->{id}, 1, $new_part );
$self->_link;
}
sub add_part_before {
# --------------------------------------------------------------------------
# Adds a part before the given part. The first argument is the part object
# to add the part before. the second argument is the part to add.
#
my ( $self, $before_part, $part ) = @_;
$self->_link;
die "Can't add part before the top level part" if $before_part == $self->{root_part};
my $parent_id = $before_part->{parent_id};
if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
die "The part's parent must exist and must be a multipart";
}
splice( @{$self->{parts}}, $before_part->{id}, 0, $part );
my $parent_part = $self->{parts}[$parent_id];
$parent_part->add_parts_before( $before_part->{id}, $part );
$self->_link;
}
sub add_part_after {
# --------------------------------------------------------------------------
# Adds a part after the given part. The first argument is the part object
# to add the part after. the second argument is the part to add.
#
my ( $self, $after_part, $part ) = @_;
$self->_link;
die "Can't add part after the top level part" if $after_part == $self->{root_part};
my $parent_id = $after_part->{parent_id};
if ( !defined $parent_id or !$self->{parts}[$parent_id]->is_multipart ) {
die "The part's parent must exist and must be a multipart";
}
splice( @{$self->{parts}}, $after_part->{id} + 1, 0, $part );
my $parent_part = $self->{parts}[$parent_id];
$parent_part->add_parts_after( $after_part->{id}, $part );
$self->_link;
}
sub add_part_beginning {
# --------------------------------------------------------------------------
# Adds a part at the beginning of the given multipart part. The first
# argument is the part object to add the part before. the second argument is
# the part to add.
#
my ( $self, $parent_part, $part ) = @_;
$self->_link;
my $parent_id = $parent_part->{id};
if ( !$self->{parts}[$parent_id]->is_multipart ) {
die "The parent part must be a multipart";
}
splice( @{$self->{parts}}, $parent_id + 1, 0, $part );
$parent_part->add_part_before( $part->{parts}[0]{id}, $part );
$self->_link;
}
sub add_part_end {
# --------------------------------------------------------------------------
# Adds a part at the end of the given multipart part. The first argument is
# the part object to add the part at the end of. the second argument is the
# part to add. The first argument must be a multipart part or a fatal error
# occurs.
#
my ( $self, $parent_part, $part ) = @_;
$self->_link;
my $parent_id = $parent_part->{id};
if ( !$self->{parts}[$parent_id]->is_multipart ) {
die "The parent part must be a multipart";
}
splice( @{$self->{parts}}, $parent_id + @parts, 0, $part );
$parent_part->parts( $part );
$self->_link;
}
sub move_part_to_position {
# --------------------------------------------------------------------------
# Move a part to a position within another multipart part. The first
# argument is the part to move within, the second argument is the part to
# move and the final argument is the position within those parts to move it
# in.
#
my ( $self, $parent_part, $part, $pos ) = @_;
die "Can't move top part" if $part == $self->{root_part};
if ( !$self->_part_in_message( $parent_part ) or !$self->_part_in_message( $part ) ) {
die "All parts specified must be in the MIME message";
}
$self->_link;
my $parent_id = $parent_part->{id};
if ( !$self->{parts}[$parent_id]->is_multipart ) {
die "The parent part must be a multipart";
}
splice( @{$self->{parts}}, $parent_id + $pos, $part );
$self->_link;
}
sub get_part_by_id {
# --------------------------------------------------------------------------
# Method to retrieve a part object by it's id
#
my ( $self, $id ) = @_;
return $self->{parts}[$id];
}
sub new_part {
# --------------------------------------------------------------------------
# Method to easily create a part object. All the header fields can be passed
# in as a hash. If the key "body_data" the value will be set as the parts
# body rather than a header field.
#
my ( $self, @opts ) = @_;
my $part = new GT::Mail::Parts;
while ( my ( $key, $val ) = ( shift( @opts ), shift( @opts ) ) ) {
if ( $key eq 'body_data' ) {
$part->body_data( $val );
}
elsif ( $key eq 'body_handle' ) {
$part->body_handle( $val );
}
elsif ( $key eq 'body_path' ) {
$part->body_path( $val );
}
else {
$part->set( $key => $val );
}
}
return $part;
}
sub all_parts {
# --------------------------------------------------------------------------
# my @parts = $obj->all_parts;
# ----------------------------
# Returns a list of all the part object for the current parsed email.
# If the email is not multipart this will be just the header part.
#
return @{shift()->{parts}}
}
sub size {
# --------------------------------------------------------------------------
# Returns the total size of an email. Call this method after the email has
# been parsed.
#
my $self = shift;
(@{$self->{parts}} > 0) or return;
my $size = 0;
foreach (@{$self->{parts}}) {
$size += $_->size;
}
return $size;
}
sub as_string {
# --------------------------------------------------------------------------
# Returns the entire email as a sting.
#
my ( $self ) = @_;
$GT::Mail::Encoder::CRLF = $CRLF;
my $out;
$$out = ' ' x 50*1024;
$self->debug ("\n\t--------------> Creating email") if $self->{_debug};
# Need the head to contiue
$self->{root_part} or die "No root part!";
$self->{root_part}->set( 'MIME-Version' => '1.0' ) unless $self->{root_part}->get( 'MIME-Version' );
my $bound = $self->{root_part}->multipart_boundary;
# If the message has parts
if ( @{$self->{root_part}->{parts}} > 0 ) {
$self->debug( "Creating multipart email." ) if $self->{_debug};
$self->_build_multipart_head( $out );
}
# Else we are single part and have either a body IO handle or the body is in memory
else {
$self->debug( "Creating singlepart email." ) if $self->{_debug};
$self->_build_singlepart_head( $out );
}
# If we have parts go through all of them and add them.
if ( @{$self->{root_part}->{parts}} > 0 ) {
my $num_parts = $#{$self->{root_part}->{parts}};
for my $num ( 0 .. $num_parts ) {
next unless $self->{root_part}->{parts}->[$num];
$self->debug( "Creating part ($num)." ) if $self->{_debug};
$self->_build_parts( $out, $self->{root_part}->{parts}->[$num] );
if ( $num_parts == $num ) {
$self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
$$out .= $CRLF . '--' . $bound . '--' . $CRLF;
}
else {
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
$$out .= $CRLF . '--' . $bound . $CRLF;
}
}
}
# Add the epilogue if we are multipart
if ( @{$self->{root_part}->{parts}} > 0 ) {
my $epilogue = join( '', @{$self->{root_part}->epilogue || []} ) || '';
$epilogue =~ s/\015?\012//g;
$self->debug( "Setting epilogue to ($epilogue)" ) if $self->{_debug};
$$out .= $epilogue . $CRLF . $CRLF if $epilogue;
}
$self->debug( "\n\t<-------------- Email created." ) if $self->{_debug};
return $$out;
}
sub _build_multipart_head {
# --------------------------------------------------------------------------
# Private method to build a multipart header.
#
my ( $self, $out ) = @_;
my $bound = $self->{root_part}->multipart_boundary;
my $encoding = $self->{root_part}->suggest_encoding;
$self->debug( "Setting encoding to ($encoding)." ) if ( $self->{debug} );
$self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
$bound or $bound = "---------=_" . scalar (time) . "-$$-" . int(rand(time)/2);
# Set the content boundary unless it has already been set
my $c = $self->{root_part}->get( 'Content-Type' );
if ( $c !~ /\Q$bound/i ) {
if ( $c and lc( $c ) !~ /boundary=/ ) {
$c =~ /multipart/ or $c = 'multipart/mixed';
$self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{debug};
$self->{root_part}->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
}
else {
$self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
$self->{root_part}->set( 'Content-Type' => qq!multipart/mixed; boundary="$bound"! )
}
}
my $preamble = join( '', @{$self->{root_part}->preamble || []} ) || "This is a multi-part message in MIME format.";
$preamble =~ s/\015?\012//g;
$self->debug( "Setting preamble to ($preamble)." ) if ( $self->{_debug} );
( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
$$out .= $head . $CRLF . $preamble . $CRLF . $CRLF . '--' . $bound . $CRLF;
return 1;
}
sub _build_singlepart_head {
# --------------------------------------------------------------------------
# Private method to build a single part header.
#
my ( $self, $out ) = @_;
my $encoding = $self->{root_part}->suggest_encoding;
$self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
$self->{root_part}->set( 'Content-Transfer-Encoding' => $encoding );
( my $head = $self->{root_part}->header_as_string ) =~ s/\015?\012/$CRLF/g;
$$out .= $head . $CRLF;
$self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
GT::Mail::Encoder->gt_encode (
debug => $self->{_debug},
encoding => $encoding,
in => $self->{root_part}->body_as_string,
out => $out
) or return;
# Must seek to the beginning for additional calles
return 1;
}
sub _build_parts {
# --------------------------------------------------------------------------
# Private method that builds the parts for the email.
#
my ($self, $out, $part) = @_;
# Need the head to contiue
$self->{root_part} or die "No root part!";
my ( $body, $encoding, $bound );
$bound = $part->multipart_boundary;
# Find the encoding for the part and set it.
$encoding = $part->suggest_encoding;
$self->debug( "Setting encoding to ($encoding)." ) if $self->{_debug};
$part->set( 'Content-Transfer-Encoding' => $encoding );
# If the message has parts and has a multipart boundary
if ( @{$part->{parts}} > 0 and $bound ) {
$self->debug( "Part is multpart." ) if $self->{_debug};
# Set the multipart boundary
$self->debug( "Setting boundary to ($bound)." ) if $self->{_debug};
# Set the content boundary unless it has already been set
my $c = $part->get( 'Content-Type' );
if ( $c ) {
$self->debug( qq|Setting content type to ($c; boundary="$bound")| ) if $self->{_debug};
$part->set( 'Content-Type' => $c . qq|; boundary="$bound"| );
}
else {
$self->debug( "Setting multipart boundary to ($bound)." ) if $self->{_debug};
$part->set( 'Content-Type' => qq!multipart/mixed; boundary="$bound"! );
}
my $preamble = join( '' => @{ $part->preamble || [] } ) || "This is a multi-part message in MIME format.";
$preamble =~ s/\015?\012//g;
$self->debug( "Setting preamble to ($preamble)." ) if $self->{_debug};
( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
$$out .= $head . $CRLF . $preamble . $CRLF . '--' . $bound . $CRLF;
}
else {
$self->debug( "Part is single part." ) if $self->{_debug};
( my $head = $part->header_as_string ) =~ s/\015?\012/$CRLF/g;
$$out .= $head . $CRLF;
# Set the body only if we have one. We would not have one on the head an multipart
$self->debug( "Encoding body with ($encoding)." ) if $self->{_debug};
GT::Mail::Encoder->gt_encode(
encoding => $encoding,
debug => $self->{_debug},
in => $part->body_as_string,
out => $out
) or return;
}
# Add the rest of the parts
if ( @{$part->{parts}} > 0 ) {
$self->debug( "Part has parts." ) if $self->{_debug};
my $num_parts = $#{$part->{parts}};
for my $num ( 0 .. $num_parts ) {
next unless $part->{parts}->[$num];
$self->debug( "Creating part ($num)." ) if $self->{_debug};
$self->_build_parts( $out, $part->{parts}->[$num] ) or return;
if ( $bound ) {
if ( $num_parts == $num ) {
$self->debug( "Boundary\n\t--$bound--" ) if $self->{_debug};
$$out .= $CRLF . '--' . $bound . '--' . $CRLF;
}
else {
$self->debug( "Boundary\n\t--$bound" ) if $self->{_debug};
$$out .= $CRLF . '--' . $bound . $CRLF;
}
}
}
}
# Maybe done!
return 1;
}
sub _delete_part {
# --------------------------------------------------------------------------
# Internal method to delete a part
my ( $self, $part ) = @_;
# We must remove it from it's parent
my $parent = $self->{parts}[$part->{parent_id}];
for ( 0 .. $#{$parent->{parts}} ) {
if ( $parent->{parts}[$_]{id} == $part->{id} ) {
splice( @{$parent->{parts}}, $_, 1 );
last;
}
}
# We must remove it from the flat list of parts
return splice( @{$self->{parts}}, $part->{id}, 1 );
}
sub _part_in_message {
# --------------------------------------------------------------------------
# Internal method to find out weather a part is in the current message
my ( $self, $part ) = @_;
for ( @{$self->{parts}} ) {
return 1 if $_ == $part;
}
return;
}
sub _link {
# --------------------------------------------------------------------------
# Creats part ids and links the children to the parrents. Called
# When parts arer modified
#
my ( $self ) = @_;
# Creates ids to keep track of parts with.
for ( 0 .. $#{$self->{parts}} ) {
$self->{parts}[$_]{id} = $_;
}
_link_ids( $self->{root_part} );
}
sub _links_ids {
# --------------------------------------------------------------------------
# Internal function to link all children to their parents with the parent id.
# RECURSIVE
#
my ( $part, $parent_id ) = @_;
for ( @{$part->{parts}} ) {
_link_ids( $_, $part->{id} );
}
$part->{parent_id} = $parent_id;
}
sub _get_parts {
# --------------------------------------------------------------------------
# Recursive function to get a flat list of all the parts in a part structure
#
my ( $part, $parts ) = @_;
$parts ||= [];
for ( @{$part->{parts}} ) {
push @$parts, @{_get_parts( $_, $parts )};
}
return $parts;
}
1;
__END__
=head1 NAME
GT::Mail::Message - Encapsolates an email message.
=head1 SYNOPSIS
use GT::Mail::Message;
# Get a GT::Mail::Message object from the parser
use GT::Mail::Parse;
my $parser = new GT::Mail::Parse( in_file => "myemail.eml" );
my $message = $parser->parse;
# Get the top level part
my $root_part = $message->root_part;
# Replace the first part with a new part
$message->replace_part( $root_part, $message->new_part(
to => 'scott@gossamer-threads.com',
from => 'alex@gossamer-threads.com',
'content-type' => 'text/plain',
body_data => 'Hi Scott, how are you?!'
);
# Add a part at the end
my $end_part = $message->new_part(
'content-type' => 'image/gif',
body_path => 'myimage.jpg'
);
$message->add_part_end( $root_part, $end_part );
# Move the first part in the top part to after the end part
$message->move_part_after( $root_part->parts->[0], $end_part );
# Print the mime message
print $message->to_string;
=head1 DESCRIPTION
GT::Mail::Message encapsolates a mime message which consists of
L<GT::Mail::Parts> object. This module provides methods to change,
move, remove, and access these parts.
=head2 Creating a new GT::Mail::Message object
Usually you will get a GT::Mail::Message object by call the parse method
in L<GT::Mail::Parse>.
my $message = $parser->parse;
You may also call new on this class specifying the top level part and or
a debug level.
my $message = new GT::Mail::Message(
root_part => $part,
debug => 1
);
=head2 Creating a new Part
You can create a part by calling new on L<GT::Mail::Parts> directly
my $part = new GT::Mail::Parts;
$part->set( 'content-type' => 'image/gif' );
$part->body_path( 'myimage.gif' );
or you can call a method in this module to get a new part
my $part = $message->new_part(
'content-type' => 'image/gif',
body_path => 'myimage.gif'
);
This method is a wraper on a combination of new() and some other
supporting methods in L<GT::Mail::Parts> such as body_path(). Anything
that is not B<body_path>, B<body_data>, or B<body_handle> is treated
as header values.
=head2 Manipulating Parts
A MIME message is just a format for storing a tree structure. We provide
tree-like methods to manipulate parts. All the method for manipulating
parts take the part object(s) as arguments. We do this so you do not need
to know how the tree is tracked internally.
=head2 Accessing Parts
More to come!
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Message.pm,v 1.14 2004/01/13 01:35:17 jagerman Exp $

829
site/slowtwitch.com/cgi-bin/articles/GT/Mail/POP3.pm Normal file
View File

@ -0,0 +1,829 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Mail::POP3
# Author: Scott Beck
# CVS Info : 087,071,086,086,085
# $Id: POP3.pm,v 1.57 2008/09/23 23:55:26 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
#
# Description: A general purpose perl interface to a POP3 server.
#
package GT::Mail::POP3;
# ==================================================================
# Pragmas
use strict;
use vars qw!$VERSION $DEBUG $ERROR $CRLF @ISA $ERRORS $ATTRIBS!;
# Constants
use constants TIMEOUT => 0.01; # The timeout used on selects.
# Internal modules
use GT::Base;
use GT::Socket::Client;
use GT::Mail::Parts;
use GT::Mail::Parse;
# System modules
use Fcntl qw/O_NONBLOCK F_SETFL F_GETFL/;
use POSIX qw/EAGAIN EINTR/;
# Silence warnings
$GT::Mail::Parse::error = '';
@ISA = qw(GT::Base);
$DEBUG = 0;
$CRLF = "\r\n";
$| = 1;
$ATTRIBS = {
host => undef,
port => undef,
user => undef,
pass => undef,
auth_mode => 'PASS',
debug => 0,
blocking => 0,
ssl => 0,
timeout => 30, # The connection timeout (passed to GT::Socket::Client)
data_timeout => 5, # The timeout to read/write data from/to the connected socket
};
$ERRORS = {
NOTCONNECTED => "You are calling %s and you have not connected yet!",
CANTCONNECT => "Could not connect to POP3 server: %s",
READ => "Unble to read from socket, reason (%s). Read: (%s)",
WRITE => "Unable to write %s length to socket. Wrote %s, Error(%s)",
NOEOF => "No EOF or EOL found. Socket locked.",
ACTION => "Could not %s. Server said: %s",
NOMD5 => "Unable to load GT::MD5 (required for APOP authentication): %s",
PARSE => "An error occurred while parsing an email: %s",
LOGIN => "An error occurred while logging in: %s",
OPEN => "Could not open (%s) for read and write. Reason: %s",
};
sub head_part {
# --------------------------------------------------------
# my $head = $obj->head_part($num);
# ---------------------------------
# This method takes one argument, the number message to
# parse. It returns a GT::Mail::Parts object that has
# only the top level head part parsed.
#
my ($self, $num) = @_;
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->head_part ($msg_num)');
my $io = '';
$self->top($num, sub { $io .= $_[0] }) or return;
return GT::Mail::Parse->new(debug => $self->{_debug}, crlf => $CRLF)->parse_head(\$io);
}
sub all_head_parts {
# --------------------------------------------------------
# my @heads = $obj->all_head_parts;
# ---------------------------------
# This does much the same as head_part() but returns an
# array of GT::Mail::Parts objects, each one only having
# the head of the message parsed.
#
my $self = shift;
my @head_parts;
for (1 .. $self->stat) {
my $part = $self->head_part($_) or return;
push(@head_parts, $part);
}
return wantarray ? @head_parts : \@head_parts;
}
sub parse_message {
# --------------------------------------------------------
# my $mail = $obj->parse_message($num);
# -------------------------------------
# This method returns a GT::Mail object. It calles parse
# for the message number specified before returning the
# object. You can retrieve the different parts of the
# message through the GT::Mail object. If this method
# fails you should check $GT::Mail::error.
#
my ($self, $num) = @_;
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->parse_message($msg_num)');
my $io = $self->retr($num) or return;
my $parser = new GT::Mail::Parse(debug => $self->{_debug}, in_string => $io, crlf => $CRLF);
$parser->parse or return $self->error("PARSE", "WARN", $GT::Mail::Parse::error);
return $parser;
}
sub init {
# --------------------------------------------------------
# Initilize the POP box object.
#
my $self = shift;
$self->set(@_);
for (qw/user pass host/) {
(defined($self->{$_})) or return $self->error('BADARGS', 'FATAL', "CLASS->new(%ARGS); The '$_' key in the hash must exists");
}
$self->{_debug} = exists($self->{debug}) ? delete($self->{debug}) : $DEBUG;
# Can be either PASS or APOP depending on login type.
$self->{auth_mode} ||= 'PASS';
return $self;
}
sub send {
# --------------------------------------------------------
# Send a message to the server.
#
my ($self, $msg) = @_;
unless (defined $msg and length $msg) {
$self->debug("Sending blank message!") if $self->{_debug};
return;
}
# Get the socket and end of line.
my $s = $self->{sock};
defined($s) and defined fileno($s) or return $self->error("NOTCONNECTED", "WARN", "send()");
# Print the message.
$self->debug("--> $msg") if $self->{_debug};
$s->write($msg . $CRLF);
$self->getline(my $line) or return;
$line =~ s/$CRLF//o if $line;
$line ||= 'Nothing sent back';
$self->{message} = $line;
$self->debug("<-- $line") if $self->{_debug};
return $line;
}
sub getline {
# --------------------------------------------------------
# Read a line of input from the server.
#
my ($self) = @_;
my $got_cr;
my $safety;
my $s = $self->{sock};
$s->readline($_[1]);
return 1;
}
sub getall {
# --------------------------------------------------------
# Get all pending output from the server.
#
my ($self) = @_;
$_[1] = '';
my $l = 0;
my $safety;
my $s = $self->{sock};
if ($self->{blocking}) {
while (<$s>) {
last if /^\.$CRLF/o;
s/^\.//; # Lines starting with a . are doubled up in POP3
$_[1] .= $_;
}
}
else {
my $save = $s->read_size;
$s->read_size(1048576);
$s->readalluntil("\n.$CRLF", $_[1], ".$CRLF");
$s->read_size($save);
$_[1] =~ s/\n\.\r?\n$/\n/; # Remove the final . at the end of the e-mail
$_[1] =~ s/^\.//mg; # Remove the initial '.' from any lines beginning with .
}
return 1;
}
sub connect {
# --------------------------------------------------------
# Connect to the server.
#
my $self = shift;
my ($s, $iaddr, $msg, $paddr, $proto);
$self->debug("Attempting to connect .. ") if ($self->{_debug});
$self->{blocking} = 1 if $self->{ssl};
$self->{port} ||= $self->{ssl} ? 995 : 110;
# If there was an existing connection, it'll be closed here when we reassign
$self->{sock} = GT::Socket::Client->open(
port => $self->{port},
host => $self->{host},
max_down => 0,
timeout => $self->{timeout},
non_blocking => !$self->{blocking},
select_time => TIMEOUT,
read_wait => $self->{data_timeout},
ssl => $self->{ssl},
debug => $self->{_debug}
) or return $self->error("CANTCONNECT", "WARN", GT::Socket::Client->error);
$self->debug('Connected to ' . $self->{host} . ' on port ' . $self->{port} . ($self->{ssl} ? ' via SSL' : '')) if $self->{_debug};
# Get server welcoming.
$self->getline($msg) or return;
# Store this - it's needed for APOP authentication
$self->{msg_id}= $1 if ($msg =~ /(<[\w\d\-\.]+\@[\w\d\-\.]+>)/);
$self->debug("Going to login") if $self->{_debug};
return $self->login();
}
sub login {
# --------------------------------------------------------
# Login either using APOP or regular.
#
my $self = shift;
($self->{auth_mode} eq 'APOP' && $self->{msg_id}) ? $self->login_apop : $self->login_pass;
}
sub login_apop {
# --------------------------------------------------------
# Login using APOP.
#
my $self = shift;
my ($hash, $count, $line);
{
local $SIG{__DIE__};
eval { require GT::MD5; 1 } or return $self->error('NOMD5', 'WARN', $@);
}
$self->debug("Attempting to log in via APOP ... ") if $self->{_debug};
$hash = GT::MD5::md5_hex($self->{msg_id} . $self->{pass});
local ($_) = $self->send('APOP ' . $self->{user} . ' ' . $hash) or return;
substr($_, 0, 1) eq '+' or return $self->error("LOGIN", "WARN", "APOP Login failed: $_");
if (/^\+OK \S+ has (\d+) /i) {
$self->{count} = $1;
}
elsif (uc substr($_, 0, 3) ne '+OK') {
return $self->error('LOGIN', 'WARN', $_);
}
$self->{state} = 'TRANSACTION';
$self->stat() or return;
$self->debug("APOP Login successful.") if $self->{_debug};
return (($self->{count} == 0) ? '0E0' : $self->{count});
}
sub login_pass {
# --------------------------------------------------------
# Login using clear text authentication.
#
my $self = shift;
my ($line);
$self->debug("Attempting to log in via clear text ... ") if $self->{_debug};
# Enter username.
local($_) = $self->send('USER ' . $self->{user}) or return;
substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "USER POP Login failed: $_");
# Enter password.
$_ = $self->send('PASS ' . $self->{pass}) or return;
substr($_, 0, 1) eq '+' or return $self->error('LOGIN', 'WARN', "PASS POP Login failed: $_");
# Ok, get total number of message, and pop box status.
if (/^\+OK \S+ has (\d+) /i) {
$self->{count} = $1;
}
elsif (uc substr($_, 0, 3) ne '+OK') {
return $self->error('LOGIN', 'WARN', $_);
}
$self->stat() or return;
$self->debug("Login successful.") if $self->{_debug};
return $self->{count} == 0 ? '0E0' : $self->{count};
}
sub top {
# --------------------------------------------------------
# Get the header of a message and the next x lines (optional).
#
my ($self, $num, $code) = @_;
defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->head($msg_num);. No message number passed to head.');
$self->debug("Getting head of message $num ... ") if $self->{_debug};
local($_) = $self->send("TOP $num 0") or return;
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "TOP $num 0", "($_)");
my ($tp, $header);
$self->getall($header);
if (substr($header, 0, 1) eq '>') {
substr($header, 0, index($header, $CRLF) + 2) = '';
}
# Support broken headers which given unix linefeeds.
if ($header =~ /[^\r]\n/) {
$header =~ s/\r?\n/$CRLF/g;
}
$self->debug("Top of message $num retrieved.") if $self->{_debug};
if ($code and ref $code eq 'CODE') {
$code->($header);
}
else {
return wantarray ? split(/$CRLF/o, $header) : $header;
}
return 1;
}
sub retr {
# --------------------------------------------------------
# Get the entire message.
#
my ($self, $num, $code) = @_;
defined($num) or return $self->error('BADARGS', 'FATAL', '$obj->retr ($msg_numm, $code);');
$self->debug("Getting message $num ... ") if ($self->{_debug});
# Get the size of the message
local ($_) = $self->send("RETR $num") or return;
uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', "RETR $num", $_);
# Retrieve the entire email
my $body = '';
$self->getall($body);
# Qmail puts this wierd header as the first line
if (substr($body, 0, 1) eq '>') {
substr($body, 0, index($body, $CRLF) + 2) = '';
}
# Support broken pop servers that send us unix linefeeds.
if ($body =~ /[^\r]\n/) {
$body =~ s/\r?\n/$CRLF/g;
}
$self->debug("Message $num retrieved.") if $self->{_debug};
if ($code and ref $code eq 'CODE') {
$code->($body);
}
else {
return \$body;
}
return 1;
}
sub last {
my ($self) = @_;
local($_) = $self->send("LAST") or return;
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LAST", $_);
s/^\+OK\s*//i;
return $_;
}
sub message_save {
# --------------------------------------------------------
# Get a message and save it to a file rather then returning.
#
my ($self, $num, $file) = @_;
# Check arguments.
$num or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');
$file or return $self->error("BADARGS", "FATAL", '$obj->message_save ($msg_num, $IO);');
my $io;
if (ref $file) {
$io = $file;
}
else {
$file =~ /^\s*(.+?)\s*$/ and $file = $1;
$io = \do { local *FH; *FH };
open $io, ">$file" or return $self->error("OPENWRITE", "FATAL", $file, "$!");
}
# Get the entire message body.
$self->retr($num, sub { print $io $_[0] });
$self->debug("Message $num saved to '$file'.") if $self->{_debug};
return 1;
}
sub stat {
# --------------------------------------------------------
# Handle a stat command, get the number of messages and size.
#
my $self = shift;
local($_) = $self->send("STAT") or return;
uc substr($_, 0, 3) eq '+OK' or return $self->error('ACTION', 'WARN', 'STAT', $_);
if (/^\+OK (\d+) (\d+)/i) {
$self->{count} = $1;
$self->{size} = $2;
$self->debug("STAT successful - count: $1 size: $2") if $self->{_debug};
}
else {
$self->debug("STAT failed, can't determine count.") if $self->{_debug};
}
return $self->{count} || "0E0";
}
sub list {
# --------------------------------------------------------
# Return a list of messages available.
#
my $self = shift;
my $num = shift || '';
my @messages;
# Broken pop servers that don't like 'LIST '.
my $cmd = ($num eq '') ? 'LIST' : "LIST $num";
local($_) = $self->send($cmd) or return;
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "LIST $num", $_);
if ($num) {
s/^\+OK\s*//i;
return $_;
}
my $msg = '';
$self->getall($msg);
@messages = split /$CRLF/o => $msg;
$self->debug(@messages . " messages listed.") if ($self->{_debug});
if (@messages) {
return wantarray ? @messages : join("", @messages);
}
}
sub rset {
# --------------------------------------------------------
# Reset deletion stat.
#
my $self = shift;
local($_) = $self->send("RSET") or return;
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "RSET", $_);
return 1;
}
sub dele {
# --------------------------------------------------------
# Delete a given message.
#
my ($self, $num) = @_;
$num and $num =~ /^\d+$/ or return $self->error("BADARGS", "FATAL", '$obj->dele ($msg_num)');
local($_) = $self->send("DELE $num") or return;
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "DELE $num", $_);
return 1;
}
sub quit {
# --------------------------------------------------------
# Close the socket.
#
my $self = shift;
$self->send("QUIT") or return;
close $self->{sock};
$self->{sock} = undef;
return 1;
}
sub uidl {
# --------------------------------------------------------
# Returns a list of uidls from the remote server
#
my $self = shift;
my $num = shift;
local $_;
if ($num and !ref $num) {
$_ = $self->send("UIDL $num") or return;
/^\+OK \d+ (.+)$/i or return $self->error("ACTION", "WARN", "UIDL $num", $_);
return $1;
}
my $ret = {};
$_ = $self->send("UIDL") or return;
uc substr($_, 0, 3) eq '+OK' or return $self->error("ACTION", "WARN", "UIDL $num", $_);
my $list = '';
$self->getall($list);
for (split /$CRLF/o => $list) {
if ($num and ref($num) eq 'CODE') {
$num->($_);
}
else {
/^(\d+) (.+)/ and $ret->{$1} = $2;
}
}
return wantarray ? %{$ret} : $ret;
}
sub count {
# --------------------------------------------------------
# Accessor for number of messages waiting.
#
return $_[0]->{count};
}
sub size {
# --------------------------------------------------------
# Accessor for size of messages waiting.
#
return $_[0]->{count};
}
sub last_message {
# --------------------------------------------------------
# Accessor for last server message.
@_ == 2 and $_[0]->{message} = $_[1];
return $_[0]->{message};
}
sub DESTROY {
# --------------------------------------------------------
# Auto close the socket.
#
my $self = shift;
if ($self->{sock} and defined fileno($self->{sock})) {
$self->send("QUIT");
close $self->{sock};
$self->{sock} = undef;
}
$self->debug("POP Object destroyed.") if ($self->{_debug} > 1);
}
1;
__END__
=head1 NAME
GT::Mail::POP3 - Receieve email through POP3 protocal
=head1 SYNOPSIS
use GT::Mail::POP3;
my $pop = GT::Mail::POP3->new(
host => 'mail.gossamer-threads.com',
port => 110,
user => 'someusername',
pass => 'somepassword',
auth_mode => 'PASS',
timeout => 30,
debug => 1
);
my $count = $pop->connect or die $GT::Mail::POP3::error;
for my $num (1 .. $count) {
my $top = $pop->parse_head($num);
my @to = $top->split_field;
if (grep /myfriend\@gossamer-threads\.com/, @to) {
$pop->message_save($num, '/keep/email.txt');
last;
}
}
=head1 DESCRIPTION
GT::Mail::POP3 is a module to check an email account using the POP3 protocol.
Many of the methods are integrated with L<GT::Mail::Parse>.
=head2 new - constructor method
This method is inherited from L<GT::Base>. The argument to this method can be
in the form of a hash or hash ref. As a minimum 'user', 'pass', and 'host' must
be specified.
=over 4
=item debug
Sets the debugging level for this instance of GT::Mail::POP3.
=item host
Sets the host to connect to for checking a POP account. This argument must be
provided.
=item port
Sets the port on the POP server to attempt to connect to. This defaults to 110,
unless using SSL, for which the default is 995.
=item ssl
Establishes the connection using SSL. Note that this requires Net::SSLeay of
at least version 1.06.
=item user
Sets the user name to login with when connecting to the POP server. This must
be specified.
=item pass
Sets the password to login with when connection to the POP server. This must be
specified.
=item auth_mode
Sets the authentication type for this connection. This can be one of two
values. PASS (the default) or APOP. If set to APOP, GT::Mail::POP3 will use
APOP to login to the remote server.
=item timeout
Sets the connection timeout. This isn't entirely reliable as it uses alarm(),
which isn't supported on all systems. That aside, this normally isn't needed
if you want a timeout - it defaults to 30 on alarm()-supporting systems. The
main purpose is to provide a value of 0 to disable the alarm() timeout.
=back
=head2 connect - Connect to the POP account
$obj->connect or die $GT::Mail::POP3::error;
This method performs the connection to the POP server. Returns the count of
messages on the server on success, and undefined on failure. Takes no arguments
and called before you can perform any actions on the POP server.
=head2 head_part - Access the email header
# Get a parsed header part object for the first email in the list.
my $top_part = $obj->head_part(1);
Instance method. The only argument to this method is the message number to get.
Returns a L<GT::Mail::Parts> object containing only the parsed header of the
specified message.
=head2 all_head_parts - Access all email headers
# Get all the head parts from all messages
my @headers = $obj->all_head_parts;
Instance method. Gets all the headers of all the email's on the remote server.
Returns an array of the L<GT::Mail::Parts> object. One object for each
email. None of the email's bodies are retrieved, only the head.
=head2 parse_message - Access an email
# Parse an email and get the GT::Mail object
my $mail = $obj->parse_message (1);
Instance method. Pass in the number of the email to retrieve. This method
retrieves the specified email and returns the parsed GT::Mail object. If this
method fails you should check $GT::Mail::error for the error message.
=head2 message_save - Save an email
open FH, '/path/to/email.txt' or die $!;
# Save message 2 to file
$obj->message_save (2, \*FH);
close FH;
- or -
$obj->message_save (2, '/path/to/email.txt') or die $GT::Mail::POP3::error;
Instance method. This method takes the message number as it's first argument,
and either a file path or a file handle ref as it's second argument. If a file
path is provided the file will be opened to truncate. The email is then
retrieved from the server and written to the file.
=head2 stat - Do a STAT command
# Get the number of messages on the server
my $count = $obj->stat;
Instance method. Does a STAT command on the remote server. It stores the total
size and returns the count of messages on the server, if successful. Otherwise
returns undef.
=head2 list - Do a LIST command
# At a list of messages on the server
my @messages = $obj->list;
Instance method. Does a LIST command on the remote server. Returns an array of
the lines in list context and a single scalar that contains all the lines in
scalar context.
=head2 rset - Do an RSET command
# Tell the server to ignore any dele commands we have issued in this
# session
$obj->rset;
Instance method. Does an RSET command. This command resets the servers
knowledge of what should be deleted when QUIT is called. Returns 1 on success.
=head2 dele - Do a DELE command
# Delete message 4
$obj->dele (4);
Instance method. Does a DELE command. The only argument is the message number
to delete. Returns 1 on success.
=head2 quit - Quit the connection
# Close our connection
$obj->quit;
Instance method. Sends the QUIT command to the server. The should should
disconnect soon after this. No more actions can be taken on this connection
until connect is called again.
=head2 uidl - Do a UIDL command
# Get the uidl for message 1
my $uidl = $obj->uidl (1);
# Get a list of all the uidl's and print them
$obj->uidl (sub { print @_ });
# Get an array of all the uidl's
my @uidl = $obj->uidl;
Instance method. Attempts to do a UIDL command on the remote server. Please be
aware support for the UIDL command is not very wide spread. This method can
take the message number as it's first argument. If the message number is given,
the UIDL for that message is returned. If the first argument is a code
reference, a UIDL command is done with no message specified and the code
reference is called for each line returned from the remote server. If no second
argument is given, a UIDL command is done, and the results are returned in a
has of message number to UIDL.
=head2 count - Get the number of messages
# Get the count from the last STAT
my $count = $obj->count;
This method returns the number of messages on the server from the last STAT
command. A STAT is done on connect.
=head2 size - Get the size of all messages
# Get the total size of all messages on the server
my $size = $obj->size;
This method returns the size of all messages in the server as returned by the
last STAT command sent to the server.
=head2 send - Send a raw command
# Send a raw command to the server
my $ret = $obj->send ("HELO");
This method sends the specified raw command to the POP server. The one line
return from the server is returned. Do not call this method if you are
expecting more than a one line response.
=head2 top - Retrieve the header
# Get the header of message 2 in an array. New lines are stripped
my @header = $obj->top (2);
# Get the header as a string
my $header = $obj->top (2);
Instance method to retrieve the top of an email on the POP server. The only
argument should be the message number to retrieve. Returns a scalar containing
the header in scalar context and an array, which is the scalar split on
\015?\012, in list context.
=head2 retr - Retrieve an email
# Get message 3 from the remote server in an array. New lines are stripped
my @email = $obj->retr (3);
# Get it as a string
my $email = $obj->retr (3);
Instance method to retrieve an email from the POP server. The first argument to
this method should be the message number to retrieve. The second argument is an
optional code ref to call for each line of the message that is retrieved. If no
code ref is specified, this method will put the email in a scalar and return
the scalar in scalar context and return the scalar split on \015?\012 in list
context.
=head1 REQUIREMENTS
L<GT::Socket::Client>
L<GT::Base>
L<GT::MD5> (for APOP authentication)
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: POP3.pm,v 1.57 2008/09/23 23:55:26 brewt Exp $

831
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Parse.pm Normal file
View File

@ -0,0 +1,831 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Mail::Parse
# Author : Scott Beck
# CVS Info : 087,071,086,086,085
# $Id: Parse.pm,v 1.90 2008/10/29 23:32:07 brewt Exp $
#
# Copyright (c) 2005 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
package GT::Mail::Parse;
# =============================================================================
# If MIME::Base64 is installed use it - must eval before hand or 5.004_04 wipes
# our ISA.
my $have_b64 = eval {
local $SIG{__DIE__};
require MIME::Base64;
import MIME::Base64;
if ($] < 5.005) { local $^W; decode_base64('brok'); }
1;
};
$have_b64 or *decode_base64 = \&gt_old_decode_base64;
my $use_decode_qp;
if ($have_b64 and
$MIME::Base64::VERSION ge 2.16 and # Prior versions had decoding bugs
defined &MIME::QuotedPrint::decode_qp and (
not defined &MIME::QuotedPrint::old_decode_qp or
\&MIME::QuotedPrint::decode_qp != \&MIME::QuotedPrint::old_decode_qp
)
) {
$use_decode_qp = 1;
}
# Pragmas
use strict;
use vars qw($VERSION $DEBUG $ERRORS @ISA);
# System modules
use Fcntl;
# Internal modules
use GT::Mail::Parts;
use GT::Base;
# Inherent from GT::Base for errors and debug
@ISA = qw(GT::Base);
# Debugging mode
$DEBUG = 0;
$VERSION = sprintf "%d.%03d", q$Revision: 1.90 $ =~ /(\d+)\.(\d+)/;
# Error messages
$ERRORS = {
PARSE => "An error occurred while parsing: %s",
DECODE => "An error occurred while decoding: %s",
NOPARTS => "Email has no parts!",
DEEPPARTS => "Deep recursion dected, email appears to have more than 50 parts!",
MALFORMED => "Found (%s) before finding the start of the boundary. Message malformed"
};
my %DecoderFor = (
# Standard...
'7bit' => 'NBit',
'8bit' => 'NBit',
'base64' => 'Base64',
'binary' => 'Binary',
'none' => 'Binary',
'quoted-printable' => 'QuotedPrint',
# Non-standard...
'x-uu' => 'UU',
'x-uuencode' => 'UU',
);
sub new {
# --------------------------------------------------------------------------
# CLASS->new (
# naming => \&naming,
# in_file => '/path/to/file/to/parse',
# handle => \*FH
# );
# ----------------------------------------------
# Class method to get a new object. Calles init if there are any additional
# argument. To set the arguments that are passed to naming call naming
# directly.
#
my $this = shift;
my $class = ref $this || $this;
my $self = bless {
file_handle => undef,
parts => [],
head_part => undef,
headers_intact => 1,
_debug => $DEBUG,
eol => "\012"
}, $class;
$self->init(@_) if @_;
$self->debug("Created new object ($self).") if $self->{_debug} > 1;
return $self;
}
sub init {
# --------------------------------------------------------------------------
# $obj->init (%opts);
# -------------------
# Sets the options for the current object.
#
my $self = shift;
my $opt = {};
if (@_ == 1 and ref $_[0] eq 'HASH') { $opt = shift }
elsif (defined $_[0] and not @_ % 2) { $opt = {@_} }
else { return $self->error("BADARGS", "FATAL", "init") }
$self->{_debug} = exists($opt->{debug}) ? $opt->{debug} : $DEBUG;
$self->{headers_intact} = exists($opt->{headers_intact}) ? $opt->{headers_intact} : 1;
for my $m (qw(crlf in_file in_handle in_string attach_rfc822)) {
$self->$m($opt->{$m}) if defined $opt->{$m};
}
}
sub attach_rfc822 {
# --------------------------------------------------------------------------
my $self = shift;
if (@_) {
$self->{attach_rfc822} = shift;
}
return $self->{attach_rfc822};
}
sub crlf {
# -----------------------------------------------------------------------------
# Sets the end-of-line character sequence to use when parsing. This defaults
# to \012 (\n); you'll likely want to use \015\012 at times (for example, when
# parsing mail downloaded from a POP3 server). This is set on a per-parser
# basis (it used to be global, but that was significantly broken).
#
my ($self, $eol) = @_;
$self->{eol} = $eol;
}
sub parse {
# --------------------------------------------------------------------------
# my $top = $obj->parse;
# ----------------------
# Parses the email set in new or init. Also calls init if there are any
# arguments passed in.
# Returns the top level part object.
#
my ($self, @opts) = @_;
# Any additional arguments goto init
$self->init(@opts) if @opts;
($self->{string} and ref($self->{string}) eq 'SCALAR')
or return $self->error('BADARGS', 'FATAL', "No input was given to parse before parse() was called");
# Recursive function to parse
$self->_parse_part(undef, $self->{string}); # parse!
# Return top part
return $self->{head_part};
}
sub parse_head {
# --------------------------------------------------------------------------
# my $head = $obj->parse_head;
# ----------------------------
# Passes any additional arguments to init. Parses only the top level header.
# This saves some overhead if for example all you need to do it find out who
# an email is to on a POP3 server.
#
my ($self, $in, @opts) = @_;
unless (ref $self) {
$self = $self->new(@opts);
}
$in ||= $self->{string};
$in || return $self->error("BADARGS", "FATAL", "No string to parse set!");
# Parse the head
return $self->_parse_head($in);
}
#--------------------------------------------
# Access
#--------------------------------------------
sub in_handle {
# --------------------------------------------------------------------------
# $obj->in_handle (\*FH);
# --------------------
# Pass in a file handle to parse from when parse is called.
#
my ($self, $value) = @_;
if (@_ > 1 and ref $value and defined fileno $value) {
read $value, ${$self->{string}}, -s $value;
}
return $self->{string};
}
sub in_file {
# --------------------------------------------------------------------------
# $obj->in_file ('/path/to/file');
# --------------------------------
# Pass in the path to a file to parse when parse is called
#
my $self = shift;
my $file = shift;
my $io = \do { local *FH; *FH };
open $io, "<$file" or return $self->error("READOPEN", "FATAL", $file, $!);
return $self->in_handle($io);
}
sub in_string {
# --------------------------------------------------------------------------
my ($self, $string) = @_;
return $self->{string} unless (@_ > 1);
if (ref($string) eq 'SCALAR') {
$self->{string} = $string;
}
else {
$self->{string} = \$string;
}
return $self->{string};
}
sub size {
# --------------------------------------------------------------------------
# my $email_size = $obj->size;
# ----------------------------
# Returns the total size of an email. Call this method after the email has
# been parsed.
#
my $self = shift;
(@{$self->{parts}} > 0) or return $self->error("NOPARTS", "WARN");
my $size = 0;
foreach (@{$self->{parts}}) {
$size += $_->size;
}
return $size;
}
sub all_parts {
# --------------------------------------------------------------------------
# my @parts = $obj->all_parts;
# ----------------------------
# Returns a list of all the part object for the current parsed email. If the
# email is not multipart this will be just the header part.
#
return @{shift()->{parts}}
}
sub top_part {
# --------------------------------------------------------------------------
return ${shift()->{parts}}[0];
}
#---------------------------------------------
# Internal Methods
#---------------------------------------------
sub _parse_head {
# --------------------------------------------------------------------------
# Internal Method
# ---------------
# Parse just the head. Returns the part object.
#
my ($self, $in) = @_;
# Get a new part object
my $part = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
if (ref $in eq 'ARRAY') {
$part->extract($in) or return $self->error("PARSE", "WARN", "Couldn't parse head!");
return $part;
}
$part->extract([map "$_$self->{eol}", split /\Q$self->{eol}/, $$in]) or return $self->error($GT::Mail::Parts::error, 'WARN');
return $part;
}
sub _parse_part {
# --------------------------------------------------------------------------
# Internal Method
# ---------------
# Parses all the parts of an email and stores them in there parts object.
# This function is recursive.
#
my ($self, $outer_bound, $in, $part) = @_;
my $state = 'OK';
# First part is going to be the top level part
if (!$part) {
$part = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
$self->{head_part} = $part;
}
push @{$self->{parts}}, $part;
# Get the header for this part
=for comment
According to rfc2045 and rfc2046, the MIME part headers are optional, so for
parsing out the headers, we have the following cases:
1) no headers, no body
EOL--boundary
2) no headers, body
EOLbodyEOL--boundary
3) headers, no body
headers[EOL]EOL--boundary
4) headers, body
headersEOLbodyEOL--boundary
_parse_to_bound parses everything after the header to EOL--boundary, so this
header parsing must be careful not to remove the EOL before the --boundary
(cases 1 and 3), or _parse_to_bound will parse more than it should.
=cut
my $eol_len = length $self->{eol};
if (defined $outer_bound and substr($$in, 0, length "$self->{eol}--$outer_bound") eq "$self->{eol}--$outer_bound") {
# do nothing
}
elsif (substr($$in, 0, $eol_len) eq $self->{eol}) {
substr($$in, 0, $eol_len) = '';
}
else {
my $indx = index($$in, $self->{eol} x 2);
if ($indx == -1) {
$self->debug('Message has no body.') if $self->{_debug};
$indx = length($$in);
}
$part->extract([map "$_$self->{eol}", split /\Q$self->{eol}/, substr $$in, 0, $indx]) or return $self->warn($GT::Mail::Parts::error);
my $trim_len = $eol_len * 2;
if (defined $outer_bound) {
my $next_bound = "$self->{eol}$self->{eol}--$outer_bound";
if (substr($$in, $indx, length $next_bound) eq $next_bound) {
$trim_len = $eol_len;
}
}
substr($$in, 0, $indx + $trim_len) = '';
}
# Get the mime type
my ($type, $subtype) = split m{/}, $part->mime_type;
$type ||= 'text';
$subtype ||= 'plain';
if ($self->{_debug}) {
my $name = $part->recommended_filename || '[unnamed]';
$self->debug("Type is '$type/$subtype' ($name)");
}
# Deal with the multipart type with some recursion
if ($type eq 'multipart') {
my $retype = (($subtype eq 'digest') ? 'message/rfc822' : '');
# Find the multipart boundary
my $inner_bound = $part->multipart_boundary;
$self->debug("Boundary is $inner_bound") if $self->{_debug} > 1;
defined $inner_bound or return $self->error("PARSE", "WARN", "No multipart boundary in multipart message.");
index($inner_bound, $self->{eol}) == -1 or return $self->error("PARSE", "WARN", "End-of-line character in multipart boundary.");
# Parse the Preamble
$self->debug("Parsing preamble.") if $self->{_debug} > 1;
$state = $self->_parse_preamble($inner_bound, $in, $part) or return;
chomp($part->preamble->[-1]) if @{$part->preamble};
# Get all the parts of the multipart message
my $partno = 0;
my $parts;
while (1) {
++$partno < 200 or return $self->error('DEEPPARTS', 'WARN');
$self->debug("Parsing part $partno.") if $self->{_debug};
($parts, $state) = $self->_parse_part($inner_bound, $in, GT::Mail::Parts->new(headers_intact => $self->{headers_intact})) or return;
$parts->mime_type($retype) if $retype;
push(@{$part->{parts}}, $parts);
if ($state eq 'EOF') {
$self->warn(PARSE => 'Unexpected EOF before close.');
return ($part, 'EOF');
}
last if $state eq 'CLOSE';
}
# Parse the epilogue
$self->debug("Parsing epilogue.") if $self->{_debug} > 1;
$state = $self->_parse_epilogue($outer_bound, $in, $part) or return;
chomp($part->epilogue->[-1]) if @{$part->epilogue} and $state ne 'EOF';
}
# We are on a single part
else {
$self->debug("Decoding single part.") if $self->{_debug} > 1;
# Find the encoding for the body of the part
my $encoding = $part->mime_encoding || 'binary';
if (!exists($DecoderFor{lc($encoding)})) {
$self->debug("Unsupported encoding '$encoding': using 'binary'... \n" .
"The entity will have an effective MIME type of \n" .
"application/octet-stream, as per RFC-2045.")
if $self->{_debug};
$part->effective_type('application/octet-stream');
$encoding = 'binary';
}
my $reparse;
$reparse = ("$type/$subtype" eq "message/rfc822") unless $self->{attach_rfc822};
my $encoded = "";
# If we have boundaries we parse the body to the boundary
if (defined $outer_bound) {
$self->debug("Parsing to boundary.") if $self->{_debug} > 1;
$state = $self->_parse_to_bound($outer_bound, $in, \$encoded) or return;
}
# Else we would parse the rest of the input stream as the rest of the message
else {
$self->debug("No Boundries.") if $self->{_debug} > 1;
$encoded = $$in;
$state = 'EOF';
}
# Normal part so we get the body and decode it.
if (!$reparse) {
$self->debug("Not reparsing.") if $self->{_debug} > 1;
$part->{body_in} = 'MEMORY';
my $decoder = $DecoderFor{lc($encoding)};
$self->debug("Decoding part using: " . lc($encoding)) if $self->{_debug};
$part->{data} = '';
my $out = '';
my $res = $self->$decoder(\$encoded, \$out);
undef $encoded;
$res or return;
$part->{data} = $out;
undef $out;
}
else {
# If have an embeded email we reparse it.
$self->debug("Reparsing enclosed message.") if $self->{_debug};
my $out = '';
my $decoder = $DecoderFor{lc($encoding)};
$self->debug("Decoding " . lc($encoding)) if $self->{_debug};
my $res = $self->$decoder(\$encoded, \$out);
undef $encoded;
$res or return;
my $p = GT::Mail::Parts->new(headers_intact => $self->{headers_intact});
push @{$part->{parts}}, $p;
$self->_parse_part(undef, \$out, $p) or return;
}
}
return ($part, $state);
}
sub _parse_to_bound {
# --------------------------------------------------------------------------
# This method takes a boundary ($bound), an input string ref ($in), and an
# output string ref ($out). It will place into $$out the data contained by
# $bound, and remove the entire region (including boundary) from $$in.
#
my ($self, $bound, $in, $out) = @_;
# Set up strings for faster checking:
$self->debug("Parsing bounds. Skip until\n\tdelim (--$bound)\n\tclose (--$bound--)") if $self->{_debug} > 1;
my $ret;
# Various shortcut variables - 'e' is eol, 'd' is delimiter, 'c' is closing delimiter:
my ($ede, $de, $ece, $ec, $ce) = (
"$self->{eol}--$bound$self->{eol}",
"--$bound$self->{eol}",
"$self->{eol}--$bound--$self->{eol}",
"$self->{eol}--$bound--",
"--$bound--$self->{eol}"
);
# Place our part in $$out.
$$out = undef;
# eoldelimeol found anywhere:
if ((my $pos = index $$in, $ede) >= 0) {
$$out = substr($$in, 0, $pos);
substr($$in, 0, $pos + length $ede) = '';
$ret = 'DELIM';
}
# delimeol at beginning of string:
elsif (substr($$in, 0, length $de) eq $de) {
substr($$in, 0, length $de) = '';
$$out = '';
$ret = 'DELIM';
}
# eolcloseeol found anywhere:
elsif (($pos = index($$in, $ece)) >= 0) {
# This code could be much more clearly written as:
#
#$$out = substr($$in, 0, $pos);
#substr($$in, 0, $pos + length $ece) = '';
#
# However, that can cause excessive memory usage in some cases (changed in revision 1.59).
$$out = $$in;
substr($$out, -(length($$out) - $pos)) = '';
my $len = $pos + length($ece) - length($$in);
$$in = $len == 0 ? '' : substr($$in, $len);
$ret = 'CLOSE';
}
# The first eolclose occurs at the end of the string:
elsif (index($$in, $ec) == (length($$in) - length($ec))) {
$$out = substr($$in, 0, -length($ec));
$$in = '';
$ret = 'CLOSE';
}
# closeeol at beginning of string:
elsif (substr($$in, 0, length $ce) eq $ce) {
$$out = '';
substr($$in, 0, length $ce) = '';
$ret = 'CLOSE';
}
# The only thing in the string is the closing boundary:
elsif ($$in eq "--$bound--") {
$$out = '';
$$in = '';
$ret = 'CLOSE';
}
if (defined $$out) {
return $ret;
}
else {
# Broken e-mail - we hit the end of the message without finding a boundary.
# Assume that everything left is the part body.
$$out = $$in;
$$in = '';
return 'EOF';
}
}
sub _parse_preamble {
# --------------------------------------------------------------------------
# Internal Method
# ---------------
# Parses preamble and sets it in part.
#
my ($self, $inner_bound, $in, $part) = @_;
my $delim = "--$inner_bound";
$self->debug("Parsing preamble. Skip until delim ($delim)") if $self->{_debug} > 1;
my @saved;
$part->preamble(\@saved);
my $data;
if (substr($$in, 0, length "$delim$self->{eol}") eq "$delim$self->{eol}") {
$data = '';
substr($$in, 0, length "$delim$self->{eol}") = '';
}
else {
if ((my $pos = index($$in, "$self->{eol}$delim$self->{eol}")) >= 0) {
$data = substr($$in, 0, $pos);
substr($$in, 0, $pos + length("$self->{eol}$delim$self->{eol}")) = '';
}
else {
return $self->warn(PARSE => "Unable to find opening boundary: $delim\nMessage is probably corrupt.");
}
}
push @saved, split /\Q$self->{eol}/, $data;
undef $data;
return 'DELIM';
}
sub _parse_epilogue {
# --------------------------------------------------------------------------
# Internal Method
# ---------------
# Parses epilogue and sets it in part.
#
my ($self, $outer_bound, $in, $part) = @_;
$self->debug("Parsing epilogue.") if $self->{_debug} > 1;
$part->epilogue(\my @saved);
if (defined $outer_bound) {
my ($delim, $close) = ("--$outer_bound", "--$outer_bound--");
$self->debug("Skip until\n\tdelim ($delim)\n\tclose($close)") if $self->{_debug} > 1;
if ($$in =~ s/(.*?)(?:\A|\Q$self->{eol}\E)\Q$delim$self->{eol}//s) {
push @saved, split /\Q$self->{eol}/, $1;
$self->debug("Found delim($delim)") if $self->{_debug};
return 'DELIM'
}
elsif ($$in =~ s/(.*?)(?:\A|\Q$self->{eol}\E)\Q$close\E(?:\Z|\Q$self->{eol}\E)//s) {
push @saved, split /\Q$self->{eol}/, $1;
$self->debug("Found close($close)") if $self->{_debug};
return 'CLOSE'
}
}
push @saved, split /\Q$self->{eol}/, $$in;
$$in = '';
$self->debug("EOF: epilogue is " . length(join '', @saved) . " bytes") if $self->{_debug};
return 'EOF';
}
sub Base64 {
# --------------------------------------------------------------------------
my ($self, $in, $out) = @_;
# Remove any non base64 characters.
$$in =~ tr{A-Za-z0-9+/}{}cd;
# Must pass multiple of 4 to decode_base64. Store any remainder in $rem_str and
# pad it with trailing equal signs.
my $rem = length($$in) % 4;
my ($rem_str);
if ($rem) {
my $pad = '=' x (4 - $rem);
$rem_str = substr($$in, length($$in) - $rem);
$rem_str .= $pad;
substr($$in, $rem * -1) = '';
}
$$out = decode_base64($$in);
if ($rem) {
$$out .= decode_base64($rem_str);
}
return 1;
}
sub Binary {
# --------------------------------------------------------------------------
my ($self, $in, $out) = @_;
$$out = $$in;
return 1;
}
sub NBit {
# --------------------------------------------------------------------------
my ($self, $in, $out) = @_;
$$out = $$in;
return 1;
}
sub QuotedPrint {
# --------------------------------------------------------------------------
my ($self, $in, $out) = @_;
if ($use_decode_qp) {
$$out = MIME::QuotedPrint::decode_qp($$in);
}
else {
$$out = $$in;
$$out =~ s/\r\n/\n/g; # normalize newlines
$$out =~ s/[ \t]+\n/\n/g; # rule #3 (trailing whitespace must be deleted)
$$out =~ s/=\n//g; # rule #5 (soft line breaks)
$$out =~ s/=([\da-fA-F]{2})/chr hex $1/ge;
}
return 1;
}
sub UU {
# --------------------------------------------------------------------------
my ($self, $in, $out) = @_;
my ($mode, $file);
# Find beginning...
while ($$in =~ s/^(.+\Q$self->{eol}\E)//) {
local $_ = $1;
last if ($mode, $file) = /^begin\s*(\d*)\s*(\S*)/;
}
return $self->warn("uu decoding: no begin found") if not defined $file;
# Decode:
while ($$in =~ s/^(.+\Q$self->{eol}\E)//) {
local $_ = $1;
last if /^end/;
next if /[a-z]/;
next unless int((((ord() - 32) & 077) + 2) / 3) == int(length($_) / 4);
$$out .= unpack('u', $_);
}
return 1;
}
sub gt_old_decode_base64 {
# --------------------------------------------------------------------------
my $str = shift;
my $res = "";
$str =~ tr|A-Za-z0-9+=/||cd;
$str =~ s/=+$//;
$str =~ tr|A-Za-z0-9+/| -_|;
return "" unless length $str;
my $uustr = '';
my ($i, $l);
$l = length($str) - 60;
for ($i = 0; $i <= $l; $i += 60) {
$uustr .= "M" . substr($str, $i, 60);
}
$str = substr($str, $i);
# and any leftover chars
if ($str ne "") {
$uustr .= chr(32 + length($str)*3/4) . $str;
}
return unpack("u", $uustr);
}
1;
__END__
=head1 NAME
GT::Mail::Parse - MIME Parse
=head1 SYNOPSIS
use GT::Mail::Parse
my $parser = new GT::Mail::Parse (
naming => \&name_files,
in_file => '/path/to/file.eml',
debug => 1
);
my $top = $parser->parse or die $GT::Mail::Parse::error;
- or -
my $parser = new GT::Mail::Parse;
open FH, '/path/to/file.eml' or die $!;
my $top = $parser->parse (
naming => \&name_files,
handle => \*FH,
debug => 1
) or die $GT::Mail::Parse::error;
close FH;
- or -
my $parser = new GT::Mail::Parse;
my $top_head = $parser->parse_head (
naming => \&name_files,
in_file => '/path/to/file.eml',
debug => 1
) or die $GT::Mail::Parse::error;
=head1 DESCRIPTION
GT::Mail::Parse is a 100% rfc822 email MIME parser that supports unlimited
nested levels of MIME. Emails are parsed into L<GT::Mail::Parts> objects. Each
part knows where it's body is and each part contains it's sub parts. See
L<GT::Mail::Parts> for details on parts methods.
=head2 new - Constructor method
This is the constructor method to get a GT::Mail::Parse object, which you
need to access all the methods (there are no Class methods). new() takes
a hash or hash ref as it's arguments. Each key has an accessor method by the
same name except debug, which can only be set by passing debug to new(), parse()
or parse_head().
=over 4
=item debug
Sets the debug level for this insance of the class.
=item naming
Specify a code reference to use as a naming convention for each part of the
email being parsed. This is useful to keep file IO down when you want the emails
seperated into each part as a file. If this is not specified GT::Mail::Parse
uses a default naming, which is to start at one and incriment that number for each
attachment. The attachments would go in the current working directory.
=item in_file
Specify the path to the file that contains the email to be parsed. One of in_file
and handle must be specified.
=item handle
Specify the file handle or IO stream that contains the email to be parsed.
=item attach_rfc822
By default, the parser will decode any embeded emails, and flatten out all the
parts. If you prefer to leave embeded emails unparsed, pass in 1 to this option
and the parser will treat it as an attachment.
=back
=head2 parse - Parse an email
Instance method. Parses the email specified by either in_file or handle. Returns
the top level L<GT::Mail::Parts> object. Any additional parameters passed in are
treated the same as if they were passed to the constuctor.
=head2 parse_head - Parse just the header of the email
Instance method. This method is exactly the same as parse except only the top
level header is parsed and it's part object returned. This is useful to keep
overhead down if you only need to know about the header of the email.
=head2 size - Get the size
Instance method. Returns the total size in bytes of the parsed unencoded email. This
method will return undef if no email has been parsed.
=head2 all_parts - Get all parts
Instance method. Returns all the parts in the parsed email. This is a flatened
list of the objects. Somewhat similar to what MIME::Tools does. All the parts
still contain their sub parts.
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Parse.pm,v 1.90 2008/10/29 23:32:07 brewt Exp $

1274
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Parts.pm Normal file
View File

File diff suppressed because it is too large Load Diff

496
site/slowtwitch.com/cgi-bin/articles/GT/Mail/Send.pm Normal file
View File

@ -0,0 +1,496 @@
# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
# GT::Mail::Send
# Author : Scott Beck
# CVS Info : 087,071,086,086,085
# $Id: Send.pm,v 1.54 2007/08/01 23:35:16 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# ==================================================================
package GT::Mail::Send;
use strict;
use GT::Base;
use GT::Socket::Client;
use GT::Mail::POP3;
use GT::MD5;
use vars qw(@ISA $VERSION $DEBUG $ATTRIBS $ERRORS $CRLF %SENDMAIL_ERRORS $HAVE_SSL);
%SENDMAIL_ERRORS = (
64 => 'EX_USAGE',
65 => 'EX_DATAERR',
66 => 'EX_NOINPUT',
67 => 'EX_NOUSER',
68 => 'EX_NOHOST',
69 => 'EX_UNAVAILABLE',
70 => 'EX_SOFTWARE',
71 => 'EX_OSERR',
72 => 'EX_OSFILE',
73 => 'EX_CANTCREAT',
74 => 'EX_IOERR',
75 => 'EX_TEMPFAIL',
76 => 'EX_PROTOCOL',
77 => 'EX_NOPERM',
78 => 'EX_CONFIG',
# This is for qmail-inject's version of sendmail
# Nice that they are different..
111 => 'EX_TEMPFAIL',
100 => 'EX_USAGE',
);
@ISA = qw/GT::Base/;
$VERSION = sprintf "%d.%03d", q$Revision: 1.54 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 0;
$ATTRIBS = {
mail => undef,
host => undef,
port => undef,
ssl => undef,
from => undef,
path => undef,
flags => undef,
rcpt => undef,
user => undef,
pass => undef,
helo => undef,
pbs_user => undef,
pbs_pass => undef,
pbs_host => undef,
pbs_port => undef,
pbs_auth_mode => undef,
pbs_ssl => undef,
debug => 0,
};
$ERRORS = {
HOSTNOTFOUND => "SMTP: server '%s' was not found.",
CONNFAILED => "SMTP: connect() failed. reason: %s",
SERVNOTAVAIL => "SMTP: Service not available: %s",
SSLNOTAVAIL => "SMTP: SSL connections are not available: Net::SSLeay 1.06 or greater not installed.",
COMMERROR => "SMTP: Unspecified communications error: '%s'.",
USERUNKNOWN => "SMTP: Local user '%s' unknown on host '%s'. Server said: %s",
TRANSFAILED => "SMTP: Transmission of message failed: %s",
AUTHFAILED => "SMTP: Authentication failed: %s",
TOEMPTY => "No To: field specified.",
NOMSG => "No message body specified",
SENDMAILNOTFOUND => "Sendmail was not defined or not found: %s",
NOOPTIONS => "No options were specified. Be sure to pass a hash ref to send()",
NOTRANSPORT => "Neither sendmail nor SMTP were specified!",
SENDMAIL => "There was a problem sending to Sendmail: (%s)",
NOMAILOBJ => "No mail object was specified.",
EX_USAGE => "Command line usage error",
EX_DATAERR => "Data format error",
EX_NOINPUT => "Cannot open input",
EX_NOUSER => "Addressee unknown",
EX_NOHOST => "Host name unknown",
EX_UNAVAILABLE => "Service unavailable",
EX_SOFTWARE => "Internal software error",
EX_OSERR => "System error (e.g., can't fork)",
EX_OSFILE => "Critical OS file missing",
EX_CANTCREAT => "Can't create (user) output file",
EX_IOERR => "Input/output error",
EX_TEMPFAIL => "Temp failure; user is invited to retry",
EX_PROTOCOL => "Remote error in protocol",
EX_NOPERM => "Permission denied",
EX_CONFIG => "Configuration error",
EX_UNKNOWN => "Sendmail exited with an unknown exit status: %s"
};
$CRLF = "\015\012";
sub init {
my $self = shift;
$self->set(@_);
# We need either a host or a path to sendmail and an email object
$self->{host} or $self->{path} or return $self->error("NOTRANSPORT", "FATAL");
exists $self->{mail} or return $self->error("NOMAILOBJ", "FATAL");
# Set debugging
$self->{_debug} = defined($self->{debug}) ? $self->{debug} : $DEBUG;
# Default port for smtp
if ($self->{host} and !$self->{port}) {
$self->{port} = $self->{ssl} ? 465 : 25;
}
# Default flags for sendmail
elsif ($self->{path}) {
($self->{flags}) or $self->{flags} = '-t -oi -oeq';
$self->{path} =~ /^\s*(.+?)\s*$/ and $self->{path} = $1; # Untaint
(-e $self->{path}) or return $self->error('SENDMAILNOTFOUND', 'FATAL', $1);
}
return $self;
}
sub smtp_send {
# ---------------------------------------------------------------
#
my ($self, $sock, $cmd) = @_;
if (defined $cmd) {
print $sock "$cmd$CRLF";
$self->debug("SMTP Log: >> $cmd\n") if $self->{debug} > 1;
}
$_ = <$sock>;
return if !$_;
my $resp = $_;
if (/^\d{3}-/) {
while (defined($_ = <$sock>) and /^\d{3}-/) {
$resp .= $_;
}
$resp .= $_;
}
$resp =~ s/$CRLF/\n/g;
$self->debug("SMTP Log: << $resp") if $self->{debug} > 1;
return $resp;
}
sub smtp {
# ---------------------------------------------------------------
# Opens a smtp port and sends the message headers.
#
my $self = shift;
ref $self or $self = $self->new(@_);
if ($self->{ssl}) {
$HAVE_SSL ||= eval { require Net::SSLeay; Net::SSLeay->require_version(1.06); 1 };
$HAVE_SSL or return $self->error('SSLNOTAVAIL', 'FATAL');
}
if ($self->{pbs_host}) {
my $pop = GT::Mail::POP3->new(
host => $self->{pbs_host},
port => $self->{pbs_port},
user => $self->{pbs_user},
pass => $self->{pbs_pass},
auth_mode => $self->{pbs_auth_mode},
ssl => $self->{pbs_ssl},
debug => $self->{debug}
);
my $count = $pop->connect();
if (!defined($count)) {
$self->debug("Couldn't connect to server for POP3 before SMTP authentication: $GT::Mail::POP3::error") if $self->{debug};
}
else {
$pop->quit();
}
}
my $sock = GT::Socket::Client->open(
host => $self->{host},
port => $self->{port},
ssl => $self->{ssl}
) or return $self->error("CONNFAILED", "WARN", GT::Socket::Client->error);
local $SIG{PIPE} = 'IGNORE';
local $_;
# Get the server's greeting message
my $resp = $self->smtp_send($sock) or return $self->error('COMMERROR', 'WARN');
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
# Decide what hostname to use on the HELO/EHLO line
my $helo = $self->{helo};
$helo ||= $ENV{SERVER_NAME};
eval {
require Sys::Hostname;
$helo = Sys::Hostname::hostname();
} unless $helo;
$helo ||= $self->{host};
$resp = $self->smtp_send($sock, "EHLO $helo") or return $self->error('COMMERROR', 'WARN');
if ($resp =~ /^[45]/) {
$resp = $self->smtp_send($sock, "HELO $helo") or return $self->error('COMMERROR', 'WARN');
return $self->error('SERVNOTAVAIL', 'WARN', $resp) if $resp =~ /^[45]/;
}
# Authenticate if needed
if ($resp =~ /AUTH[ =](.*)/ and $self->{user}) {
my $server = uc $1;
my $method = '';
# These are the authentication types that are supported, ordered by preference
for my $m (qw/CRAM-MD5 PLAIN LOGIN/) {
if ($server =~ /$m/) {
$method = $m;
last;
}
}
if ($method eq 'CRAM-MD5') {
$resp = $self->smtp_send($sock, "AUTH CRAM-MD5") or return $self->error('COMMERROR', 'WARN');
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
my ($challenge) = $resp =~ /\d{3}\s+(.*)/;
$challenge = decode_base64($challenge);
my $auth = encode_base64("$self->{user} " . hmac_md5_hex($challenge, $self->{pass}));
$resp = $self->smtp_send($sock, $auth) or return $self->error('COMMERROR', 'WARN');
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
}
elsif ($method eq 'PLAIN') {
my $auth = encode_base64("$self->{user}\0$self->{user}\0$self->{pass}");
$resp = $self->smtp_send($sock, "AUTH PLAIN $auth") or return $self->error('COMMERROR', 'WARN');
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
}
elsif ($method eq 'LOGIN') {
$resp = $self->smtp_send($sock, "AUTH LOGIN") or return $self->error('COMMERROR', 'WARN');
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
$resp = $self->smtp_send($sock, encode_base64($self->{user})) or return $self->error('COMMERROR', 'WARN');
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
$resp = $self->smtp_send($sock, encode_base64($self->{pass})) or return $self->error('COMMERROR', 'WARN');
return $self->error('AUTHFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
}
}
# We use return-path so the email will bounce to who it's from, not the user
# doing the sending.
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
$from = $self->extract_email($from) || '';
$self->debug("Sending from: <$from>") if $self->{debug} == 1;
$resp = $self->smtp_send($sock, "MAIL FROM: <$from>") or return $self->error('COMMERROR', 'WARN');
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
my $found_valid = 0;
my @tos = ($self->{mail}->{head}->split_field('to'), $self->{mail}->{head}->split_field('bcc'), $self->{mail}->{head}->split_field('cc'));
for my $to (@tos) {
next unless $to and my $email = $self->extract_email($to);
$found_valid++;
$self->debug("Sending RCPT TO: <$email>.") if $self->{debug} == 1;
$resp = $self->smtp_send($sock, "RCPT TO: <$email>") or return $self->error('COMMERROR', 'WARN');
return $self->error('USERUNKNOWN', 'WARN', $email, $self->{host}, $resp) if $resp =~ /^[45]/;
}
$found_valid or return $self->error('TOEMPTY', 'FATAL');
$resp = $self->smtp_send($sock, "DATA") or return $self->error('COMMERROR', 'WARN');
return $self->error('COMMERROR', 'WARN', $resp) if $resp =~ /^[45]/;
# Remove Bcc from the headers.
my @bcc = $self->{mail}->{head}->delete('bcc');
my $mail = $self->{mail}->to_string;
# SMTP needs any leading .'s to be doubled up.
$mail =~ s/^\./../gm;
# Print the mail body.
$resp = $self->smtp_send($sock, $mail . $CRLF . '.') or return $self->error('COMMERROR', 'WARN');
return $self->error('TRANSFAILED', 'WARN', $resp) if $resp =~ /^[45]/;
# Add them back in.
foreach my $bcc (@bcc) {
$self->{mail}->{head}->set('bcc', $bcc);
}
# Close the connection.
$resp = $self->smtp_send($sock, "QUIT") or return $self->error('COMMERROR', 'WARN');
close $sock;
return 1;
}
sub sendmail {
# ---------------------------------------------------------------
# Sends a message using sendmail.
#
my $self = shift;
ref $self or $self = $self->new(@_);
# Get a filehandle, and open pipe to sendmail.
my $s = \do{ local *FH; *FH };
# If the email address is safe, we set the envelope via -f so bounces are handled properly.
my $from = $self->{mail}->{head}->get('return-path') || $self->{mail}->{head}->get('from');
my $envelope = '';
if ($from =~ /<?([\w\-\.]+\@[\w\-\.]+)>?/) {
$envelope = "-f $1";
}
elsif ($from eq '<>' or $from eq '') {
$envelope = "-f ''";
}
open($s, "|$self->{path} $self->{flags} $envelope 1>&2") or return $self->error("SENDMAIL", "WARN", "$!");
$self->{mail}->write($s);
return 1 if close $s;
my $exit_value = $? >> 8;
my $code;
if (exists $SENDMAIL_ERRORS{$exit_value}) {
$code = $SENDMAIL_ERRORS{$exit_value};
}
else {
$code = 'EX_UNKNOWN';
}
if ($code eq 'EX_TEMPFAIL') {
return 1;
}
return $self->error($code, "WARN", $exit_value);
return 1;
}
sub extract_email {
# -----------------------------------------------------------------------------
# Takes a field, returns the e-mail address contained in that field, or undef
# if no e-mail address could be found.
#
shift if @_ > 1 and UNIVERSAL::isa($_[0], __PACKAGE__);
my $to = shift;
# We're trying to get down to the actual e-mail address. To do so, we have to
# remove quoted strings and comments, then extract the e-mail from whatever is
# left over.
$to =~ s/"(?:[^"\\]|\\.)*"//g;
1 while $to =~ s/\((?:[^()\\]|\\.)*\)//sg;
my ($email) = $to =~ /([^<>\s]+\@[\w.-]+)/;
return $email;
}
sub encode_base64 {
my $res = '';
pos($_[0]) = 0; # In case something has previously adjusted pos
while ($_[0] =~ /(.{1,45})/gs) {
$res .= substr(pack(u => $1), 1, -1);
}
$res =~ tr|` -_|AA-Za-z0-9+/|;
my $padding = (3 - length($_[0]) % 3) % 3;
$res =~ s/.{$padding}$/'=' x $padding/e if $padding;
$res;
}
sub decode_base64 {
my $str = shift;
my $res = '';
$str =~ tr|A-Za-z0-9+=/||cd;
$str =~ s/=+$//;
$str =~ tr|A-Za-z0-9+/| -_|;
return '' unless length $str;
my $uustr = '';
my ($i, $l);
$l = length($str) - 60;
for ($i = 0; $i <= $l; $i += 60) {
$uustr .= "M" . substr($str, $i, 60);
}
$str = substr($str, $i);
# and any leftover chars
if ($str ne "") {
$uustr .= chr(32 + length($str) * 3 / 4) . $str;
}
return unpack("u", $uustr);
}
sub hmac_md5_hex {
my ($challenge, $data) = @_;
GT::MD5::md5($challenge) if length $challenge > 64;
my $ipad = $data ^ (chr(0x36) x 64);
my $opad = $data ^ (chr(0x5c) x 64);
return GT::MD5::md5_hex($opad, GT::MD5::md5($ipad, $challenge));
}
1;
__END__
=head1 NAME
GT::Mail::Send - Module to send emails
=head1 SYNOPSIS
use GT::Mail::Send;
# $mail_object must be a GT::Mail object
my $send = new GT::Mail::Send (
mail => $mail_object,
host => 'smtp.gossamer-threads.com',
debug => 1
);
$send->smtp or die $GT::Mail::Send::error;
=head1 DESCRIPTION
GT::Mail::Send is an object interface to sending email over either
SMTP or Sendmail. This module is used internally to GT::Mail.
=head2 new - Constructor method
Returns a new GT::Mail::Send object. You must specify either the smtp host
or a path to sendmail. This method is inherented from GT::Base. The arguments
can be in the form of a hash or hash ref.
=over 4
=item debug
Sets the debug level for this instance of GT::Mail::Send.
=item mail
Specify the mail object to use. This must be a GT::Mail object and must contain
an email, either passed in or parsed in.
=item host
Specify the host to use when sending by SMTP.
=item port
Specify the port to use when sending over SMTP. Defaults to 25.
=item helo
The hostname to output on the HELO/EHLO line on an SMTP connection. Defaults to
$ENV{SERVER_NAME} or the system hostname (if Sys::Hostname is available).
=item path
Specify the path to sendmail when sending over sendmail. If the binary passed in
does not exist, undef will be returned and the error set in GT::Mail::Send::error.
=item flags
Specify the flags used to call sendmail. Defaults to -t -oi -oeq, see the Sendmail
guilde for sendmail for more info on the parameters to sendmail.
=back
=head2 smtp
Class or instance method. Sends the passed in email over SMTP. If called as a class
method, the parameters passed in will be used to call new(). Returns true on error,
false otherwise.
=head2 sendmail
Class or instance method. Send the passed in email to sendmail using the specified
path and flags. If called as a class method all additional arguments are passed to the
new() method. Returns true on success and false otherwise.
=head1 COPYRIGHT
Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
http://www.gossamer-threads.com/
=head1 VERSION
Revision: $Id: Send.pm,v 1.54 2007/08/01 23:35:16 brewt Exp $
=cut