Category: | Web |
Author/Contact Info | Randal L. Schwartz |
Description: | Inspired by "Serving tarball contents as part of your webspace (impractical but fun), I wrote one of my own, for a column, of course! Code is here... the text to the column will be online in a few months.
update: The column is now online. |
#!/usr/bin/perl -w
use strict;
$|++;
use CGI::Carp qw(fatalsToBrowser); # DEBUG only
## begin config
my $DIR = "/home/merlyn/Web/Tarserver";
sub VALID {
local $_ = shift;
/(\.tgz|\.tar(\.gz)?)\z/ && !/\A\./;
}
## end config
use CGI qw(:all);
(my $path = path_info()) =~ s/\A\///;
my @path = split '/', $path;
my @choices;
if (@path) { # first element must be tar.gz
die "bad tar name: $path[0]" unless VALID($path[0]);
my $tarchive = "$DIR/$path[0]";
die "missing tarchive: $tarchive" unless -f $tarchive and -r $tarchi
+ve;
## must look in contents now
my @names = do {
require Cache::FileCache;
my $cache = Cache::FileCache->new
({namespace => 'tarserver',
username => 'nobody',
default_expires_in => '10 minutes',
auto_purge_interval => '1 hour',
}) or die "Cannot connect to cache";
if (my $names = $cache->get($tarchive)) {
@$names;
} else {
require Archive::Tar;
die "Cannot list archive $tarchive"
unless my @n = Archive::Tar->list_archive($tarchive);
$cache->set($tarchive, \@n);
@n;
}
};
for my $step (1..$#path) {
@names = map /\A\/?\Q$path[$step]\E(?:\/(.*))?\z/s, @names;
die "no such name" unless @names;
if (grep !defined $_, @names) {
die "trailing stuff after name" if $step != $#path;
require Archive::Tar;
my $at = Archive::Tar->new($tarchive)
or die "Cannot open archive $tarchive";
my $file = join "/", @path[1..$#path];
defined(my $contents = $at->get_content($file))
or die "Cannot get $file from $tarchive";
require File::MMagic;
my $mimetype = File::MMagic->new->checktype_contents($contents);
print header($mimetype), $contents;
exit 0;
}
}
{
my %choices = ();
$choices{$_}++ for map /\A([^\/]+\/?)/, @names;
@choices = sort keys %choices;
}
} else { # choose a top-level item
opendir D, $DIR;
@choices = sort grep VALID($_), readdir D;
closedir D;
}
print header('text/html'), start_html('tar server'), h1('tar server');
## show path
print "from ", a({href => url()}, "Top");
{
my $link = "";
for (@path) {
$link .= "/$_";
print " / ", a({href => url().$link}, escapeHTML("$_"));
}
}
print br;
## show sublinks
my $prefix = @path ? join("/", @path, "") : "";
print ul(map {
li(a({href => url()."/$prefix$_"}, escapeHTML($_)));
} @choices);
print end_html;
|
|
---|
Replies are listed 'Best First'. | |
---|---|
Re: Serving many tarballs as part of your web space
by Aristotle (Chancellor) on Jan 11, 2002 at 09:36 UTC | |
by jryan (Vicar) on Jan 11, 2002 at 14:12 UTC | |
by merlyn (Sage) on Jan 11, 2002 at 12:36 UTC | |
by Aristotle (Chancellor) on Jan 11, 2002 at 18:59 UTC |
Back to
Code Catacombs