File Coverage

blib/lib/Apache2/ASP/Server.pm

Criterion	Covered	Total	%
statement	24	66	36.3
branch	0	6	0.0
condition			n/a
subroutine	8	20	40.0
pod	7	10	70.0
total	39	102	38.2

package Apache2::ASP::Server;

use strict;
use warnings 'all';
use Mail::Sendmail;
use encoding 'utf8';


#==============================================================================
sub new
{
  my ($class, %args) = @_;

  my $s = bless {LastError => undef}, $class;

  return $s;
}# end new()


#==============================================================================
sub GetLastError
{
  $_[0]->{LastError};
}# end GetLastError()


#==============================================================================
sub context
{
  $Apache2::ASP::HTTPContext::ClassName->current;
}# end context()


#==============================================================================
# Shamelessly ripped off from Apache::ASP::Server, by Joshua Chamas,
# who shamelessly ripped it off from CGI.pm, by Lincoln D. Stein.
# :)
sub URLEncode
{
  my $toencode = $_[1];
  no warnings 'uninitialized';
  $toencode =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/esg;
  $toencode;
}# end URLEncode()


#==============================================================================
sub URLDecode
{
  my ($s, $todecode) = @_;
  return unless defined($todecode);
  $todecode =~ tr/+/ /;       # pluses become spaces
  $todecode =~ s/%(?:([0-9a-fA-F]{2})|u([0-9a-fA-F]{4}))/
  defined($1)? chr hex($1) : _utf8_chr(hex($2))/ge;
  return $todecode;
}# end URLDecode()


#==============================================================================
sub HTMLEncode
{
  my ($s, $str) = @_;
  no warnings 'uninitialized';
  $str =~ s/&/&/g;
  $str =~ s/
  $str =~ s/>/>/g;
  $str =~ s/"/"/g;
  $str =~ s/'/'/g;
  return $str;
}# end HTMLEncode()


#==============================================================================
sub HTMLDecode
{
  my ($s, $str) = @_;
  no warnings 'uninitialized';
  $str =~ s/</
  $str =~ s/>/>/g;
  $str =~ s/"/"/g;
  $str =~ s/&/&/g;
  return $str;
}# end HTMLEncode()


#==============================================================================
sub MapPath
{
  my ($s, $path) = @_;

  return unless defined($path);

  $s->context->config->web->www_root . $path;
}# end MapPath()


#==============================================================================
sub Mail
{
  my ($s, %args) = @_;

  # XXX: Base64-encode the content, and update the content-type to reflect that
  # if content-type === 'text/html'.
  # XXX: Consider updating this so that we can send attachments as well.
  Mail::Sendmail::sendmail( %args );
}# end Mail()


#==============================================================================
sub RegisterCleanup
{
  my ($s, $sub, @args) = @_;

  # This works both in "testing" mode and within a live mod_perl environment.
  $s->context->get_prop('r')->pool->cleanup_register( $sub, \@args );
}# end RegisterCleanup()


#==============================================================================
sub _utf8_chr
{
  my ($c) = @_;
  require utf8;
  my $u = chr($c);
  utf8::encode($u); # drop utf8 flag
  return $u;
}# end _utf8_chr()


#==============================================================================
sub DESTROY
{
  my $s = shift;

  undef(%$s);
}# end DESTROY()

1;# return true:


=pod

=head1 NAME

Apache2::ASP::Server - Utility methods for Apache2::ASP

=head1 SYNOPSIS

  my $full_path = $Server->MapPath('/index.asp');

  $Server->URLEncode( '[e-mail]' );

  $Server->URLDecode( 'user%40email.com' );

  $Server->HTMLEncode( '' );

  $Server->HTMLDecode( '<br />' );

  $Server->Mail(
    To      => '[e-mail]',
    From    => '"Friendly Name" ',
    Subject => 'Hello World',
    Message => "E Pluribus Unum.\n"x777
  );

  $Server->RegisterCleanup( sub {
      my @args = @_;
      ...
    }, @args
  );

=head1 DESCRIPTION

The ASP Server object is historically a wrapper for a few utility functions that
don't belong anywhere else.

Keeping with that tradition, the Apache2::ASP Server object is a collection of
functions that don't belong anywhere else.

=head1 PUBLIC METHODS

=head2 URLEncode( $str )

Converts a string into its url-encoded equivalent.  This approximates to
JavaScript's C function or L's C function.

Example:

  <%= $Server->URLEncode( '[e-mail]' ) %>

Returns

  user%40email.com

=head2 URLDecode( $str )

Converts a url-encoded string into its non-url-encoded equivalent.  This works
the same way as JavaScript's and L's C function.

Example:

  <%= $Server->URLDecode( 'user%40email.com' ) %>

Returns

  [e-mail]

=head2 HTMLEncode( $str )

Safely converts <, > and & into C<<>, C<>> and C<&>, respectively.

=head2 HTMLDecode( $str )

Converts C<<>, C<>> and C<&> into <, > and &, respectively.

=head2 MapPath( $relative_path )

Given a relative path, C will return the absolute path for it, under the
document root of the current website.

For example, C might return C

=head2 Mail( %args )

Sends an email message.  The following arguments are required:

=over 4

=item To

The email address the message should be sent to.

=item From

The email address the message should be sent from.

=item Subject

The subject of the email.

=item Message

The content of the body.

=back

Other arguments are passed through to L.

=head2 RegisterCleanup( \&code[, @args ] )

A wrapper around L's C function.  Pass in a coderef
and (optionally) arguments to be passed to that coderef, and it is executed during
the cleanup phase of the current request.

If we were doing vanilla mod_perl, you could achieve the same effect with this:

  $r->pool->cleanup_register( sub { ... }, \@args );

=head1 BUGS

It's possible that some bugs have found their way into this release.

Use RT L to submit bug reports.

=head1 HOMEPAGE

Please visit the Apache2::ASP homepage at L to see examples
of Apache2::ASP in action.

=head1 AUTHOR

John Drago

=head1 COPYRIGHT

Copyright 2008 John Drago.  All rights reserved.

=head1 LICENSE

This software is Free software and is licensed under the same terms as perl itself.

=cut