|
0
|
1 package IMPL::Serialization::XmlObjectWriter;
|
|
|
2 use strict;
|
|
|
3
|
|
|
4 use base qw(IMPL::Object);
|
|
|
5 use IMPL::Class::Property;
|
|
|
6 use IMPL::Class::Property::Direct;
|
|
|
7
|
|
|
8 use IMPL::Serialization;
|
|
|
9 use XML::Writer;
|
|
|
10 use IMPL::Exception;
|
|
|
11
|
|
|
12 sub CONTAINER_EMPTY () { 1 }
|
|
|
13 sub CONTAINER_NORMAL () { 2 }
|
|
|
14
|
|
|
15 BEGIN {
|
|
|
16 public _direct property Encoding => prop_all;
|
|
|
17 public _direct property hOutput => prop_all;
|
|
|
18 public _direct property IdentOutput => prop_all;
|
|
|
19
|
|
|
20 private _direct property CurrentObject => prop_all;
|
|
|
21 private _direct property ObjectPath => prop_all;
|
|
|
22 private _direct property XmlWriter => prop_all;
|
|
|
23 private _direct property IdentLevel => prop_all;
|
|
|
24 private _direct property IdentNextTag => prop_all;
|
|
|
25 }
|
|
|
26
|
|
|
27 sub new {
|
|
|
28 my $class = shift;
|
|
|
29 my $self = bless {}, ref($class) || $class;
|
|
|
30 $self->CTOR(@_);
|
|
|
31 return $self;
|
|
|
32 }
|
|
|
33
|
|
|
34 sub CTOR {
|
|
|
35 my $this = shift;
|
|
|
36 my %args = @_;
|
|
|
37 $this->{$hOutput} = $args{'hOutput'};
|
|
|
38 $this->{$Encoding} = $args{'Encoding'};
|
|
|
39 $this->{$CurrentObject} = undef;
|
|
|
40 $this->{$IdentOutput} = $args{'IdentOutput'};
|
|
|
41 $this->{$IdentLevel} = 0;
|
|
|
42 $this->{$IdentNextTag} = 0;
|
|
|
43 #$this->{$ObjectPath} = [];
|
|
|
44 return 1;
|
|
|
45 }
|
|
|
46
|
|
|
47 sub BeginObject {
|
|
|
48 my $this = shift;
|
|
|
49 my %args = @_;
|
|
|
50
|
|
|
51 if (not $this->{$CurrentObject}) {
|
|
|
52 my $xmlWriter = new XML::Writer(OUTPUT => $this->{$hOutput}, ENCODING => $this->{$Encoding});
|
|
|
53 $this->{$XmlWriter} = $xmlWriter;
|
|
|
54 $xmlWriter->xmlDecl();
|
|
|
55 }
|
|
|
56
|
|
|
57 push @{$this->{$ObjectPath}},$this->{$CurrentObject} if $this->{$CurrentObject};
|
|
|
58
|
|
|
59 my %ObjectProperties = %args;
|
|
|
60 delete $ObjectProperties{'name'};
|
|
|
61 delete $args{'container_type'};
|
|
|
62
|
|
|
63 $this->{$CurrentObject} = \%ObjectProperties;
|
|
|
64
|
|
|
65 my $tagname;
|
|
|
66 if (_CheckName($args{'name'})) {
|
|
|
67 $tagname = $args{'name'};
|
|
|
68 } else {
|
|
|
69 $tagname = 'element';
|
|
|
70 $ObjectProperties{'extname'} = $args{'name'};
|
|
|
71 }
|
|
|
72
|
|
|
73 if ($args{'refid'}) {
|
|
|
74 $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag};
|
|
|
75 $this->{$XmlWriter}->emptyTag($tagname,%ObjectProperties);
|
|
|
76 $ObjectProperties{'container_type'} = CONTAINER_EMPTY;
|
|
|
77 } else {
|
|
|
78 $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag};
|
|
|
79 $this->{$XmlWriter}->startTag($tagname,%ObjectProperties);
|
|
|
80 $ObjectProperties{'container_type'} = CONTAINER_NORMAL;
|
|
|
81 }
|
|
|
82
|
|
|
83 $this->{$IdentLevel} ++;
|
|
|
84 $this->{$IdentNextTag} = $this->{$IdentOutput};
|
|
|
85
|
|
|
86 return 1;
|
|
|
87 }
|
|
|
88
|
|
|
89 sub EndObject {
|
|
|
90 my $this = shift;
|
|
|
91
|
|
|
92 my $hCurrentObject = $this->{$CurrentObject} or return 0;
|
|
|
93
|
|
|
94 $this->{$IdentLevel} --;
|
|
|
95
|
|
|
96 if ( $hCurrentObject->{'container_type'} != CONTAINER_EMPTY ) {
|
|
|
97 $this->{$XmlWriter}->characters("\n" . (' ' x $$this{$IdentLevel}) ) if $$this{$IdentNextTag};
|
|
|
98 $this->{$XmlWriter}->endTag();
|
|
|
99 }
|
|
|
100
|
|
|
101 $this->{$IdentNextTag} = $this->{$IdentOutput};
|
|
|
102
|
|
|
103 $this->{$CurrentObject} = pop @{$this->{$ObjectPath}} if exists $this->{$ObjectPath};
|
|
|
104 $this->{$XmlWriter} = undef if (not $this->{$CurrentObject});
|
|
|
105
|
|
|
106 return 1;
|
|
|
107 }
|
|
|
108
|
|
|
109 sub SetData {
|
|
|
110 my $this = shift;
|
|
|
111 #my $hCurrentObject = $this->{$CurrentObject} or return 0;
|
|
|
112
|
|
|
113 if ($this->{$CurrentObject}->{'container_type'} == CONTAINER_NORMAL) {
|
|
|
114 $this->{$XmlWriter}->characters($_[0]) if defined $_[0];
|
|
|
115 $this->{$IdentNextTag} = 0;
|
|
|
116 return 1;
|
|
|
117 } else {
|
|
|
118 return 0;
|
|
|
119 }
|
|
|
120 }
|
|
|
121
|
|
|
122 sub _CheckName {
|
|
|
123 return 0 if not $_[0];
|
|
|
124 return $_[0] =~ /^(_|\w|\d)+$/;
|
|
|
125 }
|
|
|
126
|
|
|
127 package IMPL::Serialization::XmlObjectReader;
|
|
|
128 use base qw(XML::Parser);
|
|
|
129
|
|
|
130 sub new {
|
|
|
131 my $class = shift;
|
|
|
132 my %args = @_;
|
|
|
133 die new Exception("Handler parameter is reqired") if not $args{'Handler'};
|
|
|
134 die new Exception("Handler parameter must be a reference") if not ref $args{'Handler'};
|
|
|
135
|
|
|
136 #my $this = $class->SUPER::new(Style => 'Stream', Pkg => 'Serialization::XmlObjectReader', 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } );
|
|
|
137 my $this = $class->SUPER::new(Handlers => { Start => \&StartTag, End => \&EndTag, Char => \&Text} , 'Non-Expat-Options' => {hInput => $args{'hInput'} , Handler => $args{'Handler'}, SkipWhitespace => $args{'SkipWhitespace'} } );
|
|
|
138 return $this;
|
|
|
139 }
|
|
|
140
|
|
|
141 sub Parse {
|
|
|
142 my $this = shift;
|
|
|
143 $this->parse($this->{'Non-Expat-Options'}->{'hInput'});
|
|
|
144 return 1;
|
|
|
145 }
|
|
|
146
|
|
|
147 sub StartTag {
|
|
|
148 my $this = shift;
|
|
|
149 my $name = shift;
|
|
|
150 my %Attr = @_;
|
|
|
151 $name = $Attr{'extname'} if defined $Attr{'extname'};
|
|
|
152 $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectBegin($name,\%Attr);
|
|
|
153 return 1;
|
|
|
154 }
|
|
|
155
|
|
|
156 sub EndTag {
|
|
|
157 my ($this,$name) = @_;
|
|
|
158 $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectEnd($name);
|
|
|
159 return 1;
|
|
|
160 }
|
|
|
161
|
|
|
162 sub Text {
|
|
|
163 my ($this) = shift;
|
|
|
164 $_ = shift;
|
|
|
165 return 1 if $this->{'Non-Expat-Options'}->{'SkipWhitespace'} and /^\n*\s*\n*$/;
|
|
|
166 $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectData($_);
|
|
|
167 return 1;
|
|
|
168 }
|
|
|
169
|
|
|
170 package IMPL::Serialization::XmlFormatter;
|
|
|
171 use base qw(IMPL::Object);
|
|
|
172
|
|
|
173 use IMPL::Class::Property;
|
|
|
174 use IMPL::Class::Property::Direct;
|
|
|
175
|
|
|
176 BEGIN {
|
|
|
177 public _direct property Encoding => prop_all;
|
|
|
178 public _direct property SkipWhitespace => prop_all;
|
|
|
179 public _direct property IdentOutput => prop_all;
|
|
|
180 }
|
|
|
181
|
|
|
182 sub CTOR {
|
|
|
183 my ($this,%args) = @_;
|
|
|
184
|
|
|
185 $this->Encoding($args{'Encoding'} || 'utf-8');
|
|
|
186 $this->SkipWhitespace($args{'SkipWhitespace'});
|
|
|
187 $this->IdentOutput($args{'IdentOutput'});
|
|
|
188
|
|
|
189 return 1;
|
|
|
190 }
|
|
|
191
|
|
|
192 sub CreateWriter {
|
|
|
193 my ($this,$hStream) = @_;
|
|
|
194 return new IMPL::Serialization::XmlObjectWriter(Encoding =>$this->Encoding() , hOutput => $hStream, IdentOutput => $this->IdentOutput());
|
|
|
195 }
|
|
|
196
|
|
|
197 sub CreateReader {
|
|
|
198 my ($this,$hStream,$refHandler) = @_;
|
|
|
199 return new IMPL::Serialization::XmlObjectReader(hInput => $hStream, Handler => $refHandler, SkipWhitespace => $this->SkipWhitespace());
|
|
|
200 }
|
|
|
201
|
|
49
|
202 1;
|
