whatpm/Whatpm/IMTChecker.pm

package Whatpm::IMTChecker;
use strict;

## ISSUE: RFC 2046 is so poorly written specification that
## what we should do is unclear...  It's even worse than
## RFC 1521, which contains BNF rules for parameter values.

our $Type;
$Type->{text}->{subtype}->{plain} = {
  parameter => {
    charset => {syntax => 'token'}, # RFC 2046 ## TODO: registered?
    'charset-edition' => {}, # RFC 1922
    'charset-extension' => {syntax => 'token'}, # RFC 1922 ## TODO: registered?
  },
};
$Type->{text}->{subtype}->{html} = { # RFC 2854
  parameter => {
    charset => {}, ## TODO: UTF-8 is preferred ## TODO: strongly recommended that it always be present ## NOTE: Syntax and range are not defined.
    level => {obsolete =>1}, # RFC 1866
    version => {obsolete => 1}, # HTML 3.0
  },
};
$Type->{text}->{subtype}->{css} = { # RFC 2318
  parameter => {
    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.
  },
};
$Type->{text}->{subtype}->{javascript} = { # RFC 4329
  parameter => {
    charset => {syntax => 'mime-charset'}, ## TODO: SHOULD be registered
    e4x => {checker => sub { # HTML5 (but informative?)
      my ($value, $onerror) = @_;
      unless ($value eq '1') {
        $onerror->(type => 'value syntax error:e4x', level => 'm');
      }
    }},
  },
  obsolete => 1,
};
$Type->{text}->{subtype}->{ecmascript} = { # RFC 4329
  parameter => {
    charset => $Type->{text}->{subtype}->{javascript}->{parameter}->{charset},
  },
};
$Type->{audio}->{subtype}->{mpeg} = { # RFC 3003
};
my $CodecsParameter = { # RFC 4281
  ## TODO: syntax and value check
};
$Type->{audio}->{subtype}->{'3gpp'} = {
  parameter => {
    codecs => $CodecsParameter, # RFC 4281
  },
};
$Type->{video}->{subtype}->{'3gpp'} = {
  parameter => {
    codecs => $CodecsParameter, # RFC 4281
  },
};
$Type->{audio}->{subtype}->{'3gpp2'} = { # RFC 4393
  parameter => {
    codecs => $CodecsParameter, # RFC 4393 -> RFC 4281
  },
};
$Type->{video}->{subtype}->{'3gpp2'} = { # RFC 4393
  parameter => {
    codecs => $CodecsParameter, # RFC 4393 -> RFC 4281
  },
};
$Type->{application}->{subtype}->{'octet-stream'} = {
  parameter => {
    conversions => {obsolete => 1}, # RFC 1341 ## TODO: syntax
    name => {obsolete => 1}, # RFC 1341
    padding => {}, # RFC 2046
    type => {}, # RFC 2046
  },
};
$Type->{application}->{subtype}->{javascript} = { # RFC 4329
  parameter => {
    charset => $Type->{text}->{subtype}->{javascript}->{parameter}->{charset},
  },
};
$Type->{application}->{subtype}->{ecmascript} = { # RFC 4329
  parameter => {
    charset => $Type->{text}->{subtype}->{ecmascript}->{parameter}->{charset},
  },
};
$Type->{multipart}->{parameter}->{boundary} = {
  checker => sub {
    my ($value, $onerror) = @_;
    if ($value !~ /\A[0-9A-Za-z'()+_,.\x2F:=?-]{0,69}[0-9A-Za-z'()+_,.\x2F:=?\x20-]\z/) {
      $onerror->(type => 'value syntax error:boundary', level => 'm');
    }
  },
  required => 1,
};
$Type->{message}->{subtype}->{partial} = {
  parameter => {
    id => {required => 1}, # RFC 2046
    number => {required => 1}, # RFC 2046
    total => {}, # RFC 2046 # required for the last fragment
  },
};
$Type->{message}->{subtype}->{'external-body'} = {
  parameter => {
    'access-type' => {
      required => 1,
      syntax => 'token', ## TODO: registry?
    }, # RFC 2046
    expiration => {syntax => 'MIME date-time'}, # RFC 2046
    permission => {}, # RFC 2046
    size => {}, # RFC 2046
    ## TODO: access-type dependent parameters
  },
};

sub check_imt ($$$$@) {
  my (undef, $onerror, $type, $subtype, @parameter) = @_;

  require Message::IMT::InternetMediaType; ## From manakai
  my $dom = 'Message::DOM::DOMImplementation'; ## ISSUE: This is not a formal way to instantiate it.

  local $Error::Depth = $Error::Depth + 1;

  my $imt = $dom->create_internet_media_type ($type, $subtype);
  while (@parameter) {
    $imt->add_parameter (shift @parameter => shift @parameter);
    ## NOTE: Attribute duplication are not error, though its semantics
    ## is not defined.
    ## See <http://suika.fam.cx/gate/2005/sw/%E5%AA%92%E4%BD%93%E5%9E%8B/%E5%BC%95%E6%95%B0>.
  }

  my $type = $imt->top_level_type;
  my $subtype = $imt->subtype;

  my $type_def = $Type->{$type};
  my $has_param;
  if ($type_def) {
    my $subtype_def = $type_def->{subtype}->{$subtype};
    if ($subtype_def) {
      for (0..$imt->parameter_length-1) {
        my $attr = $imt->get_attribute ($_);
        my $value = $imt->get_value ($_);
        $has_param->{$attr} = 1;
        my $param_def = $subtype_def->{parameter}->{$attr}
          || $type_def->{parameter}->{$attr};
        if ($param_def) {
          if (defined $param_def->{syntax}) {
            if ($param_def->{syntax} eq 'mime-charset') { # RFC 2978
              if ($value =~ /[^A-Za-z0-9!#\x23%&'+^_`{}~-]/) {
                $onerror->(type => 'value syntax error:'.$attr, level => 'm');
              }
            } elsif ($param_def->{syntax} eq 'token') { # RFC 2046
              if ($value =~ /[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/) {
                $onerror->(type => 'value syntax error:'.$attr, level => 'm');
              }
            }
            ## TODO: syntax |MIME date-time|
            if ($param_def->{checker}) {
              $param_def->{checker}->($value, $onerror);
            }
            if ($param_def->{obsolete}) {
              $onerror->(type => 'obsolete parameter:'.$attr, level => 'm');
            }
          }
        } else {
          $onerror->(type => 'parameter not supported:'.$attr, level => 'w');
        }
      }

      for (keys %{$subtype_def->{parameter} or {}}) {
        if ($subtype_def->{parameter}->{$_}->{required} and
            not $has_param->{$_}) {
          $onerror->(type => 'parameter missing:'.$_, level => 'm');
        }
      }
        
      if ($subtype_def->{obsolete}) {
        $onerror->(type => 'obsolete subtype', level => 's');
      }
    } else {
      $onerror->(type => 'subtype not supported', level => 'w');
    }

    for (keys %{$type_def->{parameter} or {}}) {
      if ($type_def->{parameter}->{$_}->{required} and
          not $has_param->{$_}) {
        $onerror->(type => 'parameter missing:'.$_, level => 'm');
      }
    }
  } else {
    $onerror->(type => 'type not supported', level => 'w');
  }
  ## TODO: registered? 
} # check_imt

1;
## $Date: 2007/05/25 14:16:29 $
1	package Whatpm::IMTChecker;
2	use strict;
3
4	## ISSUE: RFC 2046 is so poorly written specification that
5	## what we should do is unclear... It's even worse than
6	## RFC 1521, which contains BNF rules for parameter values.
7
8	our $Type;
9	$Type->{text}->{subtype}->{plain} = {
10	parameter => {
11	charset => {syntax => 'token'}, # RFC 2046 ## TODO: registered?
12	'charset-edition' => {}, # RFC 1922
13	'charset-extension' => {syntax => 'token'}, # RFC 1922 ## TODO: registered?
14	},
15	};
16	$Type->{text}->{subtype}->{html} = { # RFC 2854
17	parameter => {
18	charset => {}, ## TODO: UTF-8 is preferred ## TODO: strongly recommended that it always be present ## NOTE: Syntax and range are not defined.
19	level => {obsolete =>1}, # RFC 1866
20	version => {obsolete => 1}, # HTML 3.0
21	},
22	};
23	$Type->{text}->{subtype}->{css} = { # RFC 2318
24	parameter => {
25	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.
26	},
27	};
28	$Type->{text}->{subtype}->{javascript} = { # RFC 4329
29	parameter => {
30	charset => {syntax => 'mime-charset'}, ## TODO: SHOULD be registered
31	e4x => {checker => sub { # HTML5 (but informative?)
32	my ($value, $onerror) = @_;
33	unless ($value eq '1') {
34	$onerror->(type => 'value syntax error:e4x', level => 'm');
35	}
36	}},
37	},
38	obsolete => 1,
39	};
40	$Type->{text}->{subtype}->{ecmascript} = { # RFC 4329
41	parameter => {
42	charset => $Type->{text}->{subtype}->{javascript}->{parameter}->{charset},
43	},
44	};
45	$Type->{audio}->{subtype}->{mpeg} = { # RFC 3003
46	};
47	my $CodecsParameter = { # RFC 4281
48	## TODO: syntax and value check
49	};
50	$Type->{audio}->{subtype}->{'3gpp'} = {
51	parameter => {
52	codecs => $CodecsParameter, # RFC 4281
53	},
54	};
55	$Type->{video}->{subtype}->{'3gpp'} = {
56	parameter => {
57	codecs => $CodecsParameter, # RFC 4281
58	},
59	};
60	$Type->{audio}->{subtype}->{'3gpp2'} = { # RFC 4393
61	parameter => {
62	codecs => $CodecsParameter, # RFC 4393 -> RFC 4281
63	},
64	};
65	$Type->{video}->{subtype}->{'3gpp2'} = { # RFC 4393
66	parameter => {
67	codecs => $CodecsParameter, # RFC 4393 -> RFC 4281
68	},
69	};
70	$Type->{application}->{subtype}->{'octet-stream'} = {
71	parameter => {
72	conversions => {obsolete => 1}, # RFC 1341 ## TODO: syntax
73	name => {obsolete => 1}, # RFC 1341
74	padding => {}, # RFC 2046
75	type => {}, # RFC 2046
76	},
77	};
78	$Type->{application}->{subtype}->{javascript} = { # RFC 4329
79	parameter => {
80	charset => $Type->{text}->{subtype}->{javascript}->{parameter}->{charset},
81	},
82	};
83	$Type->{application}->{subtype}->{ecmascript} = { # RFC 4329
84	parameter => {
85	charset => $Type->{text}->{subtype}->{ecmascript}->{parameter}->{charset},
86	},
87	};
88	$Type->{multipart}->{parameter}->{boundary} = {
89	checker => sub {
90	my ($value, $onerror) = @_;
91	if ($value !~ /\A[0-9A-Za-z'()+_,.\x2F:=?-]{0,69}[0-9A-Za-z'()+_,.\x2F:=?\x20-]\z/) {
92	$onerror->(type => 'value syntax error:boundary', level => 'm');
93	}
94	},
95	required => 1,
96	};
97	$Type->{message}->{subtype}->{partial} = {
98	parameter => {
99	id => {required => 1}, # RFC 2046
100	number => {required => 1}, # RFC 2046
101	total => {}, # RFC 2046 # required for the last fragment
102	},
103	};
104	$Type->{message}->{subtype}->{'external-body'} = {
105	parameter => {
106	'access-type' => {
107	required => 1,
108	syntax => 'token', ## TODO: registry?
109	}, # RFC 2046
110	expiration => {syntax => 'MIME date-time'}, # RFC 2046
111	permission => {}, # RFC 2046
112	size => {}, # RFC 2046
113	## TODO: access-type dependent parameters
114	},
115	};
116
117	sub check_imt ($$$$@) {
118	my (undef, $onerror, $type, $subtype, @parameter) = @_;
119
120	require Message::IMT::InternetMediaType; ## From manakai
121	my $dom = 'Message::DOM::DOMImplementation'; ## ISSUE: This is not a formal way to instantiate it.
122
123	local $Error::Depth = $Error::Depth + 1;
124
125	my $imt = $dom->create_internet_media_type ($type, $subtype);
126	while (@parameter) {
127	$imt->add_parameter (shift @parameter => shift @parameter);
128	## NOTE: Attribute duplication are not error, though its semantics
129	## is not defined.
130	## See <http://suika.fam.cx/gate/2005/sw/%E5%AA%92%E4%BD%93%E5%9E%8B/%E5%BC%95%E6%95%B0>.
131	}
132
133	my $type = $imt->top_level_type;
134	my $subtype = $imt->subtype;
135
136	my $type_def = $Type->{$type};
137	my $has_param;
138	if ($type_def) {
139	my $subtype_def = $type_def->{subtype}->{$subtype};
140	if ($subtype_def) {
141	for (0..$imt->parameter_length-1) {
142	my $attr = $imt->get_attribute ($_);
143	my $value = $imt->get_value ($_);
144	$has_param->{$attr} = 1;
145	my $param_def = $subtype_def->{parameter}->{$attr}
146	\|\| $type_def->{parameter}->{$attr};
147	if ($param_def) {
148	if (defined $param_def->{syntax}) {
149	if ($param_def->{syntax} eq 'mime-charset') { # RFC 2978
150	if ($value =~ /[^A-Za-z0-9!#\x23%&'+^_`{}~-]/) {
151	$onerror->(type => 'value syntax error:'.$attr, level => 'm');
152	}
153	} elsif ($param_def->{syntax} eq 'token') { # RFC 2046
154	if ($value =~ /[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/) {
155	$onerror->(type => 'value syntax error:'.$attr, level => 'm');
156	}
157	}
158	## TODO: syntax \|MIME date-time\|
159	if ($param_def->{checker}) {
160	$param_def->{checker}->($value, $onerror);
161	}
162	if ($param_def->{obsolete}) {
163	$onerror->(type => 'obsolete parameter:'.$attr, level => 'm');
164	}
165	}
166	} else {
167	$onerror->(type => 'parameter not supported:'.$attr, level => 'w');
168	}
169	}
170
171	for (keys %{$subtype_def->{parameter} or {}}) {
172	if ($subtype_def->{parameter}->{$_}->{required} and
173	not $has_param->{$_}) {
174	$onerror->(type => 'parameter missing:'.$_, level => 'm');
175	}
176	}
177
178	if ($subtype_def->{obsolete}) {
179	$onerror->(type => 'obsolete subtype', level => 's');
180	}
181	} else {
182	$onerror->(type => 'subtype not supported', level => 'w');
183	}
184
185	for (keys %{$type_def->{parameter} or {}}) {
186	if ($type_def->{parameter}->{$_}->{required} and
187	not $has_param->{$_}) {
188	$onerror->(type => 'parameter missing:'.$_, level => 'm');
189	}
190	}
191	} else {
192	$onerror->(type => 'type not supported', level => 'w');
193	}
194	## TODO: registered?
195	} # check_imt
196
197	1;
198	## $Date: 2007/05/25 14:16:29 $