Message/DOM/DOMConfiguration.pm

package Message::DOM::DOMConfiguration;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.4 $=~/\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/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 ({
       '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/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';
  } 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/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/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') {
      ${$${$_[0]}}->{$name} = ''.$_[2];
    } 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,
        }->{$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 09:19:11 $
1	wakaba	1.1	package Message::DOM::DOMConfiguration;
2			use strict;
3	wakaba	1.5	our $VERSION=do{my @r=(q$Revision: 1.4 $=~/\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			q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
37			q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
38	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
39	wakaba	1.4	);
40
41			sub parameter_names ($) {
42			require Message::DOM::DOMStringList;
43			return bless [sort {$a cmp $b} keys %names],
44			'Message::DOM::DOMStringList::StaticList';
45			} # parameter_names
46
47	wakaba	1.1	## \|DOMConfiguration\| methods
48
49	wakaba	1.4	sub can_set_parameter ($$;$) {
50			my $name = ''.$_[1];
51			if ({
52	wakaba	1.5	'schema-type' => 1,
53	wakaba	1.4	q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
54			q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
55			q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
56			q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
57	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
58	wakaba	1.4	}->{$name}) {
59			return 1;
60			} elsif ($name eq 'error-handler') {
61			return 1 unless defined $_[2];
62			return ref $_[2] eq 'CODE';
63			} else {
64			return 0;
65			}
66			} # can_set_parameter
67
68	wakaba	1.3	sub get_parameter ($$) {
69	wakaba	1.4	my $name = ''.$_[1];
70			if ({
71	wakaba	1.5	'schema-type' => 1,
72	wakaba	1.4	q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
73			q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
74			q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
75			q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
76	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
77	wakaba	1.4	'error-handler' => 1,
78			}->{$name}) {
79			return ${$${$_[0]}}->{$name};
80			} else {
81			report Message::DOM::DOMException
82			-object => $_[0],
83			-type => 'NOT_FOUND_ERR',
84			-subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
85			}
86	wakaba	1.3	} # get_parameter
87	wakaba	1.4	*FETCH = \&get_parameter;
88
89			## TODO: Should we allow $cfg->{error_handler}?
90	wakaba	1.3
91	wakaba	1.1	sub set_parameter ($$;$) {
92	wakaba	1.4	my $name = ''.$_[1];
93	wakaba	1.2	if (defined $_[2]) {
94	wakaba	1.4	if ({
95			q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
96			q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
97			q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
98			q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
99	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
100	wakaba	1.4	}->{$name}) {
101			if ($_[2]) {
102			${$${$_[0]}}->{$name} = 1;
103			} else {
104			delete ${$${$_[0]}}->{$name};
105			}
106			} elsif ($name eq 'error-handler') {
107			if (ref $_[2] eq 'CODE') {
108			${$${$_[0]}}->{$name} = $_[2];
109			} else {
110			report Message::DOM::DOMException
111			-object => $_[0],
112			-type => 'TYPE_MISMATCH_ERR',
113			-subtype => 'CONFIGURATION_PARAMETER_TYPE_ERR';
114			}
115	wakaba	1.5	} elsif ($name eq 'schema-type') {
116			${$${$_[0]}}->{$name} = ''.$_[2];
117	wakaba	1.4	} else {
118			report Message::DOM::DOMException
119			-object => $_[0],
120			-type => 'NOT_FOUND_ERR',
121			-subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
122			}
123	wakaba	1.5	} else { # reset
124	wakaba	1.4	if ({
125			q<http://suika.fam.cx/www/2006/dom-config/clone-entity-reference-subtree> => 1,
126			q<http://suika.fam.cx/www/2006/dom-config/dtd-attribute-type> => 1,
127			q<http://suika.fam.cx/www/2006/dom-config/dtd-default-attribute> => 1,
128			q<http://suika.fam.cx/www/2006/dom-config/strict-document-children> => 1,
129	wakaba	1.5	q<http://suika.fam.cx/www/2006/dom-config/xml-id> => 1,
130	wakaba	1.4	}->{$name}) {
131			${$${$_[0]}}->{$name} = 1;
132	wakaba	1.5	} elsif ({
133			'schema-type' => 1,
134			}->{$name}) {
135			delete ${$${$_[0]}}->{$name};
136	wakaba	1.2	} elsif ($_[1] eq 'error-handler') {
137	wakaba	1.4	${$${$_[0]}}->{$name} = sub ($) {
138			## NOTE: Same as one set by \|Document\| constructor.
139			warn $_[0];
140			return $_[0]->severity != 3; # SEVERITY_FATAL_ERROR
141			};
142	wakaba	1.2	} else {
143	wakaba	1.4	report Message::DOM::DOMException
144			-object => $_[0],
145			-type => 'NOT_FOUND_ERR',
146			-subtype => 'UNRECOGNIZED_CONFIGURATION_PARAMETER_ERR';
147	wakaba	1.2	}
148			}
149	wakaba	1.4	return undef;
150	wakaba	1.1	} # set_parameter
151	wakaba	1.4	*STORE = \&set_parameter;
152
153			sub DELETE ($$) {
154			local $Error::Depth = $Error::Depth + 1;
155			$_[0]->set_parameter ($_[1] => undef);
156			} # DELETE
157
158			sub EXISTS ($$) { exists $names{$_[1]} }
159
160			sub FIRSTKEY ($) {
161			my $a = keys %names;
162			return each %names;
163			} # FIRSTKEY
164
165			sub NEXTKEY ($) {
166			return each %names;
167			} # NEXTKEY
168	wakaba	1.1
169			package Message::IF::DOMConfiguration;
170
171			=head1 LICENSE
172
173			Copyright 2007 Wakaba <w@suika.fam.cx>
174
175			This program is free software; you can redistribute it and/or
176			modify it under the same terms as Perl itself.
177
178			=cut
179
180			1;
181	wakaba	1.5	## $Date: 2007/07/14 09:19:11 $