extractmeta

#!/usr/local/bin/perl -w
#
# Extract info from LINK and META and put them in an RDF file
#
# Reads from 'file' (default stdin) and writes to 'output'
# (default stdout). The URL of the input is assumed to be URL
# (default 'file').
#
# Bert Bos <bert@w3.org>
# $Id: extractmeta,v 1.3 2006-10-09 18:55:52 ihickson Exp $

use Getopt::Std;
#use lib 'bin';
#use utils;

$PROG = substr($0, rindex($0, "/") + 1);
$USAGE = "Usage: $PROG [-r realname] [file [output]]\n";

# $attvalre matches attribute values; the value is $1.$2.$3
$attvalre = '\s*=\s*(?:(\w+)|\"([^\"]+)\"|\'([^\']+)\')';


# clean replaces non-alphanum characters with '_', and collapses whitespace
sub clean {
    my $r = $_[0];
    $r =~ s/^\s+//o;
    $r =~ s/\s+/ /go;
    $r =~ s/ $//o;
    $r =~ tr/a-z/A-Z/;
    $r =~ s/[^A-z0-9_.-]/_/go;
    return lc($r);
}


# urlexpand expands a relative URL to an absolute one
sub urlexpand {
    my ($url, $base) = @_;
    my $result;
    if ($url =~ /^\w+:/) {	# Already absolute
	$result = $url;		# Keep as is
    } elsif ($url =~ /^\//o) {	# Starts with '/'
	$base =~ /^\w+:(\/\/[^\/]*\/?)?/o;
	$result = $&.$url;	# Prefix protocol and possibly machine
    } else {			# Starts with path segment
	$base =~ /[^\/:]*$/;
	$result = $`.$url;	# Prefix everything except last segment
	$result =~ s/[^\/]*\/\.\.//go;
    }
    return $result;
}


getopts('r:') || die $USAGE;
if ($#ARGV >= 0) {$file = $ARGV[0]; shift;} else {$file = '-';}
if ($#ARGV >= 0) {$output = $ARGV[0]; shift;} else {$output = '-';}
if ($#ARGV >= 0) {die $USAGE;}

my $url = defined $opt_r ? $opt_r : $file;

open(IN, $file) or die "$PROG: cannot read file $file\n";
open(OUT, ">$output") or die "$PROG: cannot write to file $output\n";

print OUT '<!--
  The database schema is defined as follows:
    - there is one table, called "meta"
    - it has three columns called "href", "property", and "value"
    - "href" is a URL
    - "property" is a keyword
    - "value" is a string
  The meaning of a record, paraphrased in English, is:
  "the _property_ property of the resource at _href_ has value _value_"
  There are further constraints on the value that depend on the property,
  but which are not spelled out here.
-->
';
print OUT "<RDF schema=\"http://www.w3.org/TR/REC-ACL\">\n";

$/ = '<';
while (<IN>) {
    if (/^link\b/sio) {
	if (/\brel$attvalre/sio) {
	    my $rel = clean(defined($1) ? $1 : defined($2) ? $2 : $3);
	    if (/\bhref$attvalre/sio) {
		my $href = urlexpand(defined($1)?$1:defined($2)?$2:$3, $url);
		print OUT "  <meta
    href=\"$url\"
    property=\"$rel\"
    value=\"$href\"/>\n";
		if (/\btype$attvalre/sio) {
		    my $type = lc(defined($1) ? $1 : defined($2) ? $2 : $3);
		    print OUT "  <meta
    href=\"$href\"
    property=\"content-type\"
    value=\"$type\"/>\n";
		}
		if (/\btitle$attvalre/sio) {
		    my $title = defined($1) ? $1 : defined($2) ? $2 : $3;
		    print OUT "  <meta
    href=\"$href\"
    property=\"title\"
    value=\"$title\"/>\n";
		}
		if (/\bmedia$attvalre/sio) {
		    my $h = lc(defined($1) ? $1 : defined($2) ? $2 : $3);
		    my @media = split("\w+", $h);
		    foreach my $h (@media) {
			print OUT "  <meta
    href=\"$href\"
    property=\"medium\"
    value=\"$h\"/>\n";
		    }
		}
	    }
	}
    } elsif (/^meta\b/sio) {
	if (/\bcontent$attvalre/sio) {
	    $value = defined($1) ? $1 : defined($2) ? $2 : $3;
	    if (/\b(?:name|http-equiv)$attvalre/sio) {
		$property = clean(defined($1) ? $1 : defined($2) ? $2 : $3);
		print OUT "  <meta
    href=\"$url\"
    property=\"$property\"
    value=\"$value\"/>\n";
	    }
	}
    }
}

print OUT "</RDF>\n";
close(IN);
close(OUT);