{-------------------------------------------------------------}
{
{    Webvox - Módulo de interpretação da URL
{
{    Autores: Jose' Antonio Borges e Bernard Condorcet Porto
{
{    Em 18/10/99
{
{-------------------------------------------------------------}

unit weburl;
interface
uses dvcrt, strings, dvWin;

function maiusc (s: string): string;
procedure completaEsquema (var nomePag: string);
function nomeComputValido (nome: string): boolean;
procedure compilaURL (nomePag: string;
    var scheme, net_loc, path, params, query, fragment: string);
procedure montaURLrelativa (nomeRelativo, nomeBase: string;
                            var nomeAbsoluto: string);
procedure extraiNomePorta (net_loc: string; var nomeComp: string;
                            var porta: word);

implementation

{-------------------------------------------------------------}
{            transforma uma cadeia em maiúsculas
{-------------------------------------------------------------}

function maiusc (s: string): string;
var s2: string;
    i: integer;
begin
    s2 := s;
    for i := 1 to length (s) do
        s2 [i] := upcase (s[i]);
    maiusc := s2;
end;

{-------------------------------------------------------------}
{         completa esquema da pagina quando vem de teclado
{-------------------------------------------------------------}

procedure completaEsquema (var nomePag: string);
var i: integer;
begin
    while (nomePag <> '') and (nomePag [1] = ' ') do
        delete (nomePag, 1, 1);
    while (nomePag <> '') and (nomePag [length(nomePag)] = ' ') do
        delete (nomePag, length(nomePag), 1);

    for i := 1 to length (nomePag) do
        if nomePag[i] = '\' then nomePag[i] := '/';

    if (length (nomePag) > 2) and (upcase(nomePag[1]) in ['A'..'Z']) and
                            (nomePag[2] = ':') then
       begin
           nomePag [2] := '|';
           nomePag := 'file://'+ nomePag;
       end
    else
       begin
           if pos (':', nomePag) = 0 then
               nomePag := 'http://'+ nomePag
       end;
end;


{-------------------------------------------------------------}
{              traduz nome e porta de acesso
{-------------------------------------------------------------}

procedure extraiNomePorta (net_loc: string; var nomeComp: string;
                           var porta: word);
var p, erro: integer;
begin
    porta := 80;
    nomeComp := net_loc;

    p := pos (':', net_loc);
    if p <> 0 then
        begin
           val (copy (net_loc, p+1, length (net_loc)-p), porta, erro);
           if erro <> 0 then porta := 80;
           nomeComp := copy (net_loc, 1, p-1);
        end;
end;

{-------------------------------------------------------------}
{          verifica se nome do computador é valido
{-------------------------------------------------------------}

function nomeComputValido (nome: string): boolean;
var i: integer;
    contaPontos: integer;
begin
    nomeComputValido := true;

    contaPontos := 0;
    for i := 1 to length (nome) do
        if nome[i] = '.' then
            contaPontos := contaPontos + 1;

    if contaPontos = 0 then
        begin
            nomeComputValido := false;
            exit;
        end;

    if contaPontos > 1 then
        exit;

    nome := copy (maiusc (nome), length (nome)-2, 3);
    if (nome = 'COM') or (nome = 'EDU') or (nome = 'NET') or
       (nome = 'ORG') or (nome = 'GOV') or (nome = 'MIL') then
           exit;

    nomeComputValido := false;
end;

{-------------------------------------------------------------}
{             extrai o nome da sintaxe HTTP
{              algoritmo baseado na RFC1808
{-------------------------------------------------------------}

procedure compilaURL (nomePag: string;
    var scheme, net_loc, path, params, query, fragment: string);
var i, p, erro: integer;
    resto: string;
label fim;
begin
    scheme := '';
    net_loc := '';
    path := '';
    params := '';
    query := '';
    fragment := '';

    p := pos ('#', nomePag);
    if p <> 0 then
        begin
            fragment := copy (nomePag, p+1, length (nomePag)-p);
            delete (nomePag, p, length (nomePag)-p+1);
        end;

    p := pos ('://', nomePag);
    if p <> 0 then
         begin
             scheme := copy (nomePag, 1, p-1);
             for i := 1 to length (scheme) do
                 scheme [i] := upcase(scheme [i]);
             delete (nomePag, 1, p);
         end
    else
         begin
              if maiusc (copy (nomePag, 1, 7)) = 'MAILTO:' then
                   begin
                       scheme := 'MAILTO';
                       delete (nomePag, 1, 7);
                   end;
         end;

    if scheme = 'FILE' then
        begin
            if copy (nomePag, 1, 2) = '//' then
                delete (nomePag, 1, 2);
        end
    else
    if copy (nomePag, 1, 2) = '//' then
        begin
            delete (nomePag, 1, 2);
            p := pos ('/', nomePag);
            if p = 0  then p := pos ('?', nomePag);
            if p = 0  then p := pos (';', nomePag);
            if p = 0  then
                begin
                    net_loc := nomePag;
                    nomePag := '';
                end
            else
                begin
                    net_loc := copy (nomePag, 1, p-1);
                    delete (nomePag, 1, p-1);
                end;
        end;

    p := pos ('?', nomePag);
    if p <> 0 then
        begin
            query := copy (nomePag, p+1, length (nomePag)-p);
            delete (nomePag, p, length (nomePag)-p+1);
        end;

    p := pos (';', nomePag);
    if p <> 0 then
        begin
            params := copy (nomePag, p+1, length (nomePag)-p);
            delete (nomePag, p, length (nomePag)-p+1);
        end;

    path := nomePag;

    if (net_loc <> '') and (path = '') then
        path := '/';
end;

{-------------------------------------------------------------}
{           transforma url relativa em absoluta
{              algoritmo baseado na RFC1808
{-------------------------------------------------------------}

procedure montaURLrelativa (nomeRelativo, nomeBase: string;
                            var nomeAbsoluto: string);
var
    scheme, net_loc, path, params, query, fragment: string;
    bscheme, bnet_loc, bpath, bparams, bquery, bfragment: string;
    i, p: integer;
label 7, tiraUmaBarra, achouUltimaBarra;

begin
    compilaURL (nomeRelativo, scheme, net_loc, path, params, query, fragment);

    if (scheme = '') and (net_loc = '') and (path = '') and
       (params = '') and (query = '') and (fragment = '') then
           begin
               nomeAbsoluto := nomeBase;
               exit;
           end;

   if scheme <> '' then
         begin
              nomeAbsoluto := nomeRelativo;
              exit;
         end;

    compilaURL (nomeBase, bscheme, bnet_loc, bpath, bparams, bquery, bfragment);
    scheme := bscheme;

    if net_loc <> '' then goto 7;
    net_loc := bnet_loc;

    if (path <> '') and (path[1] = '/') then goto 7;
    if path = '' then
        begin
            path := bpath;
            if params <> '' then goto 7;
            params := bparams;

            if query <> '' then goto 7;
            query := bquery;
            goto 7;
        end
    else
        begin
    tiraUmaBarra:
            for i := length (bpath) downto 1 do
                if bpath[i] = '/' then goto achouUltimaBarra;
            i := 0;
    achouUltimaBarra:
            delete (bpath, i+1, length (bpath)-i);

            if copy (path, 1, 3) = '../' then
                begin
                    delete (path, 1, 3);
                    if (bpath [length(bpath)] = '/') and        {tem alguma barra antes}
                       (pos ('/', bpath) <> length (bpath))then
                        delete (bpath, length (bpath), 1);
                    goto tiraUmaBarra;
                end;

            bpath := bpath + path;
            while (length (bpath) >= 2) and (bpath [1] = '.') and (bpath [2] = '/') do
                delete (bpath, 1, 2);
            repeat
                p := pos ('./', bpath);
                if p <> 0 then delete (bpath, p, 2);
            until p = 0;

            while copy (bpath, length(bpath)-1, 2) = '/.' do
                delete (bpath, length (bpath)-1, 2);
            if bpath = '.' then bpath := '';

            { itens c e d da RFC não foram implementados }

            path := bpath;
        end;
7:
    nomeAbsoluto := scheme + '://'+
                 net_loc + path;
    if params <> '' then
         nomeAbsoluto := nomeAbsoluto + ';' + params;
    if query <> '' then
         nomeAbsoluto := nomeAbsoluto + '?' + query;
    if fragment <> '' then
         nomeAbsoluto := nomeAbsoluto + '#' + fragment;
end;

end.
