1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222 | #!/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>This should never happen. Further details:\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->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."), < < "EoHTML", HTMLfooter();
I'm sorry, but I don't understand the $_ command. Try starting from <a href="./">the beginning</a>.
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, < < EoHTML;
To begin a test of how OhioLINK receives the "Referrer" field from your web browser, click on the following link:
<p style="font-size: 120%; width: 100%; text-align: center; border: 1px solid gray;">
<a href="$url/test">Start Referrer Test</a>
EoHTML
push @output, HTMLfooter();
return @output;
}
sub test_results {
my @output;
my $referrer = http('HTTP_REFERER');
my $trueReferrer = url(-full=>1);
push @output, HTMLheader("Results of Test for Referrer Field");
if ((!defined($referrer)) || ($referrer eq "")) {
push @output, "","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="\"$trueReferrer\">start page</a>.)","";
} else {
push @output, "","As a result of following the link on the previous page, your browser returned this as the 'Referrer' field:<br /><span style="\"font-family:monospace; margin-left: 5em; margin-top: 1em;\">$referrer</span>","</p>";
}
if ($referrer eq $trueReferrer) {
push @output, "","This is what was expected.","";
} else {
push @output, < < "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.)
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>.
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 < < "EoHTML"
< !doctype html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/>
<meta name="robots" content="none"/>
<title>$title</title>
<link rel="stylesheet" type="text/css" href="/style/ohiolink.css"/>
<style type="text/css"><!--/*-->< ![cdata[/*><!--*/
$style
/*]]>*/--></style>
</head>
<body>
<p align="right"><img src="/images/bar-header.jpg" alt="" />
<h1>$h1</h1>
EoHTML
}
sub HTMLfooter() {
return < < EoHTML
</p></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><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) > 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;
}
|