#!/usr/local/bin/perl -T
# link.cgi
#
# version 0.1
#
# Copyright 2002 Nathan J. Mehl
# Released under the terms of the General Public License, v2.0
#
# modules
use CGI qw/:standard *table/;
# basic workflow:
#
# if invoked with no arguments, present a form to generate a key
if ( ! param ) {
print
header,
start_html('Generate a Short Link'),
h1('Generate a short link'),
hr,
start_form,
"Enter the long URL:",p,
textfield(-name=>'url',-size=>80)," ",
#submit(-name=>'frobnosticate!'),
"",
end_form,
end_html;
} elsif ( param('q') eq "list" ) {
# if invoked with the "list" key, dump the db
dbmopen(%URLS,'/project/web/htdocs/blank.org/link/urls',0222)
or die "Can't open url db file! $!";
print header,
start_html('List of short links so far...'),
h1('List of Short links so far...'),
"...click at your own risk. :-)",p,
start_table;
# while (($key,$val) = each %URLS) {
# print "
\n";
}
print end_table;
print end_html;
dbmclose(%URLS);
} elsif ( param('url') ) {
# if invoked with a url, build a short link
my $longurl = param('url');
if ( $longurl =~ /blank.org\/link/i ) {
print header,
start_html('stop that!'),
h1('Ahem.'),hr,
"Please don't try to link me to myself.",p,
"Try again.",
end_html;
exit 0;
}
if ( ! ($longurl =~ /^http:\/\// ) ) {
print header,
start_html('oops'),
h1('Try again..'),hr,
"Links must begin with \"http://\". Try
again.",
end_html;
exit 0;
}
dbmopen(%URLS,'/project/web/htdocs/blank.org/link/urls',0622)
or die "Can't open url db file! $!";
my $key = time;
while ( defined($URLS{$key}) ) {
$key++;
}
$URLS{$key} = $longurl;
# tell them what the link is
print
header,
start_html('New Link Generated'),
h1('New Link Generated'),
hr,
"Your new link is:",p,
"
http://blank.org/link/?q=$key",p,
end_html;
dbmclose(%URLS);
} elsif ( param('q') ) {
dbmopen(%URLS,'/project/web/htdocs/blank.org/link/urls',0222)
or die "Can't open url db file! $!";
my $key = param('q');
# if invoked with a key, build a redirect page to that key's URL
if ( defined($URLS{$key}) ) {
print header,
start_html(-head=>meta({ -http_equiv=>'refresh',
-content=>"2\;
url=$URLS{$key}"}),
'blank.org short link redirector'
),
h1('Blank.Org Short Link Redirector'),
hr,
"You are being redirected to
$URLS{$key}.",
end_html;
} else {
my $key = param('q');
print
header,
start_html('blank.org short link redirector'),
h1('Sorry...'),
hr,
"We\'re sorry, we don\'t have any such link $key in our
database.",
end_html;
}
dbmclose(%URLS);
} else {
print header,
start_html('oops'),
h1('Say what?'),
hr,
"I\'m sorry, I didn't understand that request.
Try again?",
end_html;
}
# cleanup and exit
exit 0;