/[pub]/test/html-webhacc/cc.cgi
Suika

Diff of /test/html-webhacc/cc.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.54 by wakaba, Sun Jul 20 16:53:10 2008 UTC revision 1.64 by wakaba, Sun Aug 17 05:06:21 2008 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
 use utf8;  
3    
4  use lib qw[/home/httpd/html/www/markup/html/whatpm  use lib qw[/home/httpd/html/www/markup/html/whatpm
5             /home/wakaba/work/manakai2/lib];             /home/wakaba/work/manakai2/lib];
6  use CGI::Carp qw[fatalsToBrowser];  use CGI::Carp qw[fatalsToBrowser];
 use Scalar::Util qw[refaddr];  
7    
8    require WebHACC::Input;    require WebHACC::Input;
   require WebHACC::Result;  
   require WebHACC::Output;  
   
 my $out;  
9    
   require Message::DOM::DOMImplementation;  
   my $dom = Message::DOM::DOMImplementation->new;  
10  {  {
11    use Message::CGI::HTTP;    require Message::CGI::HTTP;
12    my $http = Message::CGI::HTTP->new;    my $http = Message::CGI::HTTP->new;
13    
14      require WebHACC::Output;
15      my $out = WebHACC::Output->new;
16      $out->handle (*STDOUT);
17      $out->set_utf8;
18    
19    if ($http->get_meta_variable ('PATH_INFO') ne '/') {    if ($http->get_meta_variable ('PATH_INFO') ne '/') {
20      print STDOUT "Status: 404 Not Found\nContent-Type: text/plain; charset=us-ascii\n\n400";      $out->http_error (404);
21      exit;      exit;
22    }    }
     
   load_text_catalog ('en'); ## TODO: conneg  
23    
24    $out = WebHACC::Output->new;    ## TODO: We need real conneg support...
25    $out->handle (*STDOUT);    my $primary_language = 'en';
26    $out->set_utf8;    if ($ENV{HTTP_ACCEPT_LANGUAGE} =~ /ja/) {
27        $primary_language = 'ja';
28      }
29      $out->load_text_catalog ($primary_language);
30      
31    $out->set_flush;    $out->set_flush;
32    $out->html (qq[Content-Type: text/html; charset=utf-8    $out->http_header;
33      $out->html_header;
 <!DOCTYPE html>  
 <html lang="en">  
 <head>  
 <title>Web Document Conformance Checker (BETA)</title>  
 <link rel="stylesheet" href="../cc-style.css" type="text/css">  
 </head>  
 <body>  
 <h1><a href="../cc-interface">Web Document Conformance Checker</a>  
 (<em>beta</em>)</h1>  
 ]);  
   
   my $input = get_input_document ($http, $dom);  
   $out->input ($input);  
34    $out->unset_flush;    $out->unset_flush;
35    
36    my $char_length = 0;    $out->generate_input_section ($http);
37    
38    $out->start_section (id => 'document-info', title => 'Information');    my $u = $http->get_parameter ('uri');
39    $out->html (qq[<dl>    my $s = $http->get_parameter ('s');
40  <dt>Request URL</dt>    if ((not defined $u or not length $u) and
41      <dd>]);        (not defined $s or not length $s)) {
42    $out->url ($input->{request_uri});      exit;
   $out->html (q[<dt>Document URL<!-- HTML5 document's address? -->  
     <dd>]);  
   $out->url ($input->{uri}, id => 'anchor-document-url');  
   $out->html (q[  
     <script>  
       document.title = '<'  
           + document.getElementById ('anchor-document-url').href + '> \\u2014 '  
           + document.title;  
     </script>]);  
   ## NOTE: no </dl> yet  
   
   if (defined $input->{s}) {  
     $char_length = length $input->{s};  
   
     $out->html (qq[<dt>Base URI<dd>]);  
     $out->url ($input->{base_uri});  
     $out->html (qq[<dt>Internet Media Type</dt>  
     <dd><code class="MIME" lang="en">]);  
     $out->text ($input->{media_type});  
     $out->html (qq[</code> ]);  
     if ($input->{media_type_overridden}) {  
       $out->html ('<em>(overridden)</em>');  
     } elsif (defined $input->{official_type}) {  
       if ($input->{media_type} eq $input->{official_type}) {  
         #  
       } else {  
         $out->html ('<em>(sniffed; official type is: <code class=MIME lang=en>');  
         $out->text ($input->{official_type});  
         $out->html ('</code>)');  
       }  
     } else {  
       $out->html ('<em>(sniffed)</em>');  
     }  
     $out->html (q[<dt>Character Encoding<dd>]);  
     if (defined $input->{charset}) {  
       $out->html ('<code class="charset" lang="en">');  
       $out->text ($input->{charset});  
       $out->html ('</code>');  
     } else {  
       $out->text ('(none)');  
     }  
     $out->html (' <em>overridden</em>') if $input->{charset_overridden};  
     $out->html (qq[  
 <dt>Length</dt>  
     <dd>$char_length byte@{[$char_length == 1 ? '' : 's']}</dd>  
 </dl>  
   
 <script src="../cc-script.js"></script>  
 ]);  
     $out->end_section;  
   
     my $result = WebHACC::Result->new;  
     $result->output ($out);  
     $result->{conforming_min} = 1;  
     $result->{conforming_max} = 1;  
     check_and_print ($input => $result => $out);  
     $result->generate_result_section;  
   } else {  
     $out->html ('</dl>');  
     $out->end_section;  
   
     my $result = WebHACC::Result->new;  
     $result->output ($out);  
     $result->{conforming_min} = 0;  
     $result->{conforming_max} = 1;  
   
     $input->generate_transfer_sections ($result);  
     $result->generate_result_section;  
43    }    }
44    
45      require WebHACC::Result;
46      my $result = WebHACC::Result->new;
47      $result->output ($out);
48    
49      require WebHACC::Input;
50      my $input = WebHACC::Input->get_document ($http => $result => $out);
51    
52      check_and_print ($input => $result => $out);
53      
54    $out->nav_list;    $out->nav_list;
55    
56    exit;    exit;
# Line 134  sub check_and_print ($$$) { Line 61  sub check_and_print ($$$) {
61    my $original_input = $out->input;    my $original_input = $out->input;
62    $out->input ($input);    $out->input ($input);
63    
64      $input->generate_info_section ($result);
65    
66    $input->generate_transfer_sections ($result);    $input->generate_transfer_sections ($result);
67    
68    my @subdoc;    unless (defined $input->{s}) {
69        ## NOTE: This is an error of the implementation.
70        $result->layer_uncertain ('transfer');
71        $result->generate_result_section;
72    
73        $out->input ($original_input);
74        return;
75      }
76    
77    my $checker_class = {    my $checker_class = {
78      'text/cache-manifest' => 'WebHACC::Language::CacheManifest',      'text/cache-manifest' => 'WebHACC::Language::CacheManifest',
79      'text/css' => 'WebHACC::Language::CSS',      'text/css' => 'WebHACC::Language::CSS',
80      'text/html' => 'WebHACC::Language::HTML',      'text/html' => 'WebHACC::Language::HTML',
81        'text/x-h2h' => 'WebHACC::Language::H2H',
82      'text/x-webidl' => 'WebHACC::Language::WebIDL',      'text/x-webidl' => 'WebHACC::Language::WebIDL',
83    
84      'text/xml' => 'WebHACC::Language::XML',      'text/xml' => 'WebHACC::Language::XML',
# Line 169  sub check_and_print ($$$) { Line 106  sub check_and_print ($$$) {
106    $checker->generate_syntax_error_section;    $checker->generate_syntax_error_section;
107    $checker->generate_source_string_section;    $checker->generate_source_string_section;
108    
109      my @subdoc;
110    $checker->onsubdoc (sub {    $checker->onsubdoc (sub {
111      push @subdoc, shift;      push @subdoc, shift;
112    });    });
# Line 177  sub check_and_print ($$$) { Line 115  sub check_and_print ($$$) {
115    $checker->generate_structure_error_section;    $checker->generate_structure_error_section;
116    $checker->generate_additional_sections;    $checker->generate_additional_sections;
117    
 =pod  
   
   if (defined $doc or defined $el) {  
   
     print_table_section ($input, $elements->{table}) if @{$elements->{table}};  
     print_listing_section ({  
       id => 'identifiers', label => 'IDs', heading => 'Identifiers',  
     }, $input, $elements->{id}) if keys %{$elements->{id}};  
     print_listing_section ({  
       id => 'terms', label => 'Terms', heading => 'Terms',  
     }, $input, $elements->{term}) if keys %{$elements->{term}};  
     print_listing_section ({  
       id => 'classes', label => 'Classes', heading => 'Classes',  
     }, $input, $elements->{class}) if keys %{$elements->{class}};  
     
     print_rdf_section ($input, $elements->{rdf}) if @{$elements->{rdf}};  
   }  
   
 =cut  
   
118    my $id_prefix = 0;    my $id_prefix = 0;
119    for my $_subinput (@subdoc) {    for my $_subinput (@subdoc) {
120      my $subinput = WebHACC::Input->new;      my $subinput = WebHACC::Input::Subdocument->new (++$id_prefix);
121      $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;      $subinput->{$_} = $_subinput->{$_} for keys %$_subinput;
     $subinput->id_prefix ('subdoc-' . ++$id_prefix);  
     $subinput->nested (1);  
122      $subinput->{base_uri} = $subinput->{container_node}->base_uri      $subinput->{base_uri} = $subinput->{container_node}->base_uri
123          unless defined $subinput->{base_uri};          unless defined $subinput->{base_uri};
124      my $ebaseuri = htescape ($subinput->{base_uri});      $subinput->{parent_input} = $input;
     $out->start_section (id => $subinput->id_prefix,  
                          title => qq[Subdocument #$id_prefix]);  
     print STDOUT qq[  
       <dl>  
       <dt>Internet Media Type</dt>  
         <dd><code class="MIME" lang="en">@{[htescape $subinput->{media_type}]}</code>  
       <dt>Container Node</dt>  
         <dd>@{[get_node_link ($input, $subinput->{container_node})]}</dd>  
       <dt>Base <abbr title="Uniform Resource Identifiers">URI</abbr></dt>  
         <dd><code class=URI>&lt;<a href="$ebaseuri">$ebaseuri</a>></code></dd>  
       </dl>];                
125    
126      $subinput->{id_prefix} .= '-';      my $subresult = WebHACC::Result->new;
127      check_and_print ($subinput => $result => $out);      $subresult->output ($out);
128        $subresult->parent_result ($result);
129    
130      $out->end_section;      $subinput->start_section ($subresult);
131        check_and_print ($subinput => $subresult => $out);
132        $subinput->end_section ($subresult);
133    }    }
134    
135      $result->generate_result_section;
136    
137    $out->input ($original_input);    $out->input ($original_input);
138  } # check_and_print  } # check_and_print
139    
 sub print_table_section ($$) {  
   my ($input, $tables) = @_;  
     
 #  push @nav, [qq[#$input->{id_prefix}tables] => 'Tables']  
 #      unless $input->{nested};  
   print STDOUT qq[  
 <div id="$input->{id_prefix}tables" class="section">  
 <h2>Tables</h2>  
   
 <!--[if IE]><script type="text/javascript" src="../excanvas.js"></script><![endif]-->  
 <script src="../table-script.js" type="text/javascript"></script>  
 <noscript>  
 <p><em>Structure of tables are visualized here if scripting is enabled.</em></p>  
 </noscript>  
 ];  
     
   require JSON;  
     
   my $i = 0;  
   for my $table (@$tables) {  
     $i++;  
     print STDOUT qq[<div class="section" id="$input->{id_prefix}table-$i"><h3>] .  
         get_node_link ($input, $table->{element}) . q[</h3>];  
   
     delete $table->{element};  
   
     for (@{$table->{column_group}}, @{$table->{column}}, $table->{caption},  
          @{$table->{row}}) {  
       next unless $_;  
       delete $_->{element};  
     }  
       
     for (@{$table->{row_group}}) {  
       next unless $_;  
       next unless $_->{element};  
       $_->{type} = $_->{element}->manakai_local_name;  
       delete $_->{element};  
     }  
       
     for (@{$table->{cell}}) {  
       next unless $_;  
       for (@{$_}) {  
         next unless $_;  
         for (@$_) {  
           $_->{id} = refaddr $_->{element} if defined $_->{element};  
           delete $_->{element};  
           $_->{is_header} = $_->{is_header} ? 1 : 0;  
         }  
       }  
     }  
           
     print STDOUT '</div><script type="text/javascript">tableToCanvas (';  
     print STDOUT JSON::objToJson ($table);  
     print STDOUT qq[, document.getElementById ('$input->{id_prefix}table-$i')];  
     print STDOUT qq[, '$input->{id_prefix}');</script>];  
   }  
     
   print STDOUT qq[</div>];  
 } # print_table_section  
   
 sub print_listing_section ($$$) {  
   my ($opt, $input, $ids) = @_;  
     
 #  push @nav, ['#' . $input->{id_prefix} . $opt->{id} => $opt->{label}]  
 #      unless $input->{nested};  
   print STDOUT qq[  
 <div id="$input->{id_prefix}$opt->{id}" class="section">  
 <h2>$opt->{heading}</h2>  
   
 <dl>  
 ];  
   for my $id (sort {$a cmp $b} keys %$ids) {  
     print STDOUT qq[<dt><code>@{[htescape $id]}</code></dt>];  
     for (@{$ids->{$id}}) {  
       print STDOUT qq[<dd>].get_node_link ($input, $_).qq[</dd>];  
     }  
   }  
   print STDOUT qq[</dl></div>];  
 } # print_listing_section  
   
   
 sub print_rdf_section ($$$) {  
   my ($input, $rdfs) = @_;  
     
 #  push @nav, ['#' . $input->{id_prefix} . 'rdf' => 'RDF']  
 #      unless $input->{nested};  
   print STDOUT qq[  
 <div id="$input->{id_prefix}rdf" class="section">  
 <h2>RDF Triples</h2>  
   
 <dl>];  
   my $i = 0;  
   for my $rdf (@$rdfs) {  
     print STDOUT qq[<dt id="$input->{id_prefix}rdf-@{[$i++]}">];  
     print STDOUT get_node_link ($input, $rdf->[0]);  
     print STDOUT qq[<dd><dl>];  
     for my $triple (@{$rdf->[1]}) {  
       print STDOUT '<dt>' . get_node_link ($input, $triple->[0]) . '<dd>';  
       print STDOUT get_rdf_resource_html ($triple->[1]);  
       print STDOUT ' ';  
       print STDOUT get_rdf_resource_html ($triple->[2]);  
       print STDOUT ' ';  
       print STDOUT get_rdf_resource_html ($triple->[3]);  
     }  
     print STDOUT qq[</dl>];  
   }  
   print STDOUT qq[</dl></div>];  
 } # print_rdf_section  
   
 sub get_rdf_resource_html ($) {  
   my $resource = shift;  
   if (defined $resource->{uri}) {  
     my $euri = htescape ($resource->{uri});  
     return '<code class=uri>&lt;<a href="' . $euri . '">' . $euri .  
         '</a>></code>';  
   } elsif (defined $resource->{bnodeid}) {  
     return htescape ('_:' . $resource->{bnodeid});  
   } elsif ($resource->{nodes}) {  
     return '(rdf:XMLLiteral)';  
   } elsif (defined $resource->{value}) {  
     my $elang = htescape (defined $resource->{language}  
                               ? $resource->{language} : '');  
     my $r = qq[<q lang="$elang">] . htescape ($resource->{value}) . '</q>';  
     if (defined $resource->{datatype}) {  
       my $euri = htescape ($resource->{datatype});  
       $r .= '^^<code class=uri>&lt;<a href="' . $euri . '">' . $euri .  
           '</a>></code>';  
     } elsif (length $resource->{language}) {  
       $r .= '@' . htescape ($resource->{language});  
     }  
     return $r;  
   } else {  
     return '??';  
   }  
 } # get_rdf_resource_html  
   
 {  
   my $Msg = {};  
   
 sub load_text_catalog ($) {  
 #  my $self = shift;  
   my $lang = shift; # MUST be a canonical lang name  
   open my $file, '<:utf8', "cc-msg.$lang.txt"  
       or die "$0: cc-msg.$lang.txt: $!";  
   while (<$file>) {  
     if (s/^([^;]+);([^;]*);//) {  
       my ($type, $cls, $msg) = ($1, $2, $_);  
       $msg =~ tr/\x0D\x0A//d;  
       $Msg->{$type} = [$cls, $msg];  
     }  
   }  
 } # load_text_catalog  
   
 sub get_text ($;$$) {  
 #  my $self = shift;  
   my ($type, $level, $node) = @_;  
   $type = $level . ':' . $type if defined $level;  
   $level = 'm' unless defined $level;  
   my @arg;  
   {  
     if (defined $Msg->{$type}) {  
       my $msg = $Msg->{$type}->[1];  
       $msg =~ s{<var>\$([0-9]+)</var>}{  
         defined $arg[$1] ? ($arg[$1]) : '(undef)';  
       }ge;                 ##BUG: ^ must be escaped  
       $msg =~ s{<var>{\@([A-Za-z0-9:_.-]+)}</var>}{  
         UNIVERSAL::can ($node, 'get_attribute_ns')  
             ?  ($node->get_attribute_ns (undef, $1)) : ''  
       }ge; ## BUG: ^ must be escaped  
       $msg =~ s{<var>{\@}</var>}{        ## BUG: v must be escaped  
         UNIVERSAL::can ($node, 'value') ? ($node->value) : ''  
       }ge;  
       $msg =~ s{<var>{local-name}</var>}{  
         UNIVERSAL::can ($node, 'manakai_local_name')  
           ? ($node->manakai_local_name) : ''  
       }ge;  ## BUG: ^ must be escaped  
       $msg =~ s{<var>{element-local-name}</var>}{  
         (UNIVERSAL::can ($node, 'owner_element') and  
          $node->owner_element)  
           ?  ($node->owner_element->manakai_local_name)  
           : '' ## BUG: ^ must be escaped  
       }ge;  
       return ($type, 'level-' . $level . ' ' . $Msg->{$type}->[0], $msg);  
     } elsif ($type =~ s/:([^:]*)$//) {  
       unshift @arg, $1;  
       redo;  
     }  
   }  
   return ($type, 'level-'.$level, ($_[0]));  
                                  ## BUG: ^ must be escaped  
 } # get_text  
   
 }  
   
 sub get_input_document ($$) {  
   my ($http, $dom) = @_;  
   
   require Encode;  
   my $request_uri = Encode::decode ('utf-8', $http->get_parameter ('uri'));  
   my $r = WebHACC::Input->new;  
   if (defined $request_uri and length $request_uri) {  
     my $uri = $dom->create_uri_reference ($request_uri);  
     unless ({  
              http => 1,  
             }->{lc $uri->uri_scheme}) {  
       $r = WebHACC::Input::Error->new;  
       $r->{uri} = $request_uri;  
       $r->{request_uri} = $request_uri;  
       $r->{error_status_text} = 'URL scheme not allowed';  
     }  
   
     require Message::Util::HostPermit;  
     my $host_permit = new Message::Util::HostPermit;  
     $host_permit->add_rule (<<EOH);  
 Allow host=suika port=80  
 Deny host=suika  
 Allow host=suika.fam.cx port=80  
 Deny host=suika.fam.cx  
 Deny host=localhost  
 Deny host=*.localdomain  
 Deny ipv4=0.0.0.0/8  
 Deny ipv4=10.0.0.0/8  
 Deny ipv4=127.0.0.0/8  
 Deny ipv4=169.254.0.0/16  
 Deny ipv4=172.0.0.0/11  
 Deny ipv4=192.0.2.0/24  
 Deny ipv4=192.88.99.0/24  
 Deny ipv4=192.168.0.0/16  
 Deny ipv4=198.18.0.0/15  
 Deny ipv4=224.0.0.0/4  
 Deny ipv4=255.255.255.255/32  
 Deny ipv6=0::0/0  
 Allow host=*  
 EOH  
     unless ($host_permit->check ($uri->uri_host, $uri->uri_port || 80)) {  
       my $r = WebHACC::Input::Error->new;  
       $r->{uri} = $request_uri;  
       $r->{request_uri} = $request_uri;  
       $r->{error_status_text} = 'Connection to the host is forbidden';  
       return $r;  
     }  
   
     require LWP::UserAgent;  
     my $ua = WDCC::LWPUA->new;  
     $ua->{wdcc_dom} = $dom;  
     $ua->{wdcc_host_permit} = $host_permit;  
     $ua->agent ('Mozilla'); ## TODO: for now.  
     $ua->parse_head (0);  
     $ua->protocols_allowed ([qw/http/]);  
     $ua->max_size (1000_000);  
     my $req = HTTP::Request->new (GET => $request_uri);  
     $req->header ('Accept-Encoding' => 'identity, *; q=0');  
     my $res = $ua->request ($req);  
     ## TODO: 401 sets |is_success| true.  
     if ($res->is_success or $http->get_parameter ('error-page')) {  
       $r->{base_uri} = $res->base; ## NOTE: It does check |Content-Base|, |Content-Location|, and <base>. ## TODO: Use our own code!  
       $r->{uri} = $res->request->uri;  
       $r->{request_uri} = $request_uri;  
   
       ## TODO: More strict parsing...  
       my $ct = $res->header ('Content-Type');  
       if (defined $ct and $ct =~ /;\s*charset\s*=\s*"?([^\s;"]+)"?/i) {  
         $r->{charset} = lc $1;  
         $r->{charset} =~ tr/\\//d;  
         $r->{official_charset} = $r->{charset};  
       }  
   
       my $input_charset = $http->get_parameter ('charset');  
       if (defined $input_charset and length $input_charset) {  
         $r->{charset_overridden}  
             = (not defined $r->{charset} or $r->{charset} ne $input_charset);  
         $r->{charset} = $input_charset;  
       }  
   
       ## TODO: Support for HTTP Content-Encoding  
   
       $r->{s} = ''.$res->content;  
   
       require Whatpm::ContentType;  
       ($r->{official_type}, $r->{media_type})  
           = Whatpm::ContentType->get_sniffed_type  
               (get_file_head => sub {  
                  return substr $r->{s}, 0, shift;  
                },  
                http_content_type_byte => $ct,  
                has_http_content_encoding =>  
                    defined $res->header ('Content-Encoding'),  
                supported_image_types => {});  
     } else {  
       $r->{uri} = $res->request->uri;  
       $r->{request_uri} = $request_uri;  
       $r->{error_status_text} = $res->status_line;  
     }  
   
     $r->{header_field} = [];  
     $res->scan (sub {  
       push @{$r->{header_field}}, [$_[0], $_[1]];  
     });  
     $r->{header_status_code} = $res->code;  
     $r->{header_status_text} = $res->message;  
   } else {  
     $r->{s} = ''.$http->get_parameter ('s');  
     $r->{uri} = q<thismessage:/>;  
     $r->{request_uri} = q<thismessage:/>;  
     $r->{base_uri} = q<thismessage:/>;  
     $r->{charset} = ''.$http->get_parameter ('_charset_');  
     $r->{charset} =~ s/\s+//g;  
     $r->{charset} = 'utf-8' if $r->{charset} eq '';  
     $r->{official_charset} = $r->{charset};  
     $r->{header_field} = [];  
   
     require Whatpm::ContentType;  
     ($r->{official_type}, $r->{media_type})  
         = Whatpm::ContentType->get_sniffed_type  
             (get_file_head => sub {  
                return substr $r->{s}, 0, shift;  
              },  
              http_content_type_byte => undef,  
              has_http_content_encoding => 0,  
              supported_image_types => {});  
   }  
   
   my $input_format = $http->get_parameter ('i');  
   if (defined $input_format and length $input_format) {  
     $r->{media_type_overridden}  
         = (not defined $r->{media_type} or $input_format ne $r->{media_type});  
     $r->{media_type} = $input_format;  
   }  
   if (defined $r->{s} and not defined $r->{media_type}) {  
     $r->{media_type} = 'text/html';  
     $r->{media_type_overridden} = 1;  
   }  
   
   if ($r->{media_type} eq 'text/xml') {  
     unless (defined $r->{charset}) {  
       $r->{charset} = 'us-ascii';  
       $r->{official_charset} = $r->{charset};  
     } elsif ($r->{charset_overridden} and $r->{charset} eq 'us-ascii') {  
       $r->{charset_overridden} = 0;  
     }  
   }  
   
   if (length $r->{s} > 1000_000) {  
     $r->{error_status_text} = 'Entity-body too large';  
     delete $r->{s};  
     return $r;  
   }  
   
   $r->{inner_html_element} = $http->get_parameter ('e');  
   
   return $r;  
 } # get_input_document  
   
 package WDCC::LWPUA;  
 BEGIN { push our @ISA, 'LWP::UserAgent'; }  
   
 sub redirect_ok {  
   my $ua = shift;  
   unless ($ua->SUPER::redirect_ok (@_)) {  
     return 0;  
   }  
   
   my $uris = $_[1]->header ('Location');  
   return 0 unless $uris;  
   my $uri = $ua->{wdcc_dom}->create_uri_reference ($uris);  
   unless ({  
            http => 1,  
           }->{lc $uri->uri_scheme}) {  
     return 0;  
   }  
   unless ($ua->{wdcc_host_permit}->check ($uri->uri_host, $uri->uri_port || 80)) {  
     return 0;  
   }  
   return 1;  
 } # redirect_ok  
   
140  =head1 AUTHOR  =head1 AUTHOR
141    
142  Wakaba <w@suika.fam.cx>.  Wakaba <w@suika.fam.cx>.

Legend:
Removed from v.1.54  
changed lines
  Added in v.1.64

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24