#!/usr/local/bin/perl5 -wT

# Copyright (c) 2002                            RIPE NCC
#
# All Rights Reserved
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies and that
# both that copyright notice and this permission notice appear in
# supporting documentation, and that the name of the author not be
# used in advertising or publicity pertaining to distribution of the
# software without specific, written prior permission.
#
# THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL
# AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY
# DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

# Lee Wilmot 20020623

# Descramble an email address scrambled by scramble.pl, and
# ask the browser to bring up an email client with the
# descrambled address.

# See 'scramble.pl' for the scrambling method.

# HTTP Header

print "Content-type: text/html\n\n";

my ( $email_address, $other_attributes ) = &parse_form;

if ( $email_address ) {
    &print_normal_page( $email_address, $other_attributes );
}

exit 0;

sub print_normal_page
{
    my ( $email_address, $other_attributes ) = @_;

    # Check if any other attributes than an email address were
    # specified in original mail URL. Could be e.g. a subject

    if ( $other_attributes ) {
	$other_attributes = '?'. $other_attributes;
    }
    else {
	$other_attributes = '';
    }

    # Note that the header includes a refresh which will bring up the
    # email client if browser has meta refresh enabled
    
    # Otherwise, user has to click a link

    print<<"    EOF";
	<HTML>
	<HEAD>
	<META http-equiv="Refresh" content="0; URL=mailto:$email_address$other_attributes">
	<TITLE>RIPE NCC: Email Redirect</TITLE>
	</HEAD>
	<BODY BGCOLOR="#FFFFFF">
	You can contact the person you requested by
	clicking <A HREF="mailto:$email_address$other_attributes">here</A>, if
	your browser has not already brought up your mail client.
	<P>Their email address is:
	<BLOCKQUOTE>
		<B>$email_address</B>
	</BLOCKQUOTE>

	<P>Unfortunately this redirection is required to avoid
	spam abuse by trawling of our pages.</P>
    EOF

	# Print referring page if we know it

	if ( my $referrer = $ENV{'HTTP_REFERER'} ) {
	    print "<P><A HREF=\"$referrer\">Back To The Previous Page</P>";
	}

	print "</BODY></HTML>";
}

sub fatal_error
{
    my ( $user_message, $admin_message )= @_;
    
    print "<html><head></head><body>Error: $user_message</body></html>";
    
    my $referrer = $ENV{'HTTP_REFERER'} || 'unknown page';
    
    print STDERR "$0: $admin_message (from $referrer)\n";
    
    exit -1;
}

sub parse_form
{
    my ( $email_address, $other_attributes );

    my ( $request_method, $content_length, $query_string ) = ( $ENV{'REQUEST_METHOD'}, $ENV{'CONTENT_LENGTH'}, $ENV{'QUERY_STRING'} );

    if ( $request_method ) {
        if ( $request_method  eq 'POST' ) {

	    if ( $content_length ) {
		read ( STDIN, $query_string, $content_length );
	    }
	    else {
		&fatal_error( "CGI error", "empty form data" );
	    }
        }
        elsif ( $request_method ne 'GET' ) {
	    &fatal_error( "CGI error", "bad request method: $request_method" );
        }
    }
    else {
        &fatal_error( "CGI error", "no request method in ENV" );
    }

    my ( $localname, %domain_labels );
    
    foreach $pair ( split /&/, $query_string ) {
	my ( $attr, $value ) = split /=/, $pair;

	# Part of the domain name of the original email address

	if ( $attr =~ /^(\d+)$/ ) {
	    $domain_labels{$1} = $value;
	}

	# Local username of the email address

	elsif ( $attr eq 'localname' ) {
	    $localname = $value;
	}

	# All other attributes (after the email address) 
	# from the original mailto: url

	elsif ( $attr eq 'other' ) {
	    $other_attributes = $value;
	    $other_attributes =~ s/\+/ /g;
	    $other_attributes = &decode( $other_attributes );
	}
    }

    # Reconsitute the domain name from it's parts

    for ( my $label_no = 255; $label_no > 0; $label_no-- ) {
	if ( $domain_labels{$label_no} ) {
	    push @domain_labels, $domain_labels{$label_no};
	}
    }

    my $domain = join '.', @domain_labels;

    if ( $localname && $domain ) {
	$email_address = join '@', $localname, $domain;
	$email_address = &decode( $email_address );
    }
    else {
        &fatal_error( "Argument error", "localname or address not in query" );	
    }

    return ( $email_address, $other_attributes );
}

sub decode
{
	my $coded = shift;
	$coded =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack( "C", hex($1))/eg;
	return $coded;
}
