File Coverage

blib/lib/WWW/Resource.pm

Criterion	Covered	Total	%
statement	28	30	93.3
branch			n/a
condition			n/a
subroutine	10	10	100.0
pod			n/a
total	38	40	95.0

package WWW::Resource;

use 5.008006;
use strict;
use vars qw( $VERSION );
use warnings;

$VERSION = '0.01';

use Data::Dumper;

use FCGI;
use IO::Handle;
use CGI qw(:standard); # convenience functions
use HTTP::Status;

use XML::Dumper;
XML::Dumper::dtd;

use JSON;

my %formats = (
  xml  => \&pl2xml,
  json => sub { objToJson( $_[0], {pretty => 1, indent => 4} ) },
  browser => \&browserprint,
);

our $TTL = 60 * 60;    # time-to-live is 1 hr by default

sub run {
  my $package = bless {}, shift;
  my $STARTTIME = time;

  # install the pretty printer from the subclass, if it exists
  if( my $printer = $package->can("browserprint") ){
    $formats{browser} = $printer;
  }

  # how much time could a ttl live if a ttl could live time?
  $TTL = $package->ttl if $package->can("ttl");

  my $request = FCGI::Request;
  while ( $request->Accept >= 0 ) {

    my $method = $ENV{REQUEST_METHOD};

    if ( my $handler = $package->can($method) ) {

      my %query = map { split /=/ } split /;/, lc $ENV{QUERY_STRING};
      my( $status, $obj ) = $handler->(\%query);
      return_result(  $status, $obj );

    }
    else {
      return_result( RC_NOT_IMPLEMENTED );
    }

    # Time to leave?
    exit if ( time - $STARTTIME ) > $TTL;
  }
}

sub return_result {
  my ( $status, $obj ) = @_;
  my $status_msg = join " ", $status, status_message($status);

  if ( is_error($status) or !defined $obj ) {
    print header( -status => $status_msg );
    return;
  }

  my %query = map { split /=/ } split /;/, lc $ENV{QUERY_STRING};
  my $formatter = $formats{json};
  $formatter = $formats{ $query{format} }
        if (exists $query{format}
        and exists $formats{ $query{format} });

  print header( -status => $status_msg );

  print ref $obj ? $formatter->($obj) : $obj;
  return;
}


# Format the data structure for browser viewing. This is an incredibly
# stupid prettyprint. It simply places an html break at all newlines.
sub browserprint {
  my $obj = shift;
  my $dumped = Dumper $obj;
  substr($dumped, 0, 7) = '';
  $dumped =~ s/\n/\n/g;
  return start_html("Pretty-printed Data Structure") . $dumped . end_html;
}


1;


__END__