view release on metacpan or  search on metacpan

lib/App/Navegante/CGI.pm  view on Meta::CPAN

    }
    print header(cook(),-charset => 'UTF-8'), $iform;
  }
  elsif( $Navegante->{monadic} && param(action) eq "monadicend"){ 
       $Navegante->{end}() 
  }
  else {
  $U=_fixurl(param('x'));
  my $ua      = LWP::UserAgent->new();
  my $request = HTTP::Request->new(GET => _fixurl(param('x')));
  my $resp    = $ua->request($request);
  $URL = "". $resp->base();         ## the real URL extracted
  $MES = $resp->message();          ## OK if no error
  $CON = $resp->content;            ## the page content
  $cty = $resp->content_type;       ## the content type
  $cen = $resp->content_encoding;   ## the content encoding

  $Navegante->{init}(); 
  if($MES eq "OK"){
    $pag=dtstring($CON,
         -html => 1, 
       -pcdata => sub{ $c =~ s/&/&amp;/g; $c =~ s/</&lt;/g ; $c =~ s/>/&gt;/g ;
                       wrapper_proc($c) },
           img => sub{ $v{src}  = _abs($v{src});                toxml},
     ($Navegante->{monadic} 
          ? (body => sub{ $c = ####TOOLBAR#### . $c; toxml } )
          : ()),
          link => sub{ $v{href} = _abs($v{href});               toxml},
#         form => sub{ $v{action} = compoe($v{action}) if $v{action}; toxml},
             a => sub{ $v{href} = compoe($v{href}) if $v{href}; toxml},
         frame => sub{ $v{src}  = compoe($v{src});              toxml},
        iframe => sub{ $v{src}  = compoe($v{src});              toxml},
          meta => sub{ 
               if($v{content} =~ /utf[_-]?8/i)         {$ENCOD='UTF-8'}
            elsif($v{content} =~ /iso[_-]?8859[_-]?1/i){$ENCOD='ISO-8859-1'}
                       toxml()},
          );
    print header(cook(), -charset => param('e') || $ENCOD ),$pag; }
  else { errorpage($MES) }
  }
}
else {
  %estado =();
  print header(cook(),-charset => 'UTF-8'),
  start_html( -title    =>'####formtitle####',
                -encoding => 'UTF-8',
           -author   =>'jj@di.uminho.pt',
           -meta     =>{'keywords' =>'jspell,linguateca,spell',
                     'charset'  =>'UTF-8'},),
div( {style=>"background-image: url(http://nrc.homelinux.org/navegante/imagens/nav_bg.gif); background-repeat: repeat-x; height: 65px; "},
    "<table border='0' width='100%' cellpadding='0' cellspacing='0'><tr>", 
    "<td width='140'>",
    img({src=>'http://nrc.homelinux.org/navegante/imagens/nav_logo.gif',border=>'0'}),
    "</td>",
    "<td>",a({href=>'http://natura.di.umino.pt/navegante/'}, img({src=>'http://nrc.homelinux.org/navegante/imagens/nav_title.gif',border=>'0'})),"</td>",
    "</td></tr></table>",
    div( {style=>"background-image: url(http://nrc.homelinux.org/navegante/imagens/nav_line.gif); background-repeat: repeat-x; width: 100%; height: 2px;"})
),
     h1('####formtitle####'),
      start_form, "Url ", textfield(-name =>'x',-size=>50),
                  popup_menu(-name=>'e', -values=>['','UTF-8','ISO-8859-1']), 
                  submit, end_form,
                  $Navegante->{desc}(),
                  end_html;
}

sub m_error{ span({-style=>'color: red'},$_[0])}
sub m_eng  { span({-style=>'color: green'},$_[0])}

sub wrapper_proc {
    my $c = shift;

    my $tag = ctxt(1);
    my @l = (####protect####);
END_SKEL

    if ($nav->{'proctags'}) {
        $skeleton .= "    my %proctags = (####proctags####);\n";
    }

$skeleton.=<<'END_SKEL';

    if (grep {$tag eq $_} @l) { 
        return $c;
    }
    else { 
END_SKEL

    if ($nav->{'proctags'}) {
        $skeleton .= "     \$proctags{\$tag} and return \$proctags{\$tag}->(\$c);\n";
    }

$skeleton.=<<'END_SKEL';
        return $Navegante->{f}($c);
    }
}

sub compoe{ 
  my $x= _abs($_[0]);
  return $x if($x =~ /^javascript/i);
  my $y = URI->new(CGI::url());
  $y->query_form(e => param('e'),x => $x );
  "$y";
}

sub _monadicend{ 
  my $y = URI->new(CGI::url());
  $y->query_form(action => "monadicend");
  "$y";
}

sub _abs{
  my $u=shift;
  return $u        if ( $u =~ /^javascript/i);
  "". URI->new_abs($u,$URL);
}

sub _fixurl{
  my $u=shift;
#  $u = "file://localhost/$u" if     ( $u =~ m!^/! );
  $u = "http://$u" unless ( $u =~ m!:/! );