view release on metacpan or  search on metacpan

lib/Bot/Pastebot/WebUtil.pm  view on Meta::CPAN

# Rocco's POE web server helper functions.  Do URL en/decoding.  Load
# static pages, and do template things with them.
#
# TODO - We could probably replace them with an actual CPAN library or
# two.

package Bot::Pastebot::WebUtil;
$Bot::Pastebot::WebUtil::VERSION = '0.600';
use warnings;
use strict;

use CGI::Cookie;

use base qw(Exporter);
our @EXPORT_OK = qw(
  url_decode url_encode parse_content parse_cookie static_response
  dump_content dump_query_as_response base64_decode html_encode
  is_true cookie redirect
);

#------------------------------------------------------------------------------
# Build two URL-encoding maps.  Map non-printable characters to
# hexified ordinal values, and map hexified ordinal values back to
# non-printable characters.

my (%raw_to_url, %url_to_raw);

# Nonprintable characters
for (my $ord = 0; $ord < 256; $ord++) {
  my $character = chr($ord);
  my $hex = lc(unpack('H2', $character));

  # Map characters to their hex values, including the escape.
  $raw_to_url{ $character } = '%' . $hex;

  # Map hex codes (lower- and uppercase) to characters.
  $url_to_raw{    $hex } = $character;
  $url_to_raw{ uc $hex } = $character;
}

# Return a cookie string for a Set-Cookie header. The request argument is
# used to figure out domain.
sub cookie {
  my ($name, $value, $request) = @_;

  return CGI::Cookie->new(
    -name => $name,
    -value => $value,
    -expires => '+36M',
    -domain => (split /:/, $request->headers->header('Host'))[0],
    -path => '/',
  )->as_string;
}

# Decode url-encoded data.  This code was shamelessly stolen from
# Lincoln Stein's CGI.pm module.  Translate plusses to spaces, and
# then translate %xx sequences into their corresponding characters.
# Avoid /e on the regexp because "eval" is close to "evil".
sub url_decode {
  my $data = shift;
  return undef unless defined $data;
  $data =~ tr[+][ ];
  $data =~ s/%([0-9a-fA-F]{2})/$url_to_raw{$1}/g;
  return $data;
}

# Url-encode data.  This code was shamelessly stolen from Lincoln
# Stein's CGI.pm module.  Translate nonprintable characters to %xx
# sequences, and spaces to plusses.  Avoid /e too.
sub url_encode {
  my $data = shift;
  return undef unless defined $data;
  $data =~ s/([^a-zA-Z0-9_.:=\&\#\+\?\/-])/$raw_to_url{$1}/g;
  return $data;
}

# HTML-encode data.  More theft from CGI.pm.  Translates the
# blatantly "bad" html characters.
sub html_encode {
  my $data = shift;
  return undef unless defined $data;
  $data =~ s{&}{&amp;}gso;
  $data =~ s{<}{&lt;}gso;
  $data =~ s{>}{&gt;}gso;
  $data =~ s{\"}{&quot;}gso;
  # XXX: these bits are necessary for Latin charsets only, which is us.
  $data =~ s{\'}{&#39;}gso;
  $data =~ s{\x8b}{&#139;}gso;
  $data =~ s{\x9b}{&#155;}gso;
  return $data;
}

# Parse content.  This doesn't care where the content comes from; it
# may be from the URL, in the case of GET requests, or it may be from
# the actual content of a POST.  This code was shamelessly stolen from
# Lincoln Stein's CGI.pm module.
sub parse_content {
  my $content = shift;
  my %content;

  return \%content unless defined $content and length $content;

  foreach (split(/[\&\;]/, $content)) {
    my ($param, $value) = split(/=/, $_, 2);
    $param = &url_decode($param);
    $value = &url_decode($value);

    if (exists $content{$param}) {
      if (ref($content{$param}) eq 'ARRAY') {
        push @{$content{$param}}, $value;
      }
      else {
        $content{$param} = [ $content{$param}, $value ];
      }
    }
    else {
      $content{$param} = $value;
    }
  }

  return \%content;
}

# Parse a cookie string (found usually in the Cookie: header), returning a 
# hashref containing cookies values, not CGI::Cookie objects.
sub parse_cookie {
  my ($cookie) = @_;

  return {} if not defined $cookie;
  return { map url_decode($_), map /([^=]+)=?(.*)/s, split /; ?/, $cookie };
}

sub _render_template {
  my ($template, $filename, $record) = @_;

  my ($content, $error) = ('', 0);
  if (open(my $template_fh, "<", $filename)) {

    $content = eval { $template->process($template_fh, $record) };

    if ($@ || !defined $content || !length $content) {
      my $template_error = $template->error || 'unknown error';
      $error = 1;
      $content = (
        "<html><head><title>Template Error</title></head>" .
        "<body>Error processing $filename: $template_error</body></html>"
      );
    }
  } else {
    $error = 1;
    $content = (
      "<html><head><title>Template Error</title></head>" .
      "<body>Error opening $filename: $!</body></html>"
    );
  }

  return +{
    content => $content,
    error => $error,
  };
}

# Generate a static response from a file.
sub static_response {
  my ($template, $filename, $record) = @_;

  my $code = 200;
  my $result = _render_template( $template, $filename, $record );
  $code = 500 if $result->{error};

  my $response = HTTP::Response->new($code);
  $response->push_header('Content-type', 'text/html');
  $response->content( $result->{content} );

  if (wantarray()) {
    return(1, $response);
  }
  return $response;
}

# redirect to a paste
sub redirect {
  my ($template, $filename, $record, $response_code) = @_;

  my $response = HTTP::Response->new( $response_code || 303 );