1 | # ipdb/cgi-bin/CommonWeb.pm
|
---|
2 | ###
|
---|
3 | # SVN revision info
|
---|
4 | # $Date$
|
---|
5 | # SVN revision $Rev$
|
---|
6 | # Last update by $Author$
|
---|
7 | ###
|
---|
8 |
|
---|
9 | package CommonWeb;
|
---|
10 |
|
---|
11 | # 08/13/2004 kdeugau@vianet
|
---|
12 | # Split DB-related functions into new module; they're not
|
---|
13 | # specific to CGI/web stuff.
|
---|
14 |
|
---|
15 | use strict;
|
---|
16 | use warnings;
|
---|
17 | use Exporter;
|
---|
18 | use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
|
---|
19 |
|
---|
20 | $VERSION = 1.00;
|
---|
21 | @ISA = qw(Exporter);
|
---|
22 | @EXPORT_OK = qw(&parse_post &printFooter &printHeader &printError &printAndExit &desanitize &cleanInput &desanitize);
|
---|
23 |
|
---|
24 | @EXPORT = (); #export nothing by default
|
---|
25 | %EXPORT_TAGS = ( ALL => [qw( &parse_post &printFooter &printHeader &printError
|
---|
26 | &printAndExit &desanitize &cleanInput )],
|
---|
27 | lean => [qw( &parse_post &printFooter &printHeader &printError
|
---|
28 | &printAndExit &cleanInput )]
|
---|
29 | );
|
---|
30 |
|
---|
31 | sub parse_post {
|
---|
32 | my $buffer;
|
---|
33 | if ($ENV{'REQUEST_METHOD'} eq "GET") {
|
---|
34 | $buffer=$ENV{'QUERY_STRING'}
|
---|
35 | } elsif ($ENV{'REQUEST_METHOD'} eq 'POST' && $ENV{'CONTENT_TYPE'} eq "application/x-www-form-urlencoded") {
|
---|
36 | read(STDIN, $buffer, $ENV{CONTENT_LENGTH});
|
---|
37 | } else {
|
---|
38 | $buffer = $ENV{'QUERY_STRING'};
|
---|
39 | $buffer || read(STDIN, $buffer, $ENV{CONTENT_LENGTH});
|
---|
40 | }
|
---|
41 | my @pairs = split(/&/, $buffer);
|
---|
42 | my %webvarLocal;
|
---|
43 | foreach my $pair (@pairs) {
|
---|
44 | my ($name, $value) = split(/=/, $pair);
|
---|
45 | $name =~ tr/+/ /;
|
---|
46 | $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
|
---|
47 | $value =~ tr/+/ /;
|
---|
48 | $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
|
---|
49 | $value =~ s/\'/\\\'/g;
|
---|
50 | $webvarLocal{$name} = $value;
|
---|
51 | }
|
---|
52 | return %webvarLocal;
|
---|
53 | }
|
---|
54 |
|
---|
55 |
|
---|
56 | sub printHeader {
|
---|
57 | my $title = shift;
|
---|
58 | print "Content-type: text/html\n\n";
|
---|
59 | # This doesn't work well. Must investigate.
|
---|
60 | # my $realm = shift;
|
---|
61 | # print qq(WWW-Authenticate: Basic realm="$realm"\n) if $realm;
|
---|
62 | open FILE, "../header.inc"
|
---|
63 | or carp $!;
|
---|
64 | my $html = join('',<FILE>);
|
---|
65 | close FILE;
|
---|
66 |
|
---|
67 | $html =~ s/\$\$TITLE\$\$/$title/;
|
---|
68 | # Necessary for mangling arbitrary bits of the header
|
---|
69 | my $i=0;
|
---|
70 | while (defined(my $param = shift)) {
|
---|
71 | $html =~ s/\$\$EXTRA$i\$\$/$param/g;
|
---|
72 | $i++;
|
---|
73 | }
|
---|
74 | print $html;
|
---|
75 | }
|
---|
76 |
|
---|
77 | sub printFooter
|
---|
78 | {
|
---|
79 | open FILE, "../footer.inc"
|
---|
80 | or croak $!;
|
---|
81 | while (<FILE>)
|
---|
82 | {
|
---|
83 | print;
|
---|
84 | }
|
---|
85 | close FILE;
|
---|
86 | }
|
---|
87 |
|
---|
88 | sub printError($)
|
---|
89 | {
|
---|
90 | my $errStr = $_[0];
|
---|
91 | print qq(
|
---|
92 | <center><p class="regular"> $errStr </p>
|
---|
93 | <input type="button" value="Back" onclick="history.go(-1)">
|
---|
94 | </center>
|
---|
95 | );
|
---|
96 | }
|
---|
97 |
|
---|
98 | sub printAndExit($)
|
---|
99 | {
|
---|
100 | my $errStr = $_[0];
|
---|
101 | print qq(
|
---|
102 | <center><p class="regular"> $errStr </p>
|
---|
103 | <input type="button" value="Back" onclick="history.go(-1)">
|
---|
104 | </center>
|
---|
105 | );
|
---|
106 | printFooter();
|
---|
107 | exit(0);
|
---|
108 | }
|
---|
109 |
|
---|
110 | sub loginAgain
|
---|
111 | {
|
---|
112 | print qq(
|
---|
113 | <center><p>Your session has expired. Please login again.</p>
|
---|
114 | <p>
|
---|
115 | <a href="http://hosttest.vianet.ca"> Click here to login again.</a>
|
---|
116 | </p>
|
---|
117 | </center>
|
---|
118 | );
|
---|
119 | printFooter();
|
---|
120 | exit(0);
|
---|
121 | }
|
---|
122 |
|
---|
123 | # needs a reference to the webvar hash.
|
---|
124 | # takes out backticks and single quotes
|
---|
125 | sub cleanInput($)
|
---|
126 | {
|
---|
127 | my $hashRef = $_[0];
|
---|
128 |
|
---|
129 | foreach my $key (keys %$hashRef)
|
---|
130 | {
|
---|
131 | $hashRef->{$key} =~ s/`/\\`/g;
|
---|
132 | $hashRef->{$key} =~ s/'/\'/g;
|
---|
133 | }
|
---|
134 | }
|
---|
135 |
|
---|
136 | # undoes clean input. takes a string as an arg.
|
---|
137 | sub desanitize($)
|
---|
138 | {
|
---|
139 | my $string = $_[0];
|
---|
140 | $string =~ s/\\`/`/g;
|
---|
141 | $string =~ s/\\'/'/g;
|
---|
142 | return $string;
|
---|
143 | }
|
---|
144 |
|
---|
145 | # indicate that the module loaded okay.
|
---|
146 | 1;
|
---|