Dublin Core Metadata

#!/usr/bin/perl use lib "/opt/metadata/roads/elib-papers/lib"; # roads2metadc.pl: Output ROADS DUBLINCORE record as RDF, HTML Meta Tags # or displayable HTML. # # Author: Tracy Gardner # Original Author: Andy Powell # # $Id: roads2metadc.pl,v 1.1 1999/03/12 09:25:31 listag Exp listag $ # # Description: # All of the records must be in a single directory. # ############################################################################# # Order in which to output elements %order = ('Title', 1, 'Creator', 2, 'Subject', 5, 'Description', 6, 'Publisher', 7, 'Contributor', 10, 'Date', 13, 'Type', 14, 'Format', 15, 'Identifier', 16, 'Source', 17, 'Language', 18, 'Relation', 19, 'Coverage', 20, 'Rights', 21); %clusters = ('Creator', 1, 'Publisher', 1, 'Contributor', 1); ############################################################################# use Getopt::Std; require ROADS; use ROADS::ErrorLogging; #$ENV{QUERY_STRING} = "911840794-12501"; if($ENV{QUERY_STRING}) # we're being called as a cgi script # generate a web page { $opt_w = 1; $filename = $ENV{QUERY_STRING}; $IafaSourceDir = $ROADS::IafaSource; } else { # Process the command line options getopts('2mhwds:'); $debug = $opt_d || 0; $IafaSourceDir = $opt_s || $ROADS::IafaSource; $filename = $ARGV[0]; unless ($filename and ($filename ne '(none)')) { &WriteToErrorLogAndDie("roads2metadc", "No handle provided."); # Get current URL from environment and search for it... #&WriteToErrorLogAndDie("roads2metadc", "URL search not implemented!"); } } if($opt_w) { if($filename eq '(none)') { print "Content-type: text/html\n\n"; print "\n\nDublin Core Metadata\n\n"; print "\n"; print "

Sorry, no metadata available.

"; print "\n\n"; &WriteToErrorLogAndDie("roads2metadc", "No handle provided."); } } chdir($IafaSourceDir); %multiple; open(RECORDFILE, $filename) || &WriteToErrorLogAndDie("roads2metadc", "Can't open $filename: !"); while () { next if (/^Handle:\s+/i); next if (/^Destination:\s+/i); next if (/^Comments:\s+/i); next if (/^Record-Last-Modified-.*:\s+/i); next if (/^Record-Created-.*:\s+/i); next if (/^Template-Version:\s+/i); if (/^Template-Type:\s+(\w+)/i) { &WriteToErrorLogAndDie("roads2metadc", "Non-DUBLINCORE record!") unless ($1 eq 'DUBLINCORESIMPLE'); } next if (/^Template-Type:\s+/i); $line = $_; if (/^([\w-]+)\:\s*(.*)/) { $elt = $1; # print $elt . "\n"; $line = $2; if($elt =~ /^([\w]+)([^\d]*)?(-v\d*)$/) { $current_attr = $1; $sub = $2; $variant = $3; } else { $elt =~ /([\w]+)([^\d]*)/; $current_attr = $1; $sub = $2; $variant = ''; } $current_attr=$1; # print $current_attr . "*" . $sub . "*" . $variant . "\n"; if(exists $clusters{$current_attr}) { next unless ($sub =~ /Name/); } else { $current_attr .= $sub; } if($3)# May have multiple versions { @multiple{$current_attr} .= "%%" . $line; # print @multiple{$current_attr} . "\n"; } $current_attr .= $variant; # $current_attr =~ y/A-Z/a-z/; } $RECORD{"$current_attr"} =~ s/$/$line/; } close(RECORDFILE); if ($opt_m) { &WriteMeta; } elsif($opt_h) { &WriteHTML; } elsif($opt_w) { &WriteWebPage; } else { &WriteRDF; } exit; ############################################################################## # HTML Generation ############################################################################## sub WriteHTML { print "\n"; foreach $attr (sort compare (keys %RECORD)) { next if ($attr =~ /-Scheme/i); undef $v; undef $scheme; if ($attr =~ /(.*)(-v\d+)/) { $attr = $1; $v = $2; } if ($RECORD{$attr."-Scheme".$v}) { $scheme = $RECORD{$attr."-Scheme".$v}; } $e = $attr; $e =~ s/-/./g; $outval = $RECORD{$attr.$v}; if(($e =~ /Identifier/) or ($e =~ /Relation/)) { $outval = "$outval"; } if($e =~ /Email/) { $outval = "$outval"; } print "\n"; } print "

DC.$e

$outval

\n"; } sub WriteWebPage { print "Content-type: text/html\n\n"; print "\n\nDublin Core Metadata\n\n"; print "\n"; &WriteHTML; print "\n\n"; } ############################################################################## # HTML META Tag Generation ############################################################################## sub WriteMeta { print "\n"; foreach $attr (sort compare (keys %RECORD)) { next if ($attr =~ /-Scheme/i); undef $v; undef $scheme; if ($attr =~ /(.*)(-v[0-9]+)/) { $attr = $1; $v = $2; } if ($RECORD{$attr."-Scheme".$v}) { $scheme = $RECORD{$attr."-Scheme".$v}; } $e = $attr; $e =~ s/-/./g; # print "\n"; &WriteMetaTag($e, $scheme, $RECORD{$attr.$v}); } print "\n"; } # Write out an HTML META tag # sub WriteMetaTag { my ($name, $scheme, $content) = @_; return unless $content; $content =~ s/^\s+//; $content =~ s/\s+$//; if ($opt_2) { # HTML 3.2 or lower if ($scheme) { $scheme =~ s/^/(SCHEME=/; $scheme =~ s/$/) /; } &fprint("", "\n"); } else { # HTML 4.0 or greater if ($scheme) { $scheme =~ s/^/SCHEME="/; $scheme =~ s/$/" /; } &fprint("", "\n"); } } ############################################################################## # RDF Generation ############################################################################## sub WriteRDF { return unless $RECORD{'Identifier-v1'}; my $id = $RECORD{'Identifier-v1'}; &RDFBegin; print qq| 1) { push(@bag, $attr); next; } $e = $attr; $e =~ s/-/./g; if($numvals == 1) { $outputstring = $RECORD{$attr.$v}; &fprint(" ", "dc:$e=" . '"' . $outputstring . '"'); } } if(@bag > 0) # there are some elements with multiple values { print qq|> |; foreach $bagelt (@bag) { &RDFPrintBag($bagelt); } print qq| |; } else { print qq|/> |; } &RDFEnd; } sub RDFPrintBag # # # { my $attr = shift; my $vals = @multiple{$attr}; if($attr =~ /Identifier/) { # remove the -v1 variant, this already appears in the RDF $id = $RECORD{'Identifier-v1'}; $vals =~ s/%%$id//; } my @vals = split(/%%/, $vals); &fprint(" ", ""); &fprint(" ", ""); &fprint(" ", ""); } sub RDFBegin { print qq| |; } sub RDFEnd { print qq| |; } ############################################################################## # Utils ############################################################################## sub compare # compare elements to see which should come first { $a =~ /^(\D*)(-v(\d*))?$/; my $abase = $1; my $va = $3; $b =~ /^(\D*)(-v(\d*))?$/; my $bbase = $1; my $vb = $3; my $posa = $order{$abase}; my $posb = $order{$bbase}; unless ($posa or $posb) { return 0; } unless($posa){ return 1; } unless($posb){ return -1; } my $compare = $posa <=> $posb; if ($compare == 0){ $compare = ($va <=> $vb); } return $compare; } # Formated print # sub fprint { my ($prefix, $val) = @_; if($val =~ /$http:\/\//) { print $prefix . $val . "\n"; } else { eval "format main::STDOUT = $prefix^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~ \$val . "; write; } } =head1 NAME B - output ROADS DUBLINCORE record as RDF, HTML META tags or displayable HTML =head1 SYNOPSIS B [B<-d>] [B<-s> ] [B<-m>] [B<-h>] [B<-w>] [B<-2>] [I] =head1 DESCRIPTION This Perl program takes the handle of a ROADS DUBLINCORE record as an argument and generates either a set of HTML META tags or some RDF. =head1 OPTIONS =over 4 =item B<-d> Generate debugging information =item B<-s> I Change the source directory from the default =item B<-m> Generate HTML META tags instead of RDF =item B<-h> Generate HTML to be embedded in a web page (e.g. via SSI) =item B<-w> Generate HTML for a complete web page =item B<-2> Generate HTML version 3.2 (and older) META tags with SCHEME embedded in content =back =head1 OUTPUT A set of Dublin Core HTML META tags or some RDF or displayable HTML. =head1 COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. It was developed by UKOLN as part of the ROADS project. ROADS is funded under the UK Electronic Libraries Programme (eLib), and the European Commission Telematics for Research Programme. =head1 AUTHOR Tracy Gardner Andy Powell