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	wakaba	1.1	package Message::DOM::DOMConfiguration;
2			use strict;
3	wakaba	1.7	our $VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	wakaba	1.1	push our @ISA, 'Message::IF::DOMConfiguration';
5			require Message::DOM::DOMException;
6
7			use overload
8	wakaba	1.4	'%{}' => sub {
9			tie my %list, ref $_[0], $_[0];
10			return \%list;
11			},
12	wakaba	1.1	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	wakaba	1.4	sub TIEHASH ($$) { $_[1] }
26
27			## TODO: Define Perl binding
28
29			## \|DOMConfiguration\| attribute
30
31			my %names = (
32			'error-handler' => 1,
33	wakaba	1.5	'schema-type' => 1,
34	wakaba	1.4	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	wakaba	1.7	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
37	wakaba	1.4	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	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
40	wakaba	1.4	);
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	wakaba	1.1	## \|DOMConfiguration\| methods
49
50	wakaba	1.4	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	wakaba	1.7	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
55	wakaba	1.4	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	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
59	wakaba	1.4	}->{$name}) {
60			return 1;
61			} elsif ($name eq 'error-handler') {
62			return 1 unless defined $_[2];
63			return ref $_[2] eq 'CODE';
64	wakaba	1.6	} 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	wakaba	1.4	} else {
69			return 0;
70			}
71			} # can_set_parameter
72
73	wakaba	1.3	sub get_parameter ($$) {
74	wakaba	1.4	my $name = ''.$_[1];
75			if ({
76	wakaba	1.5	'schema-type' => 1,
77	wakaba	1.4	q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
78	wakaba	1.7	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
79	wakaba	1.4	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	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
83	wakaba	1.4	'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	wakaba	1.3	} # get_parameter
93	wakaba	1.4	*FETCH = \&get_parameter;
94
95			## TODO: Should we allow $cfg->{error_handler}?
96	wakaba	1.3
97	wakaba	1.1	sub set_parameter ($$;$) {
98	wakaba	1.4	my $name = ''.$_[1];
99	wakaba	1.2	if (defined $_[2]) {
100	wakaba	1.4	if ({
101			q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
102	wakaba	1.7	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
103	wakaba	1.4	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	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
107	wakaba	1.4	}->{$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	wakaba	1.5	} elsif ($name eq 'schema-type') {
123	wakaba	1.6	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	wakaba	1.4	} else {
133			report Message::DOM::DOMException
134			-object => $_[0],
135			-type => 'NOT_FOUND_ERR',
136			-subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
137			}
138	wakaba	1.5	} else { # reset
139	wakaba	1.4	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	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
145	wakaba	1.4	}->{$name}) {
146			${$${$_[0]}}->{$name} = 1;
147	wakaba	1.5	} elsif ({
148			'schema-type' => 1,
149	wakaba	1.7	q<http://suika.fam.cx/www/2006/dom-config/create-child-element> => 1,
150	wakaba	1.5	}->{$name}) {
151			delete ${$${$_[0]}}->{$name};
152	wakaba	1.2	} elsif ($_[1] eq 'error-handler') {
153	wakaba	1.4	${$${$_[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	wakaba	1.2	} else {
159	wakaba	1.4	report Message::DOM::DOMException
160			-object => $_[0],
161			-type => 'NOT_FOUND_ERR',
162			-subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
163	wakaba	1.2	}
164			}
165	wakaba	1.4	return undef;
166	wakaba	1.1	} # set_parameter
167	wakaba	1.4	*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	wakaba	1.1
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	wakaba	1.7	## $Date: 2007/07/14 16:32:28 $