8 |
use base qw/WebPAC::Common Class::Accessor/; |
use base qw/WebPAC::Common Class::Accessor/; |
9 |
__PACKAGE__->mk_accessors(qw( |
__PACKAGE__->mk_accessors(qw( |
10 |
database |
database |
11 |
|
input |
12 |
type |
type |
13 |
|
|
14 |
index_path |
index_path |
18 |
use Data::Dump qw/dump/; |
use Data::Dump qw/dump/; |
19 |
use YAML; |
use YAML; |
20 |
use JSON; |
use JSON; |
21 |
|
use Encode qw/encode/; |
22 |
|
|
23 |
|
|
24 |
=head1 NAME |
=head1 NAME |
131 |
sub add { |
sub add { |
132 |
my ($self,$id,$ds) = @_; |
my ($self,$id,$ds) = @_; |
133 |
|
|
134 |
|
die "need input" unless $self->input; |
135 |
|
|
136 |
my $log = $self->_get_logger; |
my $log = $self->_get_logger; |
137 |
$log->debug("id: $id ds = ",sub { dump($ds) }); |
$log->debug("id: $id ds = ",sub { dump($ds) }); |
138 |
|
|
139 |
my $database = $self->database || $log->logconfess('no database in $self'); |
my $database = $self->database || $log->logconfess('no database in $self'); |
140 |
|
|
141 |
my $uri = $self->database . "/$id"; |
my $uri = $self->database . '/' . $self->input . "/$id"; |
142 |
$log->debug("creating $uri"); |
$log->debug("creating $uri"); |
143 |
|
|
144 |
# filter all tags which have type defined |
# filter all tags which have type defined |
151 |
|
|
152 |
return unless (@tags); |
return unless (@tags); |
153 |
|
|
154 |
my $xml = qq{<xml>}; |
my $xml = qq{<all>}; |
|
|
|
155 |
my $data; |
my $data; |
156 |
|
|
157 |
|
foreach ( 'database', 'input' ) { |
158 |
|
$xml .= "<$_>" . $self->$_ . "</$_>"; |
159 |
|
$data->{$_} = $self->$_; |
160 |
|
} |
161 |
|
|
162 |
foreach my $tag (@tags) { |
foreach my $tag (@tags) { |
163 |
|
|
164 |
my $r = ref $ds->{$tag}->{$type}; |
my $r = ref $ds->{$tag}->{$type}; |
169 |
next if ! $vals; |
next if ! $vals; |
170 |
|
|
171 |
$vals =~ s/($escape_re)/$escape{$1}/gs; |
$vals =~ s/($escape_re)/$escape{$1}/gs; |
172 |
$xml .= qq{<$tag><![CDATA[$vals]]></$tag>}; |
# BW & EW are our markers for tag boundry |
173 |
|
$xml .= qq{<$tag><![CDATA[BW $vals EW]]></$tag>}; |
174 |
|
|
175 |
$self->{stats}->{attr}->{$tag}++; |
$self->{stats}->{attr}->{$tag}++; |
176 |
|
$self->{stats}->{input}->{ $self->input }->{$tag}++; |
177 |
|
|
178 |
$data->{$tag} = $vals; |
$data->{$tag} = $vals; |
179 |
} |
} |
182 |
$data = to_json($data); |
$data = to_json($data); |
183 |
$xml .= qq{<data><![CDATA[$data]]></data>}; |
$xml .= qq{<data><![CDATA[$data]]></data>}; |
184 |
|
|
185 |
$xml .= qq{</xml>\n}; |
$xml .= qq{</all>\n}; |
186 |
|
|
187 |
|
$xml = encode('utf-8', $xml); |
188 |
|
|
189 |
my $len = length($xml); |
my $len = length($xml); |
190 |
|
|
193 |
print $fh "Path-Name: $uri\nContent-Length: $len\nDocument-Type: XML\n\n$xml" or |
print $fh "Path-Name: $uri\nContent-Length: $len\nDocument-Type: XML\n\n$xml" or |
194 |
die "can't add $uri: $@\n$xml"; |
die "can't add $uri: $@\n$xml"; |
195 |
|
|
196 |
# warn "$xml\n"; |
$log->debug( $xml ); |
197 |
|
|
198 |
return 1; |
return 1; |
199 |
} |
} |