#!/usr/bin/perl # ------------------------------------------------------------- # redirect.pl (redirect.cgi) # Version 0.9 -- Initial public release. This script has not # yet been fully tested under a wide range of circumstances. # If you encounter what appears to be abnormal operation and # there is not an updated version available at # http://www.artsackett.com/freebies/ please submit a bug # report to scriptbugs@artsackett.com with as much detailed # information as possible regarding the environment in which # the abnormal operation occurs. # # Copyright 1998 -- Art Sackett # # a simple redirection script for processing HTML forms that # send fully qualified URI's via GET or POST. A quick way to # send users from here to there and maybe never see 'em again. # 'require CGI.pm' because I am feeling lazy, so if you don't # have it available, you will have to install it to make this # script work. # # Use of this script is at the user's sole risk. Art Sackett # does not provide any guarantee of fitness or suitability for # any purpose. If it breaks things, you get to keep whatever # little pieces might be left. # # See http://www.artsackett.com/grey_papers/ if you have # trouble making this thing work. # # Thank Liz Knuth if you like the GET method. She sweet- # talked me into supporting it, which meant replacing my old # script that sucked. # ------------------------------------------------------------ # # Feature creep! If you want to configure these things, see the # HTML help that came with this thing. Default values will work. # # ------------------ USER CONFIGURATION ---------------------- # $paranoid = 0; # default = 0 $debug = 0; # ONLY SET TO 1 WHILE DEBUGGING YOUR INSTALLATION! $reflist = 'ref_list.txt'; # Change if needed -- make sure the path is right. # ---------------- END USER CONFIGURATION -------------------- # ------------------ DESPERATE MEASURES ---------------------- # if you had to install CGI.pm in your user directory, you will also # need to set the full path in the next line and uncomment it. But # if your version of Perl is <5.002, go to the next section instead. # use lib '/users/you/lib'; # Somebody has a lame installation # if the version of Perl is prior to 5.002 and CGI.pm is in your user # directory, set the path to CGI.pm in the second line below and # uncomment these three lines: # BEGIN { # Or an even lamer one! # unshift(@INC,'/users/you/lib'); # } # If you don't grok perl, anything you want to mess with is above. # (Which is to say, you don't want to mess with what's below!) use CGI; $query = new CGI; sub check_referer { $referer = $query->referer(); if (($paranoid) && ($referer) && ($referer ne ('' || '(none)' || 'null'))) { open (LIST, "<$reflist") || exit (-1); @good_refs = ; close LIST; foreach $good_ref(@good_refs){ $good_ref =~ s/\b?\s*\#.*//g; chomp $good_ref; next if ($good_ref eq ''); if ($referer =~ /^(http:|ftp:)\/\/$good_ref.*/) { return; } } if ($debug) { $error_string = "\$paranoid = 1 AND the URL of the referring page did not match against any\nof the entries in ref_list.txt, which resulted in a termination of the\nform processing action.\n\nThe URL of the referring page was $referer."; $fix = "to add or edit an entry in ref_list.txt or set \$paranoid = 0 \nin User Configuration."; print_debug_message(); } print "content-type: text/plain\n\n"; print "Referring URL denied.\nReferring URL: $referer\n"; exit (-1); } if (($referer) && ($referer ne ('' || '(none)' || 'null'))) { $this_server = $query->server_name(); if ($referer !~ /^(http:|ftp:)\/\/$this_server\/?.*/) { $this_vhost = $query->virtual_host(); if ($referer !~ /^(http:|ftp)\/\/$this_vhost\/?.*/) { if ($debug) { if (!$this_server) { $error_string = "the server did not report it's name when asked. This is either a \nserver configuration error or the server and this script are not compatible."; $fix = "to contact scriptbugs\@artsackett.com with as much information \nabout the server software as possible. We may be able to help you, and to improve\nthe quality of this script if this is not a server misconfiguration issue\nthat is beyond our control."; print_debug_message(); } else { $error_string = "the URL of the referring page indicates that it did not originate on \n$this_server"; if (($this_vhost) && ($this_vhost ne $this_server)) { $error_string .= " or \nthe virtual host $this_vhost."; } else { $error_string .= "."; } if ($referer) { $error_string .= " \n\nThe referring URL was $referer."; } $fix = "unfortunately not easy if the referring URL indicates a \npage that originated on this server. It may be a server problem or a very \nstealthy bug in this script. \n\nIf you suspect a bug in this script, please copy the text of this page and email it \nto scriptbugs\@artsackett.com with as much detailed information as you can \nprovide about the server software and the events that led to this failure."; print_debug_message(); } exit (-1); } print "content-type: text/plain\n\n"; if (!($this_server | $this_vhost)){ print "Server misconfigured?"; } else { print "Referring URL denied.\nReferring URL: $referer"; } exit (-1); } } } } sub ssi { $method = $query->param('method'); if ($method !~ /(get|post)/i) { $method = 'get'; } $ext_list = $query->param('extlist'); if (!$ext_list) { $ext_list = 'list.txt'; } open (LIST, "<$ext_list") || exit (-1); @extlist = ; close LIST; foreach $extlist(@extlist){ next if ($extlist =~ /(^\s*\#.*)|(^\s*$)/); ($loc, $title) = split(/\t+/,$extlist); $loc =~ s/\s+//g; push @urls, $loc; chomp $title; push @pairs, $loc, $title; } %list = @pairs; $action = $query->url; $action =~ s/^inc.*:/http:/i; $text = $query->param('text'); $button = $query->param('button'); $label = $query->param('label'); if (!$label) { $label = ' Go '; } print "content-type: text/html\n\n"; print "\n\n\n"; if ($text =~ /(bold|bolditalic)/i) { print ""; } if ($text =~ /(italic|bolditalic)/i) { print ""; } print $query->startform(-method=>$method, -action=>$action); if ($button =~ /left/i){ print $query->submit(-name=>$label); } print $query->popup_menu(-name=>'location', -values=>\@urls, -labels=>\%list ); if ($button !~ /left/i) { print $query->submit(-name=>$label); } if ($text =~ /(italic|bolditalic)/i) { print ""; } if ($text =~ /(bold|bolditalic)/i) { print ""; } print $query->endform; print "\n\n\n"; exit; } sub print_debug_message { $myself = $query->self_url; print "content-type: text/plain\n\n"; print "==== Verbose debug output for Art Sackett's redirect.pl ====\n\n"; print "If you are not the administrator of the site from which this page\n"; print "was server, please contact their webmaster or courtesy\@artsackett.com\n"; print "and provide the URL (location) at which you are reading this file.\n\n"; print "The call to this script was with this URL:\n\n$myself\n\n"; print "It appears that the script failed to return the anticipated result because\n"; print "$error_string\n\n"; print "The most likely fix is $fix\n\n"; print "Please remember that the ONLY guarantee this free software brings with it\n"; print "is that if anything breaks, you get to keep the little pieces.\n\n"; print "TURN OFF DEBUGGING AS SOON AS THIS SCRIPT WORKS PROPERLY!!!\n\n"; exit (-1); } $url = $query->param('location'); $| = 1; if ((!$url) || ($url eq ('' || '(none)'))) { ssi(); } check_referer(); print $query->redirect($url); # Wave bye-bye!