# All rights reserved (c) 2002;  Author: Daniel Dinev;  http://chatologica.com

package MTS4::STD::URL;                                 # URL OBJECT

use strict;
use MTS4::STD::Common;

BEGIN {
    use Exporter;
    use vars qw(@ISA @EXPORT);
    @ISA = qw(Exporter);
    @EXPORT = qw( URLencode URLdecode variables_encode variables_decode expand_relative_to_full_url fix_url);
};

=head

    USAGE:

    my $URL = new MTS4::STD::URL( 'url' => 'yahoo.com:8080/site/index.shtml?go' );
    my $URL = new MTS4::STD::URL(
        'protocol' => 'http',
        'host' => 'yahoo.com',                          # mandatory
        'port' => '8080',
        'path' => '/site/index.shtml',
        'vars_str' => 'go',
        'variables' => {'a' => 1, 'b' => 2},
        'uri' => '/site/index.shtml?go',
        'auth_pass' => 'jhfjfj',
        'auth_user' => 'admin',
        'url' => 'yahoo.com/ind',
    );
    my $encoded_str = MTS4::STD::URL::URLencode('string to be passed through url');

=cut


sub new {                                               # A STANDARD OBJECT CONSTRUCTOR
    my ($this,%p) = @_;
    my $class = ref($this) || $this;
    my $me = {};
    bless $me, $class;
    $me->init(%p);
    return $me;
};



sub init                                                # INITIALIZE THIS OBJECT
{
    my ($me,%p) = @_;
    if($p{'url'}){
        $me->parse_URL($p{'url'},%p);
    } else {
        $me->make_URL(%p);
    };
};



sub parse_URL                                           # PARSING A URL TO ITS COMPONENTS
{
    my($me,$url,%p) = @_;
    $me->set_defaults;
    if($p{'auth'}){
        $me->prepare_auth(%p);
    };
    $$me{'url'} = $url;
    $$me{'url'} =~ s/\s//g;                             # remove white spaces from url
    $$me{'url'} =~ s{^http://http://}{http://}i;        # remove double http://
    if($$me{'url'} =~ m{^(http|file|ftp|mailbox|news|wyswyg)://(.*)$}i) {
        $$me{'protocol'} = lc $1;
        $$me{'uri'} = $2;
    } else {                                            # if protocol not defined
        $$me{'protocol'} = 'http';                      # set HTTP as a default protocol
        $$me{'url'} = 'http://' . $$me{'url'};
    };                                                  # remove repeated protocol marks with a lower case one:
    $$me{'url'} =~ s{^($$me{'protocol'}://)+}{$$me{'protocol'}://}i;
    if($$me{'protocol'} eq 'http') {                    # extracting url parts for a http url:
        if($$me{'url'} =~ m{^http://([^/]+)(/.*|)$}) {  # extracting 'host' and 'uri':
            $$me{'host'} = lc $1;
            $$me{'uri'} = $2;
            $$me{'uri'} = '/' if $$me{'uri'} eq '';
            my ($p1,$p2) = split(m/\@/,$$me{'host'});
            if(defined $p2) {
                $$me{'host'} = $p2;
                $$me{'auth'} = "$p1\@";
                $me->prepare_auth('auth' => $$me{'auth'});
            };
        };
        $me->parse_uri;
        if($$me{'host'} =~ m{^(.+):(\d+)$}) {           # extracting port:
            $$me{'host'} = $1;
            $$me{'port'} = $2;
        };
        $me->make_host_port_www_variants;               # building lowercased urls:
        $me->build_urls_from_components;
    };
};



sub make_URL                                            # MAKING A URL FROM ITS COMPONENTS
{
    my($me,%p) = @_;
    $me->set_defaults;
    $$me{'protocol'} = $p{'protocol'} || 'http';
    if($$me{'protocol'} eq 'http') {
        $$me{'host'} = $p{'host'} || '';
        $$me{'port'} = $p{'port'} || 80;
        $me->prepare_auth(%p);
        $$me{'vars_str'} = $p{'vars_str'} || '';
        $me->make_host_port_www_variants;
        if(defined $p{'uri'}) {                             # extract 'path', 'vars_str' and 'variables':
            $me->parse_uri($p{'uri'});
        } else {
            if (defined $p{'path'}) {                       # path is provided -> check it
                $$me{'path'} = $p{'path'};
                if($$me{'path'} eq '') {
                    $$me{'path'} = '/';                     # path must start with / always
                };
                $$me{'path'} =~ s{^([^/])}{/$1};            # path must start with / always
            };
            if(defined $p{'vars_str'}){                     # make 'vars_str' and 'variables' hash
                $$me{'variables'} = &variables_decode($p{'vars_str'});
            } elsif (defined $p{'variables'}){
                $$me{'vars_str'} = &variables_encode($p{'variables'});
            };
            if($$me{'vars_str'} ne ''){                     # build uri from 'path' and 'vars_str'
                $$me{'uri'} = "$$me{'path'}?$$me{'vars_str'}";
            } else {
                $$me{'uri'} = $$me{'path'};
            };
        };
        $me->build_urls_from_components;
    } else {
        $$me{'uri'} = $p{'uri'};
        $$me{'uri'} = '' if ! defined $p{'uri'};
        $$me{'url'} = "$$me{'protocol'}://$$me{uri}";
    };
};



sub prepare_auth                                        # PREPARE THE AUTHENTICATION PART OF URL
{
    my($me,%p) = @_;
    $$me{'auth_user'} = $$me{'auth_pass'} = '';
    if($p{'auth'}) {
        $$me{'auth'} = $p{'auth'};
        my $auth = $p{'auth'};
        $auth =~ s/\@$//;
        my($user,$pass) = split(m/:/,$auth);
        if(defined $pass) {
            $$me{'auth_pass'} = &URLdecode($pass);
        };
        if(defined $user) {
            $$me{'auth_user'} = &URLdecode($user);
        };
    } else {
        if(defined $p{'auth_user'}) {
            $$me{'auth_user'} = $p{'auth_user'};
        };
        if(defined $p{'auth_pass'}) {
            $$me{'auth_pass'} = $p{'auth_pass'};
        };
        if($$me{'auth_user'} || $$me{'auth_pass'}){
            $$me{'auth'} = &URLencode($$me{'auth_user'}) . ':' . &URLencode($$me{'auth_pass'}) . '@';
        };
    };
};



sub expand_relative_to_full_url                             # MAKES A RELATIVE URL TO FULL
{
    my($base_data,$rel_url) = @_;
    $rel_url = '' if !defined $rel_url;
    $rel_url = &prune_str($rel_url);
    my $full_url = $rel_url;
    if(($rel_url ne '') && ($rel_url !~ m/^https?:/i)){       # it's a relative url -> add full specification
        my $full_url_obj = new MTS4::STD::URL(%$base_data);
        if($rel_url =~ m{^/}) {                             # relative to root
            $$full_url_obj{'uri'} = $rel_url;
        } else {                                            # relative to path
            $$full_url_obj{'path'} =~ s{/[^/]+$}{/};        # remove script name from path
            while ($rel_url =~ s{^\.\./(.*)$}{$1}){         # resolve ../ parts from a relative path
                $$full_url_obj{'path'} =~ s{/[^/]+/$}{/};    # move up root
            };
            $$full_url_obj{'uri'} = "$$full_url_obj{'path'}$rel_url";
        };
        $full_url_obj->build_urls_from_components;
        $full_url = $$full_url_obj{'url'};
    };
    return $full_url;
};


############## URL/VARIABLES ENCODING/DECODINGS ########################################################


sub URLencode                                   # URL ENCODE A STRING
{
    my($s) = @_;                                # string to encode
    my $str = '';                               # encoded string
    my @h = ('A'..'F');                         # hex numbers
    while ($s =~ m/(.)/sg) {
        my $char = $1;
        if($char !~ /([\w\. ])/) {              # encode only non-word symbols
            my $c = ord $char;
            my $c1 = $c % 16;                   # making first hex digit
            if($c1 > 9) {
                $c1 = $h[$c1 - 10];
            };
            my $c2 = int ($c / 16);             # making the second hex digit
            if($c2 > 9) {
                $c2 = $h[$c2 - 10];
            };
            $char = "%$c2$c1";                  # this is the hex code of the symbol
        };
        $str .= $char;
    };
    $str =~ s/ /+/sg;                           # encode white spaces with + signs
    return $str;                                # return URL-encoded string
};



sub URLdecode                                   # DECODE URL-ENCODED STRING
{
    my($str) = @_;
    $str =~ s/\+/ /sg;
    $str =~ s/%([A-Fa-f0-9]{2})/pack("C",hex($1))/sge;
    return $str;
};



sub variables_encode                            # URLENCODE THE VARIABLES/VALUES
{
    my($variables) = @_;                        # hash of variable/value pairs
    my @pairs = ();
    for my $var (keys %$variables) {
       push @pairs, (&URLencode($var) . "=" . &URLencode($$variables{$var}));
    };
    return join('&',@pairs);
};



sub variables_decode                            # DECODE AN URL QUERY STRING INTO VARIABLE/VALUE HASH
{
    my($vars_str) = @_;                         # variables string
    my $hash = {};
    my @pairs = split(m/&/,$vars_str);
    for my $pair (@pairs) {
        my($var,$val) = split(/=/,$pair);
        $var = '' if !defined $var;
        $val = '' if !defined $val;
        $$hash{&URLdecode($var)} = &URLdecode($val);
    };
    return $hash;
};



sub fix_url                                     # MAKE SURE THAT THIS IS A VALID URL
{
    my($url) = @_;
    $url = &prune_str($url);
    $url =~ s/\s*//sg;                          # shrink url
    if($url eq 'http://') {
        $url = '';
    };
    $url =~ s{^https?://https?://}{https?://}i;       # fix double http://
    if($url && ($url !~ s{^https?://}{http://}i)){
        $url = "http://$url";
    };
    &untaint(\$url);
    return $url;
};


############## SUBROUTINES USED BY MAIN METHODS ########################################################


sub set_defaults                                    # SETTING SOME DEFAULT URL VALUES
{
    my($me,$url) = @_;
    $$me{'protocol'} = 'http';
    $$me{'host'} = '';
    $$me{'path'} = '/';
    $$me{'uri'} = '/';
    $$me{'port'} = 80;
    $$me{'vars_str'} = '';
    $$me{'variables'} = {};
    $$me{'auth'} = '';
    $$me{'auth_pass'} = $$me{'auth_user'} = '';
};



sub parse_uri                                       # PARSING AN URI TO ITS COMPONENTS
{
    my($me,$uri) = @_;
    $$me{'uri'} = $uri if defined $uri;
    if($$me{'uri'} eq '') {
        $$me{'uri'} = '/';                          # uri must start with / always
    };
    $$me{'uri'} =~ s{^([^/])}{/$1};                 # uri must start with / always
    $$me{'path'} = $$me{'uri'};                     # extracting 'path' and 'variables_string':
    $$me{'vars_str'} = '';
    if($$me{'uri'} =~ m{^(.+)\?(.*)$}) {
        $$me{'path'} = $1;
        $$me{'vars_str'} = $2;
    };                                              # making 'variables' hash:
    $$me{'variables'} = $me->variables_decode($$me{'vars_str'});
};



sub make_host_port_www_variants             # MAKE HOST:PORT VALUES AND VARIANTS WITH(OUT) WWW. SUBDOMAIN
{
    my($me) = @_;
    $$me{'host_without_www'} = $$me{'host'};        # make variants with 'www.' subdomain and without
    $$me{'host_without_www'} =~ s/^www\.//;
    $$me{'host_with_www'} = $$me{'host'};
    $$me{'host_with_www'} = "www.$$me{'host_without_www'}";
    if($$me{'port'} eq '80'){                       # smart removing of default port 80
        $$me{'host_port'} = $$me{'host'};
        $$me{'host_port_without_www'} = $$me{'host_without_www'};
        $$me{'host_port_with_www'} = $$me{'host_with_www'};
    } else {
        $$me{'host_port'} = "$$me{'host'}:$$me{'port'}";
        $$me{'host_port_without_www'} = "$$me{'host_without_www'}:$$me{'port'}";
        $$me{'host_port_with_www'} = "$$me{'host_with_www'}:$$me{'port'}";
    };
};



sub build_urls_from_components                  # MAKE ALL VARIANTS URL FROM ITS COMPONENTS
{
    my($me) = @_;
    $$me{'url'} = "http://$$me{'auth'}$$me{'host_port'}$$me{'uri'}";
    $$me{'url_without_www'} = "http://$$me{'auth'}$$me{'host_port_without_www'}$$me{'uri'}";
    $$me{'url_with_www'} = "http://$$me{'auth'}$$me{'host_port_with_www'}$$me{'uri'}";
    $$me{'host_url_without_www'} = "http://$$me{'auth'}$$me{'host_port_without_www'}";
    $$me{'host_url_with_www'} = "http://$$me{'auth'}$$me{'host_port_with_www'}";
};



1; # this library must return TRUE


