/[suikacvs]/markup/html/whatpm/Whatpm/IMTChecker.pm
Suika

Diff of /markup/html/whatpm/Whatpm/IMTChecker.pm

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

revision 1.2 by wakaba, Sat Jun 30 13:12:33 2007 UTC revision 1.3 by wakaba, Fri Nov 23 14:47:49 2007 UTC
# Line 9  our $Type; Line 9  our $Type;
9    
10  my $application_xml_charset = { ## TODO: ...  my $application_xml_charset = { ## TODO: ...
11    syntax => 'token',    syntax => 'token',
12      registered => 1,
13  };  };
14    
15  $Type->{application}->{registered} = 1;  $Type->{application}->{registered} = 1;
16    
17    $Type->{application}->{subtype}->{'atom+xml'} = { ## NOTE: RFC 4287
18      parameter => {
19        type => { ## NOTE: RFC 5023
20          ## TODO: "entry"|"feed" (case-insensitive)
21          registered => 1,
22          ## NOTE: SHOULD for Atom Entry Document.
23        },
24      },
25      registered => 1,
26    };
27    
28  $Type->{application}->{subtype}->{'rdf+xml'} = { # RFC 3870  $Type->{application}->{subtype}->{'rdf+xml'} = { # RFC 3870
29    parameter => {    parameter => {
30      charset => $application_xml_charset,      charset => $application_xml_charset,
31    },    },
32    registered => 1,    registered => 1,
   
33    ## RECOMMENDED that an RDF document follows new RDF/XML spec    ## RECOMMENDED that an RDF document follows new RDF/XML spec
34    ## rather than 1999 spec - this is not testable in this layer.    ## rather than 1999 spec - this is not testable in this layer.
35  };  };
# Line 43  $Type->{text}->{registered} = 1; Line 54  $Type->{text}->{registered} = 1;
54    
55  $Type->{text}->{subtype}->{plain} = {  $Type->{text}->{subtype}->{plain} = {
56    parameter => {    parameter => {
57      charset => {syntax => 'token'}, # RFC 2046 ## TODO: registered?      charset => {syntax => 'token', registered => 1}, # RFC 2046 ## TODO: registered?
58      'charset-edition' => {}, # RFC 1922      'charset-edition' => {registered => 1}, # RFC 1922
59      'charset-extension' => {syntax => 'token'}, # RFC 1922 ## TODO: registered?      'charset-extension' => {syntax => 'token', registered => 1}, # RFC 1922 ## TODO: registered?
60    },    },
61    registered => 1,    registered => 1,
62  };  };
63  $Type->{text}->{subtype}->{html} = { # RFC 2854  $Type->{text}->{subtype}->{html} = { # RFC 2854
64    parameter => {    parameter => {
65      charset => {}, ## TODO: UTF-8 is preferred ## TODO: strongly recommended that it always be present ## NOTE: Syntax and range are not defined.      charset => {registered => 1}, ## TODO: UTF-8 is preferred ## TODO: strongly recommended that it always be present ## NOTE: Syntax and range are not defined.
66      level => {obsolete =>1}, # RFC 1866      level => {obsolete => 1}, # RFC 1866
67      version => {obsolete => 1}, # HTML 3.0      version => {obsolete => 1}, # HTML 3.0
68    },    },
69    registered => 1,    registered => 1,
70  };  };
71  $Type->{text}->{subtype}->{css} = { # RFC 2318  $Type->{text}->{subtype}->{css} = { # RFC 2318
72    parameter => {    parameter => {
73      charset => {}, ## TODO: US-ASCII, iso-8859-X, utf-8 are recommended ## TODO: Any charset that is a superset of US-ASCII may be used ## NOTE: Syntax and range are not defined.      charset => {registered => 1}, ## TODO: US-ASCII, iso-8859-X, utf-8 are recommended ## TODO: Any charset that is a superset of US-ASCII may be used ## NOTE: Syntax and range are not defined.
74    },    },
75    registered => 1,    registered => 1,
76  };  };
77  $Type->{text}->{subtype}->{javascript} = { # RFC 4329  $Type->{text}->{subtype}->{javascript} = { # RFC 4329
78    parameter => {    parameter => {
79      charset => {syntax => 'mime-charset'}, ## TODO: SHOULD be registered      charset => {syntax => 'mime-charset', registered => 1}, ## TODO: SHOULD be registered
80      e4x => {checker => sub { # HTML5 (but informative?)      e4x => {checker => sub { # HTML5 (but informative?)
81        my ($value, $onerror) = @_;        my ($value, $onerror) = @_;
82        unless ($value eq '1') {        unless ($value eq '1') {
# Line 89  $Type->{audio}->{subtype}->{mpeg} = { # Line 100  $Type->{audio}->{subtype}->{mpeg} = { #
100  };  };
101  my $CodecsParameter = { # RFC 4281  my $CodecsParameter = { # RFC 4281
102    ## TODO: syntax and value check    ## TODO: syntax and value check
103      registered => 1,
104  };  };
105  $Type->{audio}->{subtype}->{'3gpp'} = {  $Type->{audio}->{subtype}->{'3gpp'} = {
106    parameter => {    parameter => {
# Line 119  $Type->{video}->{subtype}->{'3gpp2'} = { Line 131  $Type->{video}->{subtype}->{'3gpp2'} = {
131  };  };
132  $Type->{application}->{subtype}->{'octet-stream'} = {  $Type->{application}->{subtype}->{'octet-stream'} = {
133    parameter => {    parameter => {
134      conversions => {obsolete => 1}, # RFC 1341 ## TODO: syntax      conversions => {obsolete => 1, registered => 1}, # RFC 1341 ## TODO: syntax
135      name => {obsolete => 1}, # RFC 1341      name => {obsolete => 1, registered => 1}, # RFC 1341
136      padding => {}, # RFC 2046      padding => {registered => 1}, # RFC 2046
137      type => {}, # RFC 2046      type => {registered => 1}, # RFC 2046
138    },    },
139    registered => 1,    registered => 1,
140  };  };
# Line 146  $Type->{multipart}->{parameter}->{bounda Line 158  $Type->{multipart}->{parameter}->{bounda
158      }      }
159    },    },
160    required => 1,    required => 1,
161      registered => 1,
162  };  };
163  $Type->{message}->{subtype}->{partial} = {  $Type->{message}->{subtype}->{partial} = {
164    parameter => {    parameter => {
165      id => {required => 1}, # RFC 2046      id => {required => 1, registered => 1}, # RFC 2046
166      number => {required => 1}, # RFC 2046      number => {required => 1, registered => 1}, # RFC 2046
167      total => {}, # RFC 2046 # required for the last fragment      total => {registered => 1}, # RFC 2046 # required for the last fragment
168    },    },
169    registered => 1,    registered => 1,
170  };  };
# Line 160  $Type->{message}->{subtype}->{'external- Line 173  $Type->{message}->{subtype}->{'external-
173      'access-type' => {      'access-type' => {
174        required => 1,        required => 1,
175        syntax => 'token', ## TODO: registry?        syntax => 'token', ## TODO: registry?
176          registered => 1,
177      }, # RFC 2046      }, # RFC 2046
178      expiration => {syntax => 'MIME date-time'}, # RFC 2046      expiration => {syntax => 'MIME date-time', registered => 1}, # RFC 2046
179      permission => {}, # RFC 2046      permission => {registered => 1}, # RFC 2046
180      size => {}, # RFC 2046      size => {registered => 1}, # RFC 2046
181      ## TODO: access-type dependent parameters      ## TODO: access-type dependent parameters
182    },    },
183    registered => 1,    registered => 1,
184  };  };
185    
186    our $MUSTLevel = 'm'; ## NOTE: RFC 2119 "MUST".
187    our $StronglyDiscouragedLevel = 's'; ## NOTE: "strongly discouraged".
188    
189  sub check_imt ($$$$@) {  sub check_imt ($$$$@) {
190    my (undef, $onerror, $type, $subtype, @parameter) = @_;    my (undef, $onerror, $type, $subtype, @parameter) = @_;
191    
192    require Message::IMT::InternetMediaType; ## From manakai    require Message::IMT::InternetMediaType;
193    my $dom = 'Message::DOM::DOMImplementation'; ## ISSUE: This is not a formal way to instantiate it.    my $dom = Message::DOM::DOMImplementation->new;
194    
195    local $Error::Depth = $Error::Depth + 1;    local $Error::Depth = $Error::Depth + 1;
196    
# Line 188  sub check_imt ($$$$@) { Line 205  sub check_imt ($$$$@) {
205    my $type = $imt->top_level_type;    my $type = $imt->top_level_type;
206    my $subtype = $imt->subtype;    my $subtype = $imt->subtype;
207    
208      ## NOTE: RFC 2045 (MIME), RFC 2616 (HTTP/1.1), and RFC 4288 (IMT
209      ## registration) have different requirements on type and subtype names.
210      if ($type !~ /\A[A-Za-z0-9!#\$&.+^_-]{1,127}\z/) {
211        $onerror->(type => 'type:syntax error:'.$type, level => $MUSTLevel);
212      }
213      if ($subtype !~ /\A[A-Za-z0-9!#\$&.+^_-]{1,127}\z/) {
214        $onerror->(type => 'subtype:syntax error:'.$subtype, level => $MUSTLevel);
215      }
216    
217    my $type_def = $Type->{$type};    my $type_def = $Type->{$type};
218    my $has_param;    my $has_param;
219    
220    if ($type =~ /^x[-\.]/) { ## TODO: Is there x. tree?    if ($type =~ /^x-/) {
221      $onerror->(type => 'private type', level => 's'); ## TODO: What level?      $onerror->(type => 'private type', level => $StronglyDiscouragedLevel);
222    } elsif ($type_def and not $type_def->{registered}) {    } elsif (not $type_def or not $type_def->{registered}) {
223      $onerror->(type => 'unregistered type', level => 's'); ## TODO: What level?    #} elsif ($type_def and not $type_def->{registered}) {
224        ## NOTE: Top-level type is seldom added.
225        
226        ## NOTE: RFC 2046 6. "Any format without a rigorous and public
227        ## definition must be named with an "X-" prefix" (strictly, this
228        ## is not an author requirement, but a requirement for media
229        ## type specfication author and it does not restrict use of
230        ## unregistered value).
231        $onerror->(type => 'unregistered type', level => 'w');
232    }    }
233    
234    if ($type_def) {    if ($type_def) {
235      my $subtype_def = $type_def->{subtype}->{$subtype};      my $subtype_def = $type_def->{subtype}->{$subtype};
236    
237      if ($subtype =~ /^x[-\.]/) {      if ($subtype =~ /^x[-\.]/) {
238        $onerror->(type => 'private subtype', level => 's'); ## TODO: What level?        $onerror->(type => 'private subtype', level => 'w');
239          ## NOTE: "x." is discouraged in RFC 4288.
240      } elsif ($subtype_def and not $subtype_def->{registered}) {      } elsif ($subtype_def and not $subtype_def->{registered}) {
241        $onerror->(type => 'unregistered subtype', level => 's'); ## TODO: What level?        ## NOTE: RFC 2046 6. "Any format without a rigorous and public
242      }        ## definition must be named with an "X-" prefix" (strictly, this
243      if ($subtype_def->{obsolete}) {        ## is not an author requirement, but a requirement for media
244        $onerror->(type => 'obsolete subtype', level => 's');        ## type specfication author and it does not restrict use of
245          ## unregistered value).
246          $onerror->(type => 'unregistered subtype', level => 'w');
247      }      }
248            
249      if ($subtype_def) {      if ($subtype_def) {
250          if ($subtype_def->{obsolete}) {
251            $onerror->(type => 'obsolete subtype', level => 'w');
252          }
253    
254        for (0..$imt->parameter_length-1) {        for (0..$imt->parameter_length-1) {
255          my $attr = $imt->get_attribute ($_);          my $attr = $imt->get_attribute ($_);
256          my $value = $imt->get_value ($_);          my $value = $imt->get_value ($_);
257    
258            if ($attr !~ /\A[A-Za-z0-9!#\$&.+^_-]{1,127}\z/) {
259              $onerror->(type => 'attribute:syntax error:'.$attr,
260                         level => $MUSTLevel);
261            }
262    
263          $has_param->{$attr} = 1;          $has_param->{$attr} = 1;
264          my $param_def = $subtype_def->{parameter}->{$attr}          my $param_def = $subtype_def->{parameter}->{$attr}
265            || $type_def->{parameter}->{$attr};            || $type_def->{parameter}->{$attr};
266          if ($param_def) {          if ($param_def) {
267            if (defined $param_def->{syntax}) {            if (defined $param_def->{syntax}) {
268              if ($param_def->{syntax} eq 'mime-charset') { # RFC 2978              if ($param_def->{syntax} eq 'mime-charset') { # RFC 2978
269                  ## TODO: ...
270                if ($value =~ /[^A-Za-z0-9!#\x23%&'+^_`{}~-]/) {                if ($value =~ /[^A-Za-z0-9!#\x23%&'+^_`{}~-]/) {
271                  $onerror->(type => 'value syntax error:'.$attr, level => 'm');                  $onerror->(type => 'value syntax error:'.$attr, level => 'm');
272                }                }
273              } elsif ($param_def->{syntax} eq 'token') { # RFC 2046              } elsif ($param_def->{syntax} eq 'token') { # RFC 2046
274                  ## TODO: ...
275                if ($value =~ /[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/) {                if ($value =~ /[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/) {
276                  $onerror->(type => 'value syntax error:'.$attr, level => 'm');                  $onerror->(type => 'value syntax error:'.$attr, level => 'm');
277                }                }
# Line 232  sub check_imt ($$$$@) { Line 281  sub check_imt ($$$$@) {
281                $param_def->{checker}->($value, $onerror);                $param_def->{checker}->($value, $onerror);
282              }              }
283              if ($param_def->{obsolete}) {              if ($param_def->{obsolete}) {
284                  ## TODO: error level
285                $onerror->(type => 'obsolete parameter:'.$attr, level => 'm');                $onerror->(type => 'obsolete parameter:'.$attr, level => 'm');
286              }              }
287            }            }
288          } else {          }
289            $onerror->(type => 'parameter:'.$attr, level => 'unsupported');          if (not $param_def or not $param_def->{registered}) {
290              if ($subtype =~ /\./ or $subtype =~ /^x-/ or $type =~ /^x-/) {
291                ## NOTE: The parameter names SHOULD be fully specified for
292                ## personal or vendor tree subtype [RFC 4288].  Therefore, there
293                ## might be unknown parameters and still conforming.
294                $onerror->(type => 'parameter:'.$attr, level => 'unsupported');
295              } else {
296                ## NOTE: The parameter names MUST be fully specified for
297                ## standard tree.  Therefore, unknown parameter is non-conforming,
298                ## unless it is standardized later.
299                $onerror->(type => 'parameter not allowed:'.$attr,
300                           level => $MUSTLevel);
301              }
302          }          }
303        }        }
304    
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24