Redirect to $encoded

#!./perl -wT # copyright (C) 2004-2005 Topia . all rights reserved. # This is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # $URL: file:///usr/minetools/svnroot/clovery_jp/trunk/redirect.fcgi $ # $Id: redirect.fcgi 118 2005-07-23 04:54:12Z topia $ use strict; use File::Spec::Unix; BEGIN { eval 'use FCGI'; if ($@) { # FCGI not found eval ' package FCGI; sub Request { my $count = 0; bless \$count, __PACKAGE__; } sub Accept { my $this = shift; # only first ($$this++) ? -1 : 0; } sub Finish {}'; } } my $request = FCGI::Request; my $escape_chars = do { # RFC2396: 2.4.3. Excluded US-ASCII Characters my $delims = '<>#%"'; my $unwise = '{}|\^[]`'; qr/[\Q$delims$unwise\E]/; }; sub escape_uri { my ($uri) = shift; return join('', map { if ($_ le "\x20" || $_ gt "\x7e" || $_ =~ /$escape_chars/) { '%' . unpack("H2", $_); } else { $_; } } split(//, $uri)); } while ($request->Accept >= 0) { my $goto = undef; my $use_location = 0; my $script_name = (File::Spec::Unix->splitpath($ENV{SCRIPT_NAME}))[2]; if (exists $ENV{PATH_INFO}) { ($goto = escape_uri($ENV{PATH_INFO})) =~ s|^/||; $script_name = File::Spec::Unix->catfile( (map { length $_ ? '..' : () } File::Spec::Unix->splitdir($ENV{PATH_INFO})), '..', $script_name); } if (!defined($goto) || !length($goto)) { $goto = 'http://www.clovery.jp/info/redirect'; $use_location = 1; } else { $goto .= "?$ENV{QUERY_STRING}" if (defined $ENV{QUERY_STRING} && $ENV{QUERY_STRING}); } if ($goto =~ m|^([^/:]+:/)/?([^/])|) { $goto =~ s|^([^/:]+:/)/?([^/])|$1/$2|; } elsif ($goto =~ s/^redirect_private\?//) { # decode $goto =~ s/%([0-9a-fA-F]{2})/pack("H*", $1)/eg; } else { $goto = "http://$goto"; } my $encoded_goto = sub { my $str = shift; $str =~ s/&/&/g; $str =~ s//>/g; $str =~ s/\"/"/g; $str; }->($goto); my $js_encoded_goto = sub { my $str = shift; $str =~ s|\"|\\\"|g; $str; }->($goto); my $body = <<"END"; Redirect to $encoded_goto

Redirect to $encoded_goto.

END if ($use_location) { print ("Status: 302 Found\r\n"); print ("Location: $goto\r\n"); } print ("Content-Type: text/html; charset=UTF-8\r\n"); print ("Content-Length: " . length($body) . "\r\n"); print ("\r\n"); if (!defined $ENV{REQUEST_METHOD} || $ENV{REQUEST_METHOD} !~ /^HEAD$/) { print $body; } $request->Finish; }