#!/usr/bin/perl
#########################################################################
# header.pl
# Created by: John Michael Soileau
# Email: johnm@realtimescripts.com
###########################################################
# COPYRIGHT NOTICE:
# © Copyright 2003
# John Michael Soileau, RealTimeScripts.com All Rights Reserved.
#
# Selling the code for this program without prior written consent is expressly forbidden.
# By using this program you agree to indemnify JMS from any liability.
#####################################################################################
#####################################################################################
# call like so
# http://yourdomain.com/cgi-bin/header.pl?host=whatever.com&uri=/folder/page.html
# user and pass may also be entered into the querystring and if present, this script will send them in with the request.
# now you may add the method in query method=HEAD or GET


# Future:  split up the headers and return document into frames so that I can see the page displayed correctly
# use that base ref tag to get the images to display correctly.  Prlbably need to pull the html tags out first at top.
#  put query strin into a form. easier to type.

require 5.002;
use strict;
use Socket;
⊤


use vars qw(%VAR $protected $base_href $request_method);

unless ($ENV{'QUERY_STRING'}){
	print "<p>ERROR:  Query String Missing!</p>";
	&bottom;
	exit;
}
&assign_values(&get_query);
unless ($VAR{'uri'}){$VAR{'uri'} = '/';}
unless ($VAR{'host'}){
	print "<p>ERROR:  Required Query String Variables Missing!</p>";
	&bottom;
	exit;
}

# build base href
my @path = ();
if ($VAR{'host'} =~ m,/$,){chop $VAR{'host'}};
unless ($VAR{'uri'} =~ m,/$,){
	@path = split(/\//, $VAR{'uri'}); 
	pop @path;
}
my $uri_href = join('/',@path);
$base_href = $VAR{'host'} . $uri_href . "/";

print qq~<base href="http://$base_href">\n~;


unless ($VAR{'method'}){$VAR{'method'} = 'GET'};

if ($VAR{'user'} && $VAR{'pass'}){
	$protected = 1;
}else {$protected = 0};

my $port = 80;
my $remote_host = "$VAR{'host'}";
my $query = "$VAR{'uri'}";



&open_tcp($remote_host, $query, $port);


# Take off the headers
print qq~<p><font face="Verdana" size="3"><b>START: Returned Headers</b></font></p>~;
my $header;
do {
	$header = <SOCK>;  
	print qq~<p>$header</p>\n~;
} until ($header =~ /^\r\n/);

print qq~<p><font face="Verdana" size="3"><b>END: Returned Headers</b></font></p>~;

if ($VAR{'method'} eq 'HEAD') {
	close(SOCK);
	print qq~<p>HEAD Method. So Nothing Returned!</p>\n~;     
}else{
# Now, get all of the actual response data
	my $answer;
	while(<SOCK>) {
		$answer .= $_;
	}	
	print qq~<p>GET Method. So Here Is Your Page!</p>\n~;
	print qq~$answer~;
	close(SOCK);
}


&bottom;
exit;

###################################################################################################
sub open_tcp {
	my ($remote, $add, $port) = @_;

      if ($port =~ /\D/) { $port = getservbyname($port, 'tcp') }
	      die "No port specified." unless $port;

      my $iaddr   = inet_aton($remote)               || die "Could not find host: $remote";
      my $paddr   = sockaddr_in($port, $iaddr);
      my $proto   = getprotobyname('tcp');
      socket(SOCK, PF_INET, SOCK_STREAM, $proto)  || die "Socket Error: $!";
      connect(SOCK, $paddr)    || die "Connect Error: $!";

	my $old_fh = select(SOCK);
	$| = 1;
	select($old_fh);
	
	
	### Request being made here.
	print SOCK "$VAR{'method'} $add HTTP/1.0\n";

	print SOCK "Host: $remote\n";
	print SOCK "Referer: " . 'seeallofme.com/member' . "\n";

	if ($protected){
		my $encoded = &old_encode_base64("$VAR{'user'}:$VAR{'pass'}");
		print SOCK "User-Agent: Real Time Scripts PW Agent/1.0\n";	


		print SOCK "Authorization: Basic $encoded\n";

	}else {
		print SOCK "User-Agent: Real Time Scripts Agent/1.0\n";
	}

	print SOCK "Connection: Keep-Alive\n";
#	print SOCK "Content-type: application/x-www-form-urlencoded\n";
	print SOCK "\n";
	
}
###########################################################################################
sub top{
print "Content-type: text/html\n\n";
print qq~
<html>
<head>
<title>Socket Test</title>
</head>
<body link="#0000FF" vlink="#0000FF">~;
print qq~<p align="center"><font face="Verdana" size="4">Real Time Scripts Socket Test</font></p>~;
}
###########################################################################################
sub bottom{
print qq~
<p align="center"><font SIZE="2" face="Verdana">© Copyright 2000 - 01 Digital
Schema, LLC. All rights reserved</font><font size="2" face="Verdana"><br>
This free script can be found at:</font><a href="http://realtimescripts.com"><font size="2" face="Verdana"><br>
Real Time Scripts</font></a></p>
</body>
</html>~;
}
###########################################################################################
sub assign_values {
my @array = @_;
my ($name,$value);
foreach (@array) {
	chomp;
	($name, $value) = split(/=/);
	$value =~ tr/+/ /;
	$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
	$value =~ s/<!--(.|\n)*-->//g;
	$VAR{$name} = $value;
}}
####################################################################################################
sub get_query {
my @pairs;
@pairs = split(/&/, $ENV{'QUERY_STRING'});
return @pairs;
}
####################################################################################################


##########  Code whacked from MIME::Base64  -- ALL CODE BELOW THIS LINE COVERED
##########  BY LICENSE GRANT BELOW.

#Copyright 1995-1998 Gisle Aas.

#    This library is free software; you can redistribute it and/or
#modify it under the same terms as Perl itself.

#Distantly based on LWP::Base64 written by Martijn Koster
#<m.koster@nexor.co.uk> and Joerg Reichelt <j.reichelt@nexor.co.uk> and
#code posted to comp.lang.perl <3pd2lp$6gf@wsinti07.win.tue.nl> by Hans
#Mulder <hansm@wsinti07.win.tue.nl>

use integer;

sub old_encode_base64 ($;$)
{
    my $res = "";
    my $eol = $_[1];
    $eol = "\n" unless defined $eol;
    pos($_[0]) = 0;                          # ensure start at the beginning
    while ($_[0] =~ /(.{1,45})/gs) {
        $res .= substr(pack('u', $1), 1);
        chop($res);
    }
    $res =~ tr|` -_|AA-Za-z0-9+/|;               # `# help emacs
    # fix padding at the end
    my $padding = (3 - length($_[0]) % 3) % 3;
    $res =~ s/.{$padding}$/'=' x $padding/e if $padding;
    # break encoded string into lines of no more than 76 characters each
    if (length $eol) {
        $res =~ s/(.{1,76})/$1$eol/g;
    }
    $res;
}

sub old_decode_base64 ($)
{
    local($^W) = 0; # unpack("u",...) gives bogus warning in 5.00[123]

    my $str = shift;
    my $res = "";

    $str =~ tr|A-Za-z0-9+=/||cd;            # remove non-base64 chars
    if (length($str) % 4) {
        require Carp;
      Carp::carp("Length of base64 data not a multiple of 4")
      }
    $str =~ s/=+$//;                        # remove padding
    $str =~ tr|A-Za-z0-9+/| -_|;            # convert to uuencoded format
    while ($str =~ /(.{1,60})/gs) {
        my $len = chr(32 + length($1)*3/4); # compute length byte
        $res .= unpack("u", $len . $1 );    # uudecode
    }
    $res;
}