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