#!/usr/bin/perl -w
# Copyright (C) 2006-2007 OhioLINK
#
# This file is part of the OhioLINK Digital Resource Commons (DRC) Project.
#
# The OhioLINK DRC is free software; you can redistribute it and/or
# modify it under the terms of the Affero General Public License as
# published by Affero, Inc. -- either version 1 of the License, or
# (at your option) any later version.
#
# The OhioLINK DRC Project is distributed in the hope that it will be
# useful, but WITHOUT ANY WARRANTY -- without even the implied warranty
# of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# Affero General Public License for more details.
#
# You should have received a copy of the Affero General Public
# License in the LICENSE.txt file that comes with the DRC project;
# if not, write to DRC Development Team, OhioLINK, 2455 North Star Rd,
# Suite 300, Columbus, OH 43221, USA.
 
if (!$ENV{PATH_INFO}) {
  print "Location: http://no-path-info-given/\\r\\n\\r\\n";
} else {
  ($format,$id) = $ENV{PATH_INFO} =~ q#^/+(.*?)/(.*)$#;
 
  if ($format =~ /Quicktime/i) {
    print "Location: http://video.ohiolink.edu/blah/Quicktime/$id\\r\\n\\r\\n";
  } elsif ($format =~ /Real/i) {
    print "Location: http://video.ohiolink.edu:8080/ramgen/blah/Real/$id\\r\\n\\r\\n";
  } elsif ($format =~ /Windows/i) {
    ($winType,$winFile) = $id =~ q#^(.*?)/(.*)$#;
    if ($winType =~ /asx/i) {
      $winFile =~ s/\\..*$//;
      print >> "EoMarkup";
Content-type: video/x-ms-asf
 
<asx version="3.0">
<copyright>(c) 2005 - xxx</copyright>
<entry>
<ref href="mms://video.ohiolink.edu/blah/Windows/$winFile.wmv?SAMI=http://rave.ohiolink.edu/dmc/blah/windows/smi/$winFile.smi">
<ref href="http://video.ohiolink.edu/blah/Windows/$winFile.wmv?SAMI=http://rave.ohiolink.edu/dmc/blah/windows/smi/$winFile.smi"/>
<copyright>(c) 2005 - xxx</copyright>
</ref></entry>
</asx>
EoMarkup
    } elsif ($winType =~ /wmv/i) {
      print "Location: mms://video.ohiolink.edu/blah/Windows/$winFile\\r\\n\\r\\n";
    } elsif ($winType =~ /smi/i) {
      use LWP::UserAgent;
      $ua = LWP::UserAgent->new;
      $ua->agent("$0-lwp/0.1 " . $ua->agent);
      $req = HTTP::Request->new(GET => "http://video.ohiolink.edu:8080/blah/Windows/$winFile");
      # send request
      $res = $ua->request($req);
      # check the outcome
      if ($res->is_success) {
        print "Content-type: application/smil\\r\\n\\r\\n";
        print $res->decoded_content;
      } else {
        print "Location: http://error-from-remote-server/$winType/$winFile/".$res->code."/".$res->message."\\r\\n\\r\\n";
      }
    } else {
      print "Location: http://invalid-Windows-format-given/$winType/$winFile\\r\\n\\r\\n";
    }
  } else {
    print "Location: http://invalid-format-given/$format/$id\\r\\n\\r\\n";
  }
}

#!/usr/bin/perl
##
###########################################################################
##
##  Program:  check-refer.pl
##
##  Purpose:  Test the referrer header from the user's browser
##
##  Version:  1.0  5-Sep-2006
##
##  Author:   Peter Murray
##
##  Legalities:
##            Copyright 2006 by OhioLINK
## This file is part of the OhioLINK Digital Resource Commons (DRC) Project.
##
## The OhioLINK DRC is free software; you can redistribute it and/or
## modify it under the terms of the Affero General Public License as
## published by Affero, Inc. -- either version 1 of the License, or
## (at your option) any later version.
##
## The OhioLINK DRC Project is distributed in the hope that it will be
## useful, but WITHOUT ANY WARRANTY -- without even the implied warranty
## of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## Affero General Public License for more details.
##
## You should have received a copy of the Affero General Public
## License in the LICENSE.txt file that comes with the DRC project;
## if not, write to DRC Development Team, OhioLINK, 2455 North Star Rd, 
## Suite 300, Columbus, OH 43221, USA.
##
##  Revision History:
##    1.0   5-Sep-2006  peter  Initial Version
##
##
 
use CGI qw(escapeHTML url http);
use CGI::Carp;
use strict;
 
BEGIN {
  $SIG{'__DIE__'} = sub {
    print "Content-type: text/html\r\n\r\n";
    print "<html><head><title>COMPILE TIME ERROR.</title></head>\n";
    print "<body><h1>COMPILE TIME ERROR.</h1><p>This should never happen.  Further details:</p>\n";
    print join "\n<br />",@_;
    print "</body></html>\n";
    exit;
  };
}
 
$SIG{'__DIE__'} = 'handle_die';
 
eval("main");
if ($@) {
	print "Content-type: text/plain\n\n",
              "The script failed because the error\n$@\noccurred.";
}
 
sub main {
# @output will be used in each one of these cases below to store the
# temporary array of HTML while we check for an error returning from the
# subroutine.
my @output;
 
 
## Now start doing some real work.
 
# Initialize the CGI module, and get any form variables into FORM::
my($query) = new CGI;
$query-&gt;import_names('FORM');
 
# Split the parameters from the URL line by the slash character (after removing
# the leading slash).  We will cycle through each one of these below.
my($path_info);
($path_info = $ENV{'PATH_INFO'}) =~ s/^\///;
my(@params) = split(/\//, $path_info);
 
#
# Now we start cycling through the @params array looking for specific keywords.
$_ = shift @params;
if ((!defined($_)) || ($_ eq 'start')) {
 # If there is nothing following the script file name (e.g., no PATH_INFO) or if the
 # contents of the first parameter is 'start', then generate the introdution page
  @output = initial_page();
} elsif ($_ eq 'test') {
 # If the first parameter is 'test' then run the tests on the referrer header
  @output = test_results();
} else {
 # The command was unknown -- either an error in coding or someone trying to hack
 # the script.  Return an error.
  push @output, HTMLheader("Sorry -- I don't understand."), &lt; &lt; "EoHTML", HTMLfooter();
<p>I'm sorry, but I don't understand the $_ command.  Try starting from <a href="./">the beginning</a>.</p>
EoHTML
}
 
# Write out the HTML that has been gathered in @output
outputHTML (@output);
 
# And we're done!
exit;
}  ## End of sub main()
 
 
 
sub initial_page {
  my @output;
  my $url = url();
  push @output, HTMLheader("Check Your Referrer Field");
  push @output, &lt; &lt; EoHTML;
 
<p>
To begin a test of how OhioLINK receives the "Referrer" field from your web browser, click on the following link:
</p>
<p style="font-size: 120%; width: 100%; text-align: center; border: 1px solid gray;">
<a href="$url/test">Start Referrer Test</a>
</p>
 
EoHTML
  push @output, HTMLfooter();
  return @output;
}
 
 
sub test_results {
  my @output;
 
  my $referrer = http('HTTP_REFERER');
  my $trueReferrer = url(-full=&gt;1);
  push @output, HTMLheader("Results of Test for Referrer Field");
 
  if ((!defined($referrer)) || ($referrer eq "")) {
  	push @output, "<p>","Either your browser did not return a 'Referrer' URL as a result of following the link on the previous page or an intermediary has stripped the referrer URL from your browser's request before it reached this server.  (This symptom can also happen if you typed the results URL, <em>$trueReferrer/test</em>, directly in the browser address window rather beginning from the <a href="\&quot;$trueReferrer\">start page</a>.)","</p>";
  } else {
    push @output, "<p>","As a result of following the link on the previous page, your browser returned this as the 'Referrer' field:<br /><span style="\&quot;font-family:monospace; margin-left: 5em; margin-top: 1em;\">$referrer</span>","</p>";
  }
 
  if ($referrer eq $trueReferrer) {
    push @output, "<p>","This is what was expected.","</p>";
  } else {
    push @output, &lt; &lt; "EoHTML";
<p>
This was not what was expected, and as a result you may have problems using some OhioLINK services.  
This value should be <em>$trueReferrer</em> instead.  
(Make sure you start from <a href="$trueReferrer">$trueReferrer</a> when performing this test.)
</p>
<p>
For assistance with correcting this problem, please see <a href="http://karmak.org/2004/reftest/fix" title="HTTP_REFERER Fix">this support page from karmak.org</a>.
</p>
EoHTML
  }
  push @output, HTMLfooter();
  return @output;
}
 
 
sub outputHTML() {
  my @output=@_;
  print "Content-type: text/html\n\n";
  print join("\n",@output),"\n";
}
 
sub HTMLheader(@) {
 my($title,$h1,$style) = @_;
 
 $h1=$title if !defined($h1);
 $style = "" if !defined($style);
 
 return &lt; &lt; "EoHTML"
&lt; !doctype html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"&gt;
<html xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
<head>
	<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
	</meta><meta name="robots" content="none">
	<title>$title</title>
	<link rel="stylesheet" type="text/css" href="/style/ohiolink.css">
	<style type="text/css"><!--/*-->&lt; ![cdata[/*&gt;<!--*/
       $style
	/*]]>*/--&gt;</style>
</link></meta></head>
<body>
<p align="right"><img src="/images/bar-header.jpg" alt="" /></p>
<h1>$h1</h1>
EoHTML
}
 
sub HTMLfooter() {
  return &lt; &lt; EoHTML
</body>
</html>
EoHTML
}
 
##
## SUBROUTINE handle_die
##
##   Get an error key for the program, open up the error text file, find and
##   print the text specific for that error, make the user feel special with
##   a message, then EXIT THE SCRIPT.
##
##   Parameters: Text key of the error message, plus additional parameters
##   Returns:    --none--  handle_die WILL EXIT THE SCRIPT
sub handle_die {
  my(@addl_info) = split /\|/,@_[0];
  my($error_key) = shift @addl_info;
  my($package, $filename, $line, $subroutine) = caller(0);
  my($progName, $paramURL);
 
  print "Content-type: text/html\n\n";
  print HTMLheader('Program Error');
  print "<p>This program encountered an error in the <b>$subroutine</b> routine at line <b>$line</b> of <b>$progName</b>.";
  print "The error key is <b>$error_key</b>.  The parameter URL is <b>$paramURL</b>.</p>\n";
  if (scalar(@addl_info) &gt; 0) {
    print "<p>Some additional info:\n</p><ul><li>\n </li><li>";
    print join "\n </li><li>",@addl_info;
    print "\n</li></ul>\n";
  }
  print HTMLfooter();
  exit;
}