/[webpac2]/trunk/lib/WebPAC/Output/SWISH.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/WebPAC/Output/SWISH.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1147 by dpavlin, Thu Apr 23 13:20:51 2009 UTC revision 1179 by dpavlin, Wed Apr 29 18:14:17 2009 UTC
# Line 8  use lib 'lib'; Line 8  use lib 'lib';
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;
21    use Encode qw/encode/;
22    
23    
24  =head1 NAME  =head1 NAME
# Line 62  sub init { Line 65  sub init {
65    
66          my $database = $self->database || $log->logdie("need database");          my $database = $self->database || $log->logdie("need database");
67    
68          make_path $dir if ! -e $dir;          mkpath $dir if ! -e $dir;
69    
70          my $path = "$dir/$database.conf";          my $path = "$dir/$database.conf";
71    
# Line 89  IndexFile $dir/$database Line 92  IndexFile $dir/$database
92  # Croatian ISO-8859-2 characters to unaccented equivalents  # Croatian ISO-8859-2 characters to unaccented equivalents
93  #TranslateCharacters ¹©ðÐèÈæƾ® ssddcccczz  #TranslateCharacters ¹©ðÐèÈæƾ® ssddcccczz
94    
95    # store data into index
96    PropertyNames data
97    
98  # disable output  # disable output
99  ParserWarnLevel 0  ParserWarnLevel 0
# Line 126  my $escape_re  = join '|' => keys %escap Line 131  my $escape_re  = join '|' => keys %escap
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
# Line 144  sub add { Line 151  sub add {
151    
152          return unless (@tags);          return unless (@tags);
153    
154          my $xml = qq{<xml>};          my $xml = qq{<all>};
155            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    
# Line 156  sub add { Line 169  sub add {
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;
179          }          }
180    
181          $xml .= qq{</xml>\n};          # serialize to JSON instead of YAML because we will loose whitespace
182            $data = to_json($data);
183            $xml .= qq{<data><![CDATA[$data]]></data>};
184    
185            $xml .= qq{</all>\n};
186    
187            $xml = encode('utf-8', $xml);
188    
189          my $len = length($xml);          my $len = length($xml);
190    
# Line 170  sub add { Line 193  sub add {
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            $log->debug( $xml );
197    
198          return 1;          return 1;
199  }  }
200    
Legend:
Removed from v.1147  
changed lines
  Added in v.1179
  ViewVC Help
Powered by ViewVC 1.1.26