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