File Coverage

blib/lib/Devel/Pillbug.pm

Criterion	Covered	Total	%
statement	9	9	100.0
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	12	12	100.0

package Devel::Pillbug::MasonHandler;

use strict;
use warnings;

use base qw| HTML::Mason::CGIHandler |;

### CGIHandler evals stuff before we can check on the result code,
### which can make it hard or impossible to trap specific errors.
###
### Avoid this by delegating to H~::M~::Request's exec method instead.
sub exec {
  my $self = shift;

  return HTML::Mason::Request::exec( $self, @_ );
}

package Devel::Pillbug;

our $VERSION = 0.006;

use strict;
use warnings;

use File::HomeDir;
use Media::Type::Simple;

### Media::Type::Simple's internal use of a cached filehandle makes
### it not usable when forking, and its internal use of private globals
### makes it hard to subclass.
###
### Sadly, Media::Type::Simple is currently the best thing going on CPAN
### in terms of guessing MIME types from file extensions, so... until
### its author applies a fix for this very common problem (or something
### better comes along), I am adapting Jos Boumans's workaround from
### rt.cpan.org #46474:
do {
  no strict "refs";

  *{"Media::Type::Simple::__new"} = sub {
    my $class = shift;
    my $self = { types => {}, extens => {}, };

    bless $self, $class;

    if (@_) {
      my $fh = shift;
      return $self->add_types_from_file($fh);
    } else {
      my $offset = tell Media::Type::Simple::DATA;

      $Media::Type::Simple::Default =
        $self->add_types_from_file( \*Media::Type::Simple::DATA );

      seek Media::Type::Simple::DATA, $offset, 0;

      return clone $Media::Type::Simple::Default;
    }
    }
};

use base qw| HTTP::Server::Simple::Mason |;

use constant DefaultServerType   => "Net::Server::PreFork";
use constant DefaultHandlerClass => "Devel::Pillbug::MasonHandler";

use constant DefaultIndexName => "index";
use constant DefaultCompExt   => "html";

our $serverType   = DefaultServerType;
our $handlerClass = DefaultHandlerClass;

#
#
#
sub net_server {
  my $class         = shift;
  my $newServerType = shift;

  if ($newServerType) {
    if ( !UNIVERSAL::isa( $newServerType, "Net::Server" ) ) {
      warn "net_server() requires a Net::Server subclass";
    }

    $serverType = $newServerType;
  }

  return $serverType;
}

#
#
#
sub handler_class {
  my $class           = shift;
  my $newHandlerClass = shift;

  if ($newHandlerClass) {
    if ( !UNIVERSAL::isa( $newHandlerClass, "HTML::Mason::Request" ) ) {
      warn "handler_class() requires a HTML::Mason::Request subclass";
    }

    $handlerClass = $newHandlerClass;
  }

  return $handlerClass;
}

#
#
#
sub pretty_html_header {
  my $self   = shift;
  my $header = shift;

  if ($header) {
    $self->{_html_header} = $header;

    return;
  }

  if ( defined $self->{_html_header} ) {
    print $self->{_html_header};

    return;
  }

  print "\n";
  print "\n";
  print "\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="131">131</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  body {\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="132">132</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "    background: #fff; color: #333;\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="133">133</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  }\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="134">134</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  body, td {\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="135">135</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "    font-family: verdana, sans-serif;\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="136">136</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "    font-size: 11px;\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="137">137</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  }\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="138">138</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  td {\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="139">139</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "    border-bottom: 1px dotted #999;\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="140">140</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  }\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="141">141</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  h1 {\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="142">142</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "    color: #999;\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="143">143</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  }\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="144">144</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  pre {\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="145">145</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "    white-space: pre-wrap;\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="146">146</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "    background: #ccc; color: #000;\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="147">147</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "    margin: 6px; padding: 6px;\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="148">148</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "  }\n"; </td>
</tr>

<tr>
<td  class="h" >
<a name="149">149</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   print "\n";
  print "\n";
  print "\n";
}

#
#
#
sub pretty_html_footer {
  my $self   = shift;
  my $footer = shift;

  if ($footer) {
    $self->{_html_footer} = $footer;

    return;
  }

  if ( $self->{_html_footer} ) {
    print $self->{_html_footer};

    return;
  }

  my @time = localtime();
  my $time = sprintf(
    '%i-%02d-%02d %02d:%02d:%02d %s',
    $time[5] + 1900,
    $time[4] + 1,
    $time[3], $time[2], $time[1], $time[0], POSIX::strftime( '%Z', @time )
  );

  print "$time\n";
  print "\n";
  print "\n";
}

#
#
#
sub docroot {
  my $self    = shift;
  my $docroot = shift;

  $self->{_docroot} = $docroot if $docroot;

  if ( !$self->{_docroot} ) {
    my $home = File::HomeDir->my_home;

    my $pubHtml = join "/", $home, "public_html";
    my $sites   = join "/", $home, "Sites";

    $self->{_docroot} = ( -d $sites ) ? $sites : $pubHtml;
  }

  if ( !-d $self->{_docroot} ) {
    warn "docroot $self->{_docroot} is not a usable directory";
  }

  return $self->{_docroot};
}

#
#
#
sub allow_index {
  my $self = shift;

  $self->{_allow_index} ||= 0;

  if ( scalar(@_) ) {
    $self->{_allow_index} = $_[0] ? 1 : 0;
  }

  return $self->{_allow_index};
}

#
#
#
sub index_name {
  my $self  = shift;
  my $index = shift;

  $self->{_index} = $index if $index;

  $self->{_index} ||= DefaultIndexName;

  return $self->{_index};
}

#
#
#
sub comp_ext {
  my $self = shift;
  my $ext  = shift;

  $self->{_ext} = $ext if $ext;

  $self->{_ext} ||= DefaultCompExt;

  return $self->{_ext};
}

#
#
#
sub mason_config {
  my $self = shift;

  return ( comp_root => $self->docroot() );
}

#
#
#
sub _handle_mason_request {
  my $self = shift;
  my $cgi  = shift;
  my $path = shift;

  my $r = HTML::Mason::FakeApache->new( cgi => $cgi );
  my $buffer;

  ###
  ### Brutal and tempoorary workaround for undef warnings caused
  ### by anonymous components calling other components.
  ###
  ### https://rt.cpan.org/Public/Bug/Display.html?id=55159
  do {
    no strict "refs";
    no warnings "redefine";

    *{"HTML::Mason::Component::dir_path"} = sub { return "" };
  };

  eval {
    my $m = $self->mason_handler;

    my $comp = $m->interp->make_component( comp_file => $path );

    my $req = $m->interp->make_request(
      comp         => $comp,
      args         => [ $cgi->Vars ],
      cgi_request  => $r,
      out_method   => \$buffer,
      error_mode   => "fatal",
      error_format => "text",
    );

    $r->{http_header_sent} = 1;

    $m->interp->set_global( '$r', $r );

    $req->exec;
  };

  #
  #
  #
  if ( $@ && ( !$r->status || ( $r->status !~ /^302/ ) ) ) {
    $r->status("500 Internal Server Error");

    return $self->_handle_error( $r, $@ );
  } elsif ( !$r->status ) {
    $r->status("200 OK");
  }

  #
  #
  #
  my $header = $r->http_header;
  $header =~ s|^Status:|HTTP/1.0|;

  print $header;

  print $buffer if $buffer;
}

sub _handle_directory_request {
  my $self = shift;
  my $r    = shift;

  my $fsPath   = shift;
  my $compPath = shift;

  print "HTTP/1.0 200 OK\r\n";
  print "Content-Type: text/html\r\n";
  print "\r\n";

  $self->pretty_html_header();

  print "Index of $compPath\n";

  print "\n"; \n"; \n"; \n"; \n"; \n"; \n"; \n"; \n"; \n"; \n"; \n"; \n"; 




345




 





 





 





 





 





 



   print "  




346




 





 





 





 





 





 



   print "    Name




347




 





 





 





 





 





 



   print "    Type




348




 





 





 





 





 





 



   print "    Last Modified




349




 





 





 





 





 





 



   print "    Size




350




 





 





 





 





 





 



   print "  




351




 





 





 





 





 





 



   




352




 





 





 





 





 





 



   my %conf = $self->mason_config; 




353




 





 





 





 





 





 



   




354




 





 





 





 





 





 



   my @files; 




355




 





 





 





 





 





 



   




356




 





 





 





 





 





 



   if ( $compPath ne "/" ) { push @files, ".." } 




357




 





 





 





 





 





 



   




358




 





 





 





 





 





 



   for (<$fsPath/*>) { push @files, $_ } 




359




 





 





 





 





 





 



   




360




 





 





 





 





 





 



   for (@files) { 




361




 





 





 





 





 





 



     my $path = $_; 




362




 





 





 





 





 





 



   




363




 





 





 





 





 





 



     my @stat = stat($path); 




364




 





 





 





 





 





 



   




365




 





 





 





 





 





 



     my $type; 




366




 





 





 





 





 





 



     my $size; 




367




 





 





 





 





 





 



   




368




 





 





 





 





 





 



     if ( -d $path ) { 




369




 





 





 





 





 





 



       $path .= '/'; 




370




 





 





 





 





 





 



       $type = "directory"; 




371




 





 





 





 





 





 



       $size = "-"; 




372




 





 





 





 





 





 



     } else { 




373




 





 





 





 





 





 



       my $ext = $path; 




374




 





 





 





 





 





 



       $ext =~ s/.*\.//; 




375




 





 





 





 





 





 



       my $o = Media::Type::Simple->__new(); 




376




 





 





 





 





 





 



       eval { $type = $o->type_from_ext($ext); }; 




377




 





 





 





 





 





 



       $type ||= "application/octet-stream"; 




378




 





 





 





 





 





 



       $size = $stat[7]; 




379




 





 





 





 





 





 



     } 




380




 





 





 





 





 





 



   




381




 





 





 





 





 





 



     $path =~ s/^$conf{comp_root}$compPath\///; 




382




 





 





 





 





 





 



   




383




 





 





 





 





 





 



     my @time = localtime( $stat[9] ); 




384




 





 





 





 





 





 



     my $time = sprintf( 




385




 





 





 





 





 





 



       '%i-%02d-%02d %02d:%02d:%02d %s', 




386




 





 





 





 





 





 



       $time[5] + 1900, 




387




 





 





 





 





 





 



       $time[4] + 1, 




388




 





 





 





 





 





 



       $time[3], $time[2], $time[1], $time[0], POSIX::strftime( '%Z', @time ) 




389




 





 





 





 





 





 



     ); 




390




 





 





 





 





 





 



   




391




 





 





 





 





 





 



     print "  




392




 





 





 





 





 





 



     print "    $path




393




 





 





 





 





 





 



     print "    $type




394




 





 





 





 





 





 



     print "    $time




395




 





 





 





 





 





 



     print "    ${ size }




396




 





 





 





 





 





 



     print "  




397




 





 





 





 





 





 



   } 




398




 





 





 





 





 





 



   




399




 





 





 





 





 





 



   print "\n";
  print "
  print "
  print "
  print "
  print "
  print "

  my %conf = $self->mason_config;

  my @files;

  if ( $compPath ne "/" ) { push @files, ".." }

  for (<$fsPath/*>) { push @files, $_ }

  for (@files) {
    my $path = $_;

    my @stat = stat($path);

    my $type;
    my $size;

    if ( -d $path ) {
      $path .= '/';
      $type = "directory";
      $size = "-";
    } else {
      my $ext = $path;
      $ext =~ s/.*\.//;
      my $o = Media::Type::Simple->__new();
      eval { $type = $o->type_from_ext($ext); };
      $type ||= "application/octet-stream";
      $size = $stat[7];
    }

    $path =~ s/^$conf{comp_root}$compPath\///;

    my @time = localtime( $stat[9] );
    my $time = sprintf(
      '%i-%02d-%02d %02d:%02d:%02d %s',
      $time[5] + 1900,
      $time[4] + 1,
      $time[3], $time[2], $time[1], $time[0], POSIX::strftime( '%Z', @time )
    );

    print "
    print "
    print "
    print "
    print "
    print "
  }

  print "

  $self->pretty_html_footer();
}

sub _handle_document_request {
  my $self = shift;
  my $r    = shift;

  my $fsPath   = shift;
  my $compPath = shift;

  my $ext = $fsPath;
  $ext =~ s/.*\.//;
  my $o = Media::Type::Simple->__new();
  my $type;
  eval { $type = $o->type_from_ext($ext); };
  $type ||= "application/octet-stream";

  my @out;

  eval {
    open( IN, "<", $fsPath ) || die $!;
    while () { push @out, $_ }
    close(IN);
  };

  if ($@) {
    return $self->_handle_error( $r, $@ );
  }

  print "HTTP/1.0 200 OK\r\n";
  print "Content-Type: $type\r\n";
  print "\r\n";

  while (@out) { print shift @out }
}

sub _handle_notfound_request {
  my $self = shift;
  my $r    = shift;

  my $fsPath   = shift;
  my $compPath = shift;

  print "HTTP/1.0 404 Not Found\r\n";
  print "Content-Type: text/html\r\n";
  print "\r\n";

  $self->pretty_html_header();

  print "Not Found\n";
  print "The requested URL $compPath was not found on this server.\n";

  $self->pretty_html_footer();
}

sub _handle_error {
  my $self = shift;
  my $r    = shift;

  my $err = shift;

  # $err =~ s/at \S+ line \d+.*//;

  $err = HTML::Entities::encode_entities($err);

  print "HTTP/1.0 500 Internal Server Error\r\n";
  print "Content-type: text/html\r\n";
  print "\r\n";

  $self->pretty_html_header();

  print "Internal Server Error\n";
  print "The server could not complete your request. The error was:\n";
  print "$err\n";

  $self->pretty_html_footer();
}

sub _handle_directory_redirect {
  my $self     = shift;
  my $compPath = shift;

  my $url = sprintf 'http://%s:%s%s/', $self->host, $self->port, $compPath;

  print "HTTP/1.0 302 Moved\r\n";
  print "Location: $url\r\n";
  print "\r\n";

  $self->pretty_html_header();

  print "Moved\n";
  print "The document is available here.\n";

  $self->pretty_html_footer();
}

#
# Override HTTP::Server::Simple::Mason to also deal with document requests,
# directory listings, and 404s
#
sub handle_request {
  my $self = shift;
  my $r    = shift;

  local $@;

  my %conf = $self->mason_config;
  my $m    = $self->mason_handler;

  my $compPath = $r->path_info;
  my $fsPath = join "", $conf{comp_root}, $compPath;

  my $ext = $self->comp_ext;

  my $indexFilename = join ".", $self->index_name, $ext;

  if ( -d $fsPath
    && $compPath !~ m{/$}
    && ( -e join( "/", $fsPath, $indexFilename ) || $self->allow_index ) )
  {
    return $self->_handle_directory_redirect($compPath);

  } elsif ( -d $fsPath ) {
    my $indexPath = join "/", $fsPath, $indexFilename;

    if ( -e $indexPath ) {
      $compPath .= $indexFilename;
      $fsPath   .= $indexFilename;

      $r->path_info($compPath);
    }
  }

  eval {
    if ( $compPath =~ /$ext$/ && $m->interp->comp_exists($compPath) )
    {
      $self->_handle_mason_request( $r, $fsPath, $compPath );

    } elsif ( $self->allow_index && -d $fsPath ) {
      $self->_handle_directory_request( $r, $fsPath, $compPath );

    } elsif ( !-d $fsPath && -e $fsPath ) {
      $self->_handle_document_request( $r, $fsPath, $compPath );

    } else {
      $self->_handle_notfound_request( $r, $fsPath, $compPath );

    }
  };

  if ($@) {
    warn $@;
  }
}

1;
__END__