The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w

use strict;

use HTTP::Date qw(time2iso);
require "db.pl";
use vars qw($dbh);

if (@ARGV == 1 && $ARGV[0] =~ /^\d+$/) {
    my $id = shift;
    my $sth = $dbh->query("select scheme, host, port, abs_path, uri.last_visit, status_code, message, last_mod, etag, entity, content_type from server, uri where server.id = uri.server and uri.id = $id") or die $dbh->errmsg;
    unless ($sth->numrows) {
	die "None found $id\n";
    }
    my($scheme,$host,$port,$abs_path,$last_visit,$code,$mess,
       $last_mod,$etag,$eid,$ctid) = $sth->fetchrow;
    print "URL: ", make_url($scheme, $host, $port, $abs_path), "\n";
    print "Last-Visit: ", time2iso($last_visit), "\n" if $last_visit;
    print "Status: $code $mess\n" if $code;
    if ($ctid) {
	$sth = $dbh->query("select name from media_types where id=$ctid") or die $dbh->errmsg;
	my($name) = $sth->fetchrow;
	my $ct = $name ? $name : "#$ctid";
	print "Content-Type: $ct\n";
    }
    print "Last-Modified: ", time2iso($last_mod), "\n" if $last_mod;
    print "ETag: $etag\n" if $etag;

    my @r;
    if ($eid) {
	print "Entity-ID: $eid\n";
	@r= $dbh->query("select id from uri where entity=$eid and id<>$id order by id")->fetchcol(0);
	print "Same-Entity-As: @r\n" if @r;
    }

    @r= $dbh->query("select dest from links where src = $id order by dest")->fetchcol(0);
    print "References: @r\n" if @r;

    @r = $dbh->query("select src from links where dest = $id order by src")->fetchcol(0);
    print "Referenced-By: @r\n" if @r;

    exit;
}

my $extra = join(" ", @ARGV);
substr($extra,0,0) = " AND " if $extra;

my $sql = "SELECT uri.id, scheme, host, port, abs_path, status_code FROM server, uri WHERE server.id = uri.server$extra";
print STDERR "$sql\n";

my $sth = $dbh->query($sql) or die $dbh->errmsg;

while (my($id, $scheme,$host,$port,$abs_path,$code) = $sth->fetchrow) {
   $code = "---" unless $code;
   my $url  = make_url($scheme,$host,$port,$abs_path);
   print "$code $url #$id\n";
}

sub make_url
{
    my($scheme,$host,$port,$abs_path) = @_;
   if ($port) {
       if ($scheme eq "http" && $port == 80) {
	   $port = "";
       } else {
	   $port = ":$port";
       }
   } else {
       $port = "";
   }
   "$scheme://$host$port$abs_path";
}