view release on metacpan or  search on metacpan

lib/App/tarweb.pm  view on Meta::CPAN

    my %dedupe;

    $app = Plack::Builder->new;

    $app->mount("/favicon.ico" => sub ($env) {
      my $res = [ 200, [ 'Content-Type' => 'image/vnd.microsoft.icon' ], [ '' ] ];
      $res->[2]->[0] = path(dist_share(__PACKAGE__))->child('favicon.ico')->slurp_raw;
      push $res->[1]->@*, 'Content-Length' => length $res->[2]->[0];
      return $res;
    });
    $dedupe{"favicon.ico"} = 1;

    my $tt;

    foreach my $fspath (map { path($_) } @ARGV)
    {
      if(-r $fspath)
      {
        my $path = $fspath->basename;

        # make the URL path unique
        {
          my $suffix = '';
          my $i = 0;
          while($dedupe{"$path$suffix"})
          {
            $suffix = "-@{[ $i++ ]}";
          }

          $path .= $suffix;
          $dedupe{$path} = 1;
        }

        push @paths, "/$path/";

        my $subapp = Plack::App::Libarchive->new( archive => $fspath, @pa_la_args );

        $app->mount( "/$path/" => $subapp->to_app );

        $tt ||= $subapp->tt;
      }
      else
      {
        say STDERR "unable to read $fspath, skipping";
      }
    }

    unless($tt)
    {
      say STDERR "no archive file given!";
      return 2;
    }

    $app->mount("/" => sub ($env) {
      my $html;
      $tt->process('index.html.tt', {
        title    => 'archives',
        archives => [ sort grep { $_ ne 'favicon.ico' } keys %dedupe ],
      }, \$html);
      $html = encode('UTF-8', $html, Encode::FB_CROAK);
      return [ 200, [ 'Content-Type' => 'text/html; charset=utf-8', 'Content-Length' => length $html ], [ $html ] ];
    });

  }

  $runner->run($app->to_app);

  return 0;
}

sub _random_port ($)
{
  IO::Socket::INET->new(
    Listen => 5,
    LocalAddr => '127.0.0.1',
  )->sockport;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

App::tarweb - Open an archive file in your web browser!

=head1 VERSION

version 0.01

=head1 SYNOPSIS

 $ tarweb foo.tar.gz

=head1 DESCRIPTION

This class just contains the machinery of the L<tarweb> application.

=head1 SEE ALSO

=over 4

=item L<tarweb>

=back

=head1 AUTHOR

Graham Ollis <plicease@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2022 by Graham Ollis.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.