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 |
15 |
)); |
)); |
16 |
|
|
17 |
use File::Path qw/make_path/; |
use File::Path qw/mkpath/; |
18 |
use Data::Dump qw/dump/; |
use Data::Dump qw/dump/; |
19 |
use YAML; |
use YAML; |
20 |
use JSON; |
use JSON; |
64 |
|
|
65 |
my $database = $self->database || $log->logdie("need database"); |
my $database = $self->database || $log->logdie("need database"); |
66 |
|
|
67 |
make_path $dir if ! -e $dir; |
mkpath $dir if ! -e $dir; |
68 |
|
|
69 |
my $path = "$dir/$database.conf"; |
my $path = "$dir/$database.conf"; |
70 |
|
|
130 |
sub add { |
sub add { |
131 |
my ($self,$id,$ds) = @_; |
my ($self,$id,$ds) = @_; |
132 |
|
|
133 |
|
die "need input" unless $self->input; |
134 |
|
|
135 |
my $log = $self->_get_logger; |
my $log = $self->_get_logger; |
136 |
$log->debug("id: $id ds = ",sub { dump($ds) }); |
$log->debug("id: $id ds = ",sub { dump($ds) }); |
137 |
|
|
138 |
my $database = $self->database || $log->logconfess('no database in $self'); |
my $database = $self->database || $log->logconfess('no database in $self'); |
139 |
|
|
140 |
my $uri = $self->database . "/$id"; |
my $uri = $self->database . '/' . $self->input . "/$id"; |
141 |
$log->debug("creating $uri"); |
$log->debug("creating $uri"); |
142 |
|
|
143 |
# filter all tags which have type defined |
# filter all tags which have type defined |
150 |
|
|
151 |
return unless (@tags); |
return unless (@tags); |
152 |
|
|
153 |
my $xml = qq{<xml>}; |
my $xml = qq{<all>}; |
|
|
|
154 |
my $data; |
my $data; |
155 |
|
|
156 |
|
foreach ( 'database', 'input' ) { |
157 |
|
$xml .= "<$_>" . $self->$_ . "</$_>"; |
158 |
|
$data->{$_} = $self->$_; |
159 |
|
} |
160 |
|
|
161 |
foreach my $tag (@tags) { |
foreach my $tag (@tags) { |
162 |
|
|
163 |
my $r = ref $ds->{$tag}->{$type}; |
my $r = ref $ds->{$tag}->{$type}; |
168 |
next if ! $vals; |
next if ! $vals; |
169 |
|
|
170 |
$vals =~ s/($escape_re)/$escape{$1}/gs; |
$vals =~ s/($escape_re)/$escape{$1}/gs; |
171 |
$xml .= qq{<$tag><![CDATA[$vals]]></$tag>}; |
# BW & EW are our markers for tag boundry |
172 |
|
$xml .= qq{<$tag><![CDATA[BW $vals EW]]></$tag>}; |
173 |
|
|
174 |
$self->{stats}->{attr}->{$tag}++; |
$self->{stats}->{attr}->{$tag}++; |
175 |
|
$self->{stats}->{input}->{ $self->input }->{$tag}++; |
176 |
|
|
177 |
$data->{$tag} = $vals; |
$data->{$tag} = $vals; |
178 |
} |
} |
181 |
$data = to_json($data); |
$data = to_json($data); |
182 |
$xml .= qq{<data><![CDATA[$data]]></data>}; |
$xml .= qq{<data><![CDATA[$data]]></data>}; |
183 |
|
|
184 |
$xml .= qq{</xml>\n}; |
$xml .= qq{</all>\n}; |
185 |
|
|
186 |
my $len = length($xml); |
my $len = length($xml); |
187 |
|
|
190 |
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 |
191 |
die "can't add $uri: $@\n$xml"; |
die "can't add $uri: $@\n$xml"; |
192 |
|
|
193 |
warn "$xml\n"; |
$log->debug( $xml ); |
194 |
|
|
195 |
return 1; |
return 1; |
196 |
} |
} |