code/UserTag/get_url.tag

   1 # Copyright 2002-2007 Interchange Development Group and others
   2 #
   3 # This program is free software; you can redistribute it and/or modify
   4 # it under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation; either version 2 of the License, or
   6 # (at your option) any later version.  See the LICENSE file for details.
   7 #
   8 # $Id: get_url.tag,v 1.12 2007-12-05 00:38:03 racke Exp $
   9
  10 UserTag get-url Order        url
  11 UserTag get-url AddAttr
  12 UserTag get-url Interpolate
  13 UserTag get-url Version      $Revision: 1.12 $
  14 UserTag get-url Routine      <<EOR
  15 require LWP::UserAgent;
  16 sub {
  17         my ($url, $opt) = @_;
  18         my $html = '';
  19         my $method;
  20
  21         my $ua = LWP::UserAgent->new;
  22
  23         if($opt->{method}) {
  24                 $method = uc($opt->{method});
  25         } else {
  26                 $method = 'GET';
  27         }
  28
  29     if($opt->{timeout}) {
  30                 my $to = Vend::Config::time_to_seconds($opt->{timeout});
  31                 $ua->timeout($to);
  32         }
  33
  34         if($opt->{useragent} ) {
  35                         $ua->agent($opt->{useragent});
  36         }
  37
  38         if($opt->{form}) {
  39                 $opt->{content} = Vend::Interpolate::escape_form($opt->{form});
  40         }
  41
  42         my $do_content;
  43
  44         if ($opt->{content}) {
  45                 if ($method eq 'POST' || $method eq 'PUT') {
  46                         $opt->{content_type} ||= 'application/x-www-form-urlencoded';
  47                         $do_content = 1;
  48                 }
  49                 else {
  50                         $url .= $opt->{url} =~ /\?/ ? '&' : '?';
  51                         $url .= $opt->{content};
  52                 }
  53         }
  54
  55         my $req = HTTP::Request->new($method, $url);
  56
  57         if($do_content) {
  58                 $req->content_type($opt->{content_type});
  59                 $req->content($opt->{content});
  60         }
  61
  62         if($opt->{authuser} && $opt->{authpass}) {
  63                 $req->authorization_basic($opt->{authuser}, $opt->{authpass});
  64         }
  65
  66
  67         my $res = $ua->request($req);
  68
  69         if ($res->is_success) {
  70                 $html .= $res->content;
  71         } else {
  72                 $html .= "Failed - " . $res->status_line;
  73         }
  74
  75         if($opt->{strip}) {
  76                 $html =~ s/.*<body[^>]*>//si;
  77                 $html =~ s:</body>.*::si;
  78         }
  79
  80         if ($opt->{scratch}) {
  81                 $::Scratch->{$opt->{scratch}} = $html;
  82                 return;
  83         }
  84
  85         return $html;
  86 }
  87 EOR