Message/DOM/DOMConfiguration.pm

package Message::DOM::DOMConfiguration;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
push our @ISA, 'Message::IF::DOMConfiguration';
require Message::DOM::DOMException;

use overload
    '%{}' => sub {
      tie my %list, ref $_[0], $_[0];
      return \%list;
    },
    eq => sub {
      return 0 unless UNIVERSAL::isa ($_[1], 'Message::DOM::DOMConfiguration');
      return $${$_[0]} eq $${$_[1]};
    },
    ne => sub {
      return not ($_[0] eq $_[1]);
    },
    fallback => 1;

sub ___report_error ($$) {
  $_[1]->throw;
} # ___report_error

sub TIEHASH ($$) { $_[1] }

## TODO: Define Perl binding

## |DOMConfiguration| attribute

my %names = (
             'error-handler' => 1,
             'schema-type' => 1,
             q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
             q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
             q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
             q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
             q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
             q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
);

sub parameter_names ($) {
  require Message::DOM::DOMStringList;
  return bless [sort {$a cmp $b} keys %names],
      'Message::DOM::DOMStringList::StaticList';
} # parameter_names

## |DOMConfiguration| methods

sub can_set_parameter ($$;$) {
  my $name = ''.$_[1];
  if ({
       q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
      }->{$name}) {
    return 1;
  } elsif ($name eq 'error-handler') {
    return 1 unless defined $_[2];
    return ref $_[2] eq 'CODE';
  } elsif ($name eq 'schema-type') {
    return 1 unless defined $_[2];
    return 1 if ''.$_[2] eq q<http://www.w3.org/TR/REC-xml>;
    return 0;
  } else {
    return 0;
  }
} # can_set_parameter

sub get_parameter ($$) {
  my $name = ''.$_[1];
  if ({
       'schema-type' => 1,
       q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
       q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
       'error-handler' => 1,
      }->{$name}) {
    return ${$${$_[0]}}->{$name};    
  } else {
    report Message::DOM::DOMException
        -object => $_[0],
        -type => 'NOT_FOUND_ERR',
        -subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
  }
} # get_parameter
*FETCH = \&get_parameter;

## TODO: Should we allow $cfg->{error_handler}?

sub set_parameter ($$;$) {
  my $name = ''.$_[1];
  if (defined $_[2]) {
    if ({
         q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
         q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
         q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
         q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
         q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
         q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
        }->{$name}) {
      if ($_[2]) {
        ${$${$_[0]}}->{$name} = 1;
      } else {
        delete ${$${$_[0]}}->{$name};
      }
    } elsif ($name eq 'error-handler') {
      if (ref $_[2] eq 'CODE') {
        ${$${$_[0]}}->{$name} = $_[2];
      } else {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'TYPE_MISMATCH_ERR',
            -subtype => 'CONFIGURATION_PARAMETER_TYPE_ERR';
      }
    } elsif ($name eq 'schema-type') {
      my $value = ''.$_[2];
      if ($value eq q<http://www.w3.org/TR/REC-xml>) {
        ${$${$_[0]}}->{$name} = ''.$_[2];
      } else {
        report Message::DOM::DOMException
            -object => $_[0],
            -type => 'NOT_SUPPORTED_ERR',
            -subtype => 'CONFIGURATION_PARAMETER_VALUE_ERR';
      }
    } else {
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'NOT_FOUND_ERR',
          -subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
    }
  } else { # reset
    if ({
         q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
         q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
         q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
         q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
         q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
        }->{$name}) {
      ${$${$_[0]}}->{$name} = 1;
    } elsif ({
              'schema-type' => 1,
              q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
        }->{$name}) {
      delete ${$${$_[0]}}->{$name};
    } elsif ($_[1] eq 'error-handler') {
      ${$${$_[0]}}->{$name} = sub ($) {
        ## NOTE: Same as one set by |Document| constructor.
        warn $_[0];
        return $_[0]->severity != 3; # SEVERITY_FATAL_ERROR
      };
    } else {
      report Message::DOM::DOMException
          -object => $_[0],
          -type => 'NOT_FOUND_ERR',
          -subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
    }
  }
  return undef;
} # set_parameter
*STORE = \&set_parameter;

sub DELETE ($$) {
  local $Error::Depth = $Error::Depth + 1;
  $_[0]->set_parameter ($_[1] => undef);
} # DELETE

sub EXISTS ($$) { exists $names{$_[1]} }

sub FIRSTKEY ($) {
  my $a = keys %names;
  return each %names;
} # FIRSTKEY
              
sub NEXTKEY ($) {
  return each %names;
} # NEXTKEY

package Message::IF::DOMConfiguration;

=head1 LICENSE

Copyright 2007 Wakaba <w@suika.fam.cx>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1;
## $Date: 2007/07/14 16:32:28 $
1	package Message::DOM::DOMConfiguration;
2	use strict;
3	our $VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	push our @ISA, 'Message::IF::DOMConfiguration';
5	require Message::DOM::DOMException;
6
7	use overload
8	'%{}' => sub {
9	tie my %list, ref $_[0], $_[0];
10	return \%list;
11	},
12	eq => sub {
13	return 0 unless UNIVERSAL::isa ($_[1], 'Message::DOM::DOMConfiguration');
14	return $${$_[0]} eq $${$_[1]};
15	},
16	ne => sub {
17	return not ($_[0] eq $_[1]);
18	},
19	fallback => 1;
20
21	sub ___report_error ($$) {
22	$_[1]->throw;
23	} # ___report_error
24
25	sub TIEHASH ($$) { $_[1] }
26
27	## TODO: Define Perl binding
28
29	## \|DOMConfiguration\| attribute
30
31	my %names = (
32	'error-handler' => 1,
33	'schema-type' => 1,
34	q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
35	q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
36	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
37	q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
38	q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
39	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
40	);
41
42	sub parameter_names ($) {
43	require Message::DOM::DOMStringList;
44	return bless [sort {$a cmp $b} keys %names],
45	'Message::DOM::DOMStringList::StaticList';
46	} # parameter_names
47
48	## \|DOMConfiguration\| methods
49
50	sub can_set_parameter ($$;$) {
51	my $name = ''.$_[1];
52	if ({
53	q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
54	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
55	q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
56	q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
57	q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
58	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
59	}->{$name}) {
60	return 1;
61	} elsif ($name eq 'error-handler') {
62	return 1 unless defined $_[2];
63	return ref $_[2] eq 'CODE';
64	} elsif ($name eq 'schema-type') {
65	return 1 unless defined $_[2];
66	return 1 if ''.$_[2] eq q<http://www.w3.org/TR/REC-xml>;
67	return 0;
68	} else {
69	return 0;
70	}
71	} # can_set_parameter
72
73	sub get_parameter ($$) {
74	my $name = ''.$_[1];
75	if ({
76	'schema-type' => 1,
77	q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
78	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
79	q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
80	q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
81	q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
82	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
83	'error-handler' => 1,
84	}->{$name}) {
85	return ${$${$_[0]}}->{$name};
86	} else {
87	report Message::DOM::DOMException
88	-object => $_[0],
89	-type => 'NOT_FOUND_ERR',
90	-subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
91	}
92	} # get_parameter
93	*FETCH = \&get_parameter;
94
95	## TODO: Should we allow $cfg->{error_handler}?
96
97	sub set_parameter ($$;$) {
98	my $name = ''.$_[1];
99	if (defined $_[2]) {
100	if ({
101	q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
102	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
103	q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
104	q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
105	q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
106	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
107	}->{$name}) {
108	if ($_[2]) {
109	${$${$_[0]}}->{$name} = 1;
110	} else {
111	delete ${$${$_[0]}}->{$name};
112	}
113	} elsif ($name eq 'error-handler') {
114	if (ref $_[2] eq 'CODE') {
115	${$${$_[0]}}->{$name} = $_[2];
116	} else {
117	report Message::DOM::DOMException
118	-object => $_[0],
119	-type => 'TYPE_MISMATCH_ERR',
120	-subtype => 'CONFIGURATION_PARAMETER_TYPE_ERR';
121	}
122	} elsif ($name eq 'schema-type') {
123	my $value = ''.$_[2];
124	if ($value eq q<http://www.w3.org/TR/REC-xml>) {
125	${$${$_[0]}}->{$name} = ''.$_[2];
126	} else {
127	report Message::DOM::DOMException
128	-object => $_[0],
129	-type => 'NOT_SUPPORTED_ERR',
130	-subtype => 'CONFIGURATION_PARAMETER_VALUE_ERR';
131	}
132	} else {
133	report Message::DOM::DOMException
134	-object => $_[0],
135	-type => 'NOT_FOUND_ERR',
136	-subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
137	}
138	} else { # reset
139	if ({
140	q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
141	q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
142	q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
143	q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
144	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
145	}->{$name}) {
146	${$${$_[0]}}->{$name} = 1;
147	} elsif ({
148	'schema-type' => 1,
149	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
150	}->{$name}) {
151	delete ${$${$_[0]}}->{$name};
152	} elsif ($_[1] eq 'error-handler') {
153	${$${$_[0]}}->{$name} = sub ($) {
154	## NOTE: Same as one set by \|Document\| constructor.
155	warn $_[0];
156	return $_[0]->severity != 3; # SEVERITY_FATAL_ERROR
157	};
158	} else {
159	report Message::DOM::DOMException
160	-object => $_[0],
161	-type => 'NOT_FOUND_ERR',
162	-subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
163	}
164	}
165	return undef;
166	} # set_parameter
167	*STORE = \&set_parameter;
168
169	sub DELETE ($$) {
170	local $Error::Depth = $Error::Depth + 1;
171	$_[0]->set_parameter ($_[1] => undef);
172	} # DELETE
173
174	sub EXISTS ($$) { exists $names{$_[1]} }
175
176	sub FIRSTKEY ($) {
177	my $a = keys %names;
178	return each %names;
179	} # FIRSTKEY
180
181	sub NEXTKEY ($) {
182	return each %names;
183	} # NEXTKEY
184
185	package Message::IF::DOMConfiguration;
186
187	=head1 LICENSE
188
189	Copyright 2007 Wakaba <w@suika.fam.cx>
190
191	This program is free software; you can redistribute it and/or
192	modify it under the same terms as Perl itself.
193
194	=cut
195
196	1;
197	## $Date: 2007/07/14 16:32:28 $