/[Search-Estraier]/trunk/lib/Search/Estraier.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/Search/Estraier.pm

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

revision 71 by dpavlin, Mon Jan 9 15:22:05 2006 UTC revision 97 by dpavlin, Sat Jan 28 18:19:47 2006 UTC
# Line 4  use 5.008; Line 4  use 5.008;
4  use strict;  use strict;
5  use warnings;  use warnings;
6    
7  our $VERSION = '0.03_1';  our $VERSION = '0.04_1';
8    
9  =head1 NAME  =head1 NAME
10    
# Line 92  Remove multiple whitespaces from string, Line 92  Remove multiple whitespaces from string,
92  =cut  =cut
93    
94  sub _s {  sub _s {
95          my $text = $_[1] || return;          my $text = $_[1];
96            return unless defined($text);
97          $text =~ s/\s\s+/ /gs;          $text =~ s/\s\s+/ /gs;
98          $text =~ s/^\s+//;          $text =~ s/^\s+//;
99          $text =~ s/\s+$//;          $text =~ s/\s+$//;
# Line 157  sub new { Line 158  sub new {
158                          } elsif ($line =~ m/^$/) {                          } elsif ($line =~ m/^$/) {
159                                  $in_text = 1;                                  $in_text = 1;
160                                  next;                                  next;
161                          } elsif ($line =~ m/^(.+)=(.+)$/) {                          } elsif ($line =~ m/^(.+)=(.*)$/) {
162                                  $self->{attrs}->{ $1 } = $2;                                  $self->{attrs}->{ $1 } = $2;
163                                  next;                                  next;
164                          }                          }
165    
166                          warn "draft ignored: $line\n";                          warn "draft ignored: '$line'\n";
167                  }                  }
168          }          }
169    
# Line 320  sub dump_draft { Line 321  sub dump_draft {
321          my $draft;          my $draft;
322    
323          foreach my $attr_name (sort keys %{ $self->{attrs} }) {          foreach my $attr_name (sort keys %{ $self->{attrs} }) {
324                  $draft .= $attr_name . '=' . $self->{attrs}->{$attr_name} . "\n";                  next unless defined(my $v = $self->{attrs}->{$attr_name});
325                    $draft .= $attr_name . '=' . $v . "\n";
326          }          }
327    
328          if ($self->{kwords}) {          if ($self->{kwords}) {
# Line 735  sub hint { Line 737  sub hint {
737          return $self->{hints}->{$key};          return $self->{hints}->{$key};
738  }  }
739    
740    =head2 hints
741    
742    More perlish version of C<hint>. This one returns hash.
743    
744      my %hints = $rec->hints;
745    
746    =cut
747    
748    sub hints {
749            my $self = shift;
750            return $self->{hints};
751    }
752    
753  package Search::Estraier::Node;  package Search::Estraier::Node;
754    
# Line 754  or optionally with C<url> as parametar Line 768  or optionally with C<url> as parametar
768    
769    my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );    my $node = new Search::HyperEstraier::Node( 'http://localhost:1978/node/test' );
770    
771    or in more verbose form
772    
773      my $node = new Search::HyperEstraier::Node(
774            url => 'http://localhost:1978/node/test',
775            debug => 1,
776            croak_on_error => 1
777      );
778    
779    with following arguments:
780    
781    =over 4
782    
783    =item url
784    
785    URL to node
786    
787    =item debug
788    
789    dumps a B<lot> of debugging output
790    
791    =item croak_on_error
792    
793    very helpful during development. It will croak on all errors instead of
794    silently returning C<-1> (which is convention of Hyper Estraier API in other
795    languages).
796    
797    =back
798    
799  =cut  =cut
800    
801  sub new {  sub new {
# Line 776  sub new { Line 818  sub new {
818          } else {          } else {
819                  my $args = {@_};                  my $args = {@_};
820    
821                  $self->{debug} = $args->{debug};                  %$self = ( %$self, @_ );
822    
823                  warn "## Node debug on\n" if ($self->{debug});                  warn "## Node debug on\n" if ($self->{debug});
824          }          }
825    
# Line 1418  sub shuttle_url { Line 1461  sub shuttle_url {
1461    
1462          $req->headers->header( 'Host' => $url->host . ":" . $url->port );          $req->headers->header( 'Host' => $url->host . ":" . $url->port );
1463          $req->headers->header( 'Connection', 'close' );          $req->headers->header( 'Connection', 'close' );
1464          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} );          $req->headers->header( 'Authorization', 'Basic ' . $self->{auth} ) if ($self->{auth});
1465          $req->content_type( $content_type );          $req->content_type( $content_type );
1466    
1467          warn $req->headers->as_string,"\n" if ($self->{debug});          warn $req->headers->as_string,"\n" if ($self->{debug});
# Line 1432  sub shuttle_url { Line 1475  sub shuttle_url {
1475    
1476          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});          warn "## response status: ",$res->status_line,"\n" if ($self->{debug});
1477    
         return -1 if (! $res->is_success);  
   
1478          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);          ($self->{status}, $self->{status_message}) = split(/\s+/, $res->status_line, 2);
1479    
1480            if (! $res->is_success) {
1481                    if ($self->{croak_on_error}) {
1482                            croak("can't get $url: ",$res->status_line);
1483                    } else {
1484                            return -1;
1485                    }
1486            }
1487    
1488          $$resbody .= $res->content;          $$resbody .= $res->content;
1489    
1490          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});          warn "## response body:\n$$resbody\n" if ($resbody && $self->{debug});
Legend:
Removed from v.71  
changed lines
  Added in v.97
  ViewVC Help
Powered by ViewVC 1.1.26