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 |
|
|
155 |
|
$xml .= "<$_>" . $self->$_ . "</$_>" foreach ( 'database', 'input' ); |
156 |
|
|
157 |
my $data; |
my $data; |
158 |
|
|
166 |
next if ! $vals; |
next if ! $vals; |
167 |
|
|
168 |
$vals =~ s/($escape_re)/$escape{$1}/gs; |
$vals =~ s/($escape_re)/$escape{$1}/gs; |
169 |
$xml .= qq{<$tag><![CDATA[$vals]]></$tag>}; |
# BW & EW are our markers for tag boundry |
170 |
|
$xml .= qq{<$tag><![CDATA[BW $vals EW]]></$tag>}; |
171 |
|
|
172 |
$self->{stats}->{attr}->{$tag}++; |
$self->{stats}->{attr}->{$tag}++; |
173 |
|
$self->{stats}->{input}->{ $self->input }->{$tag}++; |
174 |
|
|
175 |
$data->{$tag} = $vals; |
$data->{$tag} = $vals; |
176 |
} |
} |
179 |
$data = to_json($data); |
$data = to_json($data); |
180 |
$xml .= qq{<data><![CDATA[$data]]></data>}; |
$xml .= qq{<data><![CDATA[$data]]></data>}; |
181 |
|
|
182 |
$xml .= qq{</xml>\n}; |
$xml .= qq{</all>\n}; |
183 |
|
|
184 |
my $len = length($xml); |
my $len = length($xml); |
185 |
|
|
188 |
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 |
189 |
die "can't add $uri: $@\n$xml"; |
die "can't add $uri: $@\n$xml"; |
190 |
|
|
191 |
warn "$xml\n"; |
$log->debug( $xml ); |
192 |
|
|
193 |
return 1; |
return 1; |
194 |
} |
} |