/[suikacvs]/test/html-webhacc/WebHACC/Input.pm
Suika

Diff of /test/html-webhacc/WebHACC/Input.pm

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

revision 1.1 by wakaba, Sun Jul 20 14:58:24 2008 UTC revision 1.4 by wakaba, Mon Jul 21 09:40:59 2008 UTC
# Line 2  package WebHACC::Input; Line 2  package WebHACC::Input;
2  use strict;  use strict;
3    
4  sub new ($) {  sub new ($) {
5    return bless {id_prefix => ''}, shift;    return bless {}, shift;
6  } # new  } # new
7    
8  sub id_prefix ($;$) {  sub id_prefix ($) { '' }
9    if (@_ > 1) {  
10      if (defined $_[1]) {  sub nested ($) { 0 }
11        $_[0]->{id_prefix} = ''.$_[1];  
12    sub subdocument_index ($) { 0 }
13    
14    sub full_subdocument_index ($) { 0 }
15    
16    sub generate_info_section ($$) {
17      my $self = shift;
18      
19      my $result = shift;
20      my $out = $result->output;
21    
22      $out->start_section (id => 'document-info', title => 'Information');
23      $out->start_tag ('dl');
24    
25      $out->dt ('Request URL');
26      $out->start_tag ('dd');
27      $out->url ($self->{request_uri});
28    
29      $out->dt ('Document URL'); ## TODO: HTML5 "document's address"?
30      $out->start_tag ('dd');
31      $out->url ($self->{uri}, id => 'anchor-document-url');
32      $out->script (q[
33          document.title = '<'
34              + document.getElementById ('anchor-document-url').href + '> \\u2014 '
35              + document.title;
36      ]);
37    
38      if (defined $self->{s}) {
39        $out->dt ('Base URL');
40        $out->start_tag ('dd');
41        $out->url ($self->{base_uri});
42        
43        $out->dt ('Internet Media Type');
44        $out->start_tag ('dd');
45        $out->code ($self->{media_type}, class => 'MIME', lang => 'en');
46        if ($self->{media_type_overridden}) {
47          $out->html (' <em>(overridden)</em>');
48        } elsif (defined $self->{official_type}) {
49          if ($self->{media_type} eq $self->{official_type}) {
50            #
51          } else {
52            $out->html (' <em>(sniffed; official type is: ');
53            $out->code ($self->{official_type}, class => 'MIME', lang => 'en');
54            $out->html (')</em>');
55          }
56        } else {
57          $out->html ( '<em>(sniffed)</em>');
58        }
59    
60        $out->dt ('Character Encoding');
61        $out->start_tag ('dd');
62        if (defined $self->{charset}) {
63          $out->code ($self->{charset}, class => 'charset', lang => 'en');
64      } else {      } else {
65        $_[0]->{id_prefix} = '';        $out->text ('(none)');
66      }      }
67        $out->html (' <em>overridden</em>') if $self->{charset_overridden};
68    
69        $out->dt ($self->{is_char_string} ? 'Character Length' : 'Byte Length');
70        ## TODO: formatting
71        $out->start_tag ('dd');
72        my $length = length $self->{s};
73        $out->text ($length . ($self->{is_char_string} ? ' character' : ' byte') .
74                    ($length == 1 ? '' : 's'));
75      }
76    
77      $out->end_tag ('dl');
78      $out->end_section;
79    } # generate_info_section
80    
81    sub generate_transfer_sections ($$) {
82      my $self = shift;
83      my $result = shift;
84      
85      $self->generate_http_header_section ($result);
86    } # generate_transfer_sections
87    
88    sub generate_http_header_section ($$) {
89      my ($self, $result) = @_;
90      
91      return unless defined $self->{header_status_code} or
92          defined $self->{header_status_text} or
93          @{$self->{header_field} or []};
94    
95      my $out = $result->output;
96      
97      $out->start_section (id => 'source-header', title => 'HTTP Header');
98      $out->html (qq[<p><strong>Note</strong>: Due to the limitation of the
99    network library in use, the content of this section might
100    not be the real header.</p>
101    
102    <table><tbody>
103    ]);
104    
105      if (defined $self->{header_status_code}) {
106        $out->html (qq[<tr><th scope="row">Status code</th>]);
107        $out->start_tag ('td');
108        $out->code ($self->{header_status_code});
109    }    }
110      if (defined $self->{header_status_text}) {
111        $out->html (qq[<tr><th scope="row">Status text</th>]);
112        $out->start_tag ('td');
113        $out->code ($self->{header_status_text});
114      }
115      
116      for (@{$self->{header_field}}) {
117        $out->start_tag ('tr');
118        $out->start_tag ('th', scope => 'row');
119        $out->code ($_->[0]);
120        $out->start_tag ('td');
121        $out->code ($_->[1]);
122      }
123    
124      $out->end_tag ('table');
125    
126    return $_[0]->{id_prefix};    $out->end_section;
127    } # generate_http_header_section
128    
129    package WebHACC::Input::Subdocument;
130    push our @ISA, 'WebHACC::Input';
131    
132    sub new ($$) {
133      my $self = bless {}, shift;
134      $self->{subdocument_index} = shift;
135      return $self;
136    } # new
137    
138    sub id_prefix ($) {
139      return 'subdoc-' . shift->{subdocument_index} . '-';
140  } # id_prefix  } # id_prefix
141    
142  sub nested ($;$) {  sub nested ($) { 1 }
143    if (@_ > 1) {  
144      if ($_[1]) {  sub subdocument_index ($) {
145        $_[0]->{nested} = 1;    return shift->{subdocument_index};
146      } else {  } # subdocument_index
147        delete $_[0]->{nested};  
148      }  sub full_subdocument_index ($) {
149      my $self = shift;
150      my $parent = $self->{parent_input}->full_subdocument_index;
151      if ($parent) {
152        return $parent . '.' . $self->{subdocument_index};
153      } else {
154        return $self->{subdocument_index};
155      }
156    } # full_subdocument_index
157    
158    sub start_section ($$) {
159      my $self = shift;
160    
161      my $result = shift;
162      my $out = $result->output;
163    
164      my $index = $self->full_subdocument_index;
165      $out->start_section (id => $self->id_prefix,
166                           title => qq[Subdocument #] . $index,
167                           short_title => 'Sub #' . $index);
168    } # start_section
169    
170    sub end_section ($$) {
171      $_[1]->output->end_section;
172    } # end_section
173    
174    sub generate_info_section ($$) {
175      my $self = shift;
176    
177      my $result = shift;
178      my $out = $result->output;
179    
180      $out->start_section (id => 'document-info', title => 'Information');
181      $out->start_tag ('dl');
182    
183      $out->dt ('Internet Media Type');
184      $out->start_tag ('dd');
185      $out->code ($self->{media_type}, code => 'MIME', lang => 'en');
186    
187      if (defined $self->{container_node}) {
188        $out->dt ('Container Node');
189        $out->start_tag ('dd');
190        my $original_input = $out->input;
191        $out->input ($self->{parent_input});
192        $out->node_link ($self->{container_node});
193        $out->input ($original_input);
194    }    }
195    
196    return $_[0]->{nested};    $out->dt ('Base URL');
197  } # nested    $out->start_tag ('dd');
198      $out->url ($self->{base_uri});
199    
200      $out->end_tag ('dl');
201      $out->end_section;
202    } # generate_info_section
203    
204    package WebHACC::Input::Error;
205    push our @ISA, 'WebHACC::Input';
206    
207    sub generate_transfer_sections ($$) {
208      my $self = shift;
209    
210      $self->SUPER::generate_transfer_sections (@_);
211      
212      my $result = shift;
213      my $out = $result->output;
214    
215      $out->start_section (id => 'transfer-errors', title => 'Transfer Errors');
216    
217      $out->start_tag ('dl');
218      $result->add_error (layer => 'transfer',
219                          level => 'u',
220                          type => 'resource retrieval error',
221                          url => $self->{request_uri},
222                          text => $self->{error_status_text});
223      $out->end_tag ('dl');
224    
225      $out->end_section;
226    } # generate_transfer_sections
227    
228  1;  1;
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.4
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24