/[suikacvs]/messaging/bunshin/Bunshin.pm
Suika

Diff of /messaging/bunshin/Bunshin.pm

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

revision 1.3 by wakaba, Thu Jun 20 11:36:32 2002 UTC revision 1.5 by wakaba, Thu Aug 29 12:10:59 2002 UTC
# Line 20  sub new ($;%) { Line 20  sub new ($;%) {
20    my $class = shift;    my $class = shift;
21    my $self = bless {}, $class;    my $self = bless {}, $class;
22    $self->{fmt2str} = Message::Util::make_clone    $self->{fmt2str} = Message::Util::make_clone
23      ($Message::Field::Date::DEFAULT{-fmt2str});      (\%Message::Field::Date::FMT2STR);
24    $self;    $self;
25  }  }
26    
# Line 67  sub set_elements ($$@) { Line 67  sub set_elements ($$@) {
67  sub set_source ($%) {  sub set_source ($%) {
68    my $self = shift;    my $self = shift;
69    my %option = @_;    my %option = @_;
70      ($self->{source}, $self->{meta_info}) = $self->_get_resource (%option);
71      $self->default_parameter (base_uri => $option{uri}) if $option{uri};
72            ## BUG: Doesn't support redirection
73      if ($option{uri} || $option{file}) {
74        my $c = $self->{hook_code_conversion} || \&_code_conversion;
75        $self->{source} = &$c ($self, $self->{source}, \%option, $self->{meta_info});
76      }
77      $self->{source} =~ s/\x0D(?!\x0A)/\x0D\x0A/g;
78      $self->{source} =~ s/(?<!\x0D)\x0A/\x0D\x0A/g;
79      $self;
80    }
81    
82    sub _get_resource ($%) {
83      my $self = shift;
84      my %option = @_;
85      my ($resource, $meta);
86    if (defined $option{value}) {    if (defined $option{value}) {
87      $self->{source} = $option{value};      $resource = $option{value};
88    } elsif ($option{uri}) {    } elsif ($option{uri}) {
89      require Message::Field::UA;      require Message::Field::UA;
90      require LWP::UserAgent;      require LWP::UserAgent;
# Line 79  sub set_source ($%) { Line 95  sub set_source ($%) {
95      $lwp->agent ($ua->stringify);      $lwp->agent ($ua->stringify);
96      my $req = HTTP::Request->new (GET => $option{uri});      my $req = HTTP::Request->new (GET => $option{uri});
97      my $res = $lwp->request ($req);      my $res = $lwp->request ($req);
98      my $c = $self->{hook_code_conversion} || \&_code_conversion;      $resource = $res->content;
99      $self->{source} = &$c ($self, $res->content, \%option);      $meta = parse Message::Header $res->headers_as_string,
100      $self->default_parameter (base_uri => $option{uri});        -parse_all => 0, -format => 'http-response',
101        ;
102    } elsif ($option{file}) {    } elsif ($option{file}) {
103      my $f = new FileHandle $option{file} => 'r';      my $f = new FileHandle $option{file} => 'r';
104      Carp::croak "set_source: $option{file}: $!" unless defined $f;      Carp::croak "set_source: $option{file}: $!" unless defined $f;
105      my $c = $self->{hook_code_conversion} || \&_code_conversion;      my $c = $self->{hook_code_conversion} || \&_code_conversion;
106      local $/ = undef;      local $/ = undef;
107      $self->{source} = &$c ($self, $f->getline, \%option);      $resource = $f->getline;
108    } else {    } else {
109      Carp::croak "set_source: $_[0]: Unsupported data source type";      Carp::croak "_get_resource: $_[0]: Unsupported data source type";
110    }    }
111    $self->{source} =~ s/\x0D(?!\x0A)/\x0D\x0A/g;    ($resource, $meta);
   $self->{source} =~ s/(?<!\x0D)\x0A/\x0D\x0A/g;  
   $self;  
112  }  }
113    
114  ## $self->_code_conversion ($string, \%option)  ## $self->_code_conversion ($string, \%option, $meta_info)
115  sub _code_conversion ($$\%) {  sub _code_conversion ($$\%$) {
116    $_[1];    $_[1];
117  }  }
118    
# Line 136  sub _make_a_msg ($@) { Line 151  sub _make_a_msg ($@) {
151      -fill_date  => 0,      -fill_date  => 0,
152      -fill_msgid => 0,      -fill_msgid => 0,
153      -fill_ua_name       => 'x-shimbun-agent',      -fill_ua_name       => 'x-shimbun-agent',
154        -format     => 'news-usefor',
155      -parse_all  => 1,      -parse_all  => 1,
156    ;    ;
157    my $hdr = $msg->header;    my $hdr = $msg->header;
# Line 184  sub _make_a_msg ($@) { Line 200  sub _make_a_msg ($@) {
200        if ($p{base_uri} && /uri/ && length $p{$_}) {        if ($p{base_uri} && /uri/ && length $p{$_}) {
201          require URI::WithBase;          require URI::WithBase;
202          $a->add ($name => URI::WithBase->new ($p{$_}, $p{base_uri})->abs);          $a->add ($name => URI::WithBase->new ($p{$_}, $p{base_uri})->abs);
203          } elsif (/color/) {
204            $p{$_} = '#'.$p{$_} if $p{$_} =~ /^[A-Za-z0-9]{6}$/;
205            $a->add ($name => $p{$_}) if length $p{$_};
206        } else {        } else {
207          $a->add ($name => $p{$_}) if length $p{$_};          $a->add ($name => $p{$_}) if length $p{$_};
208        }        }
# Line 205  sub _make_a_msg ($@) { Line 224  sub _make_a_msg ($@) {
224        $uri->display_name ($p{list_name}) if length $p{list_name};        $uri->display_name ($p{list_name}) if length $p{list_name};
225      }      }
226      if ($p{urn_template}) {      if ($p{urn_template}) {
227        my $urn = $self->Message::Field::Date::_date2str ({        my $urn = $date->stringify (
228          format_template => $p{urn_template},          -format_macros  => $self->{fmt2str},
229          date_time       => $date->unix_time,          -format_template        => $p{urn_template},
230          zone    => $date->zone,          -format_parameters      => \%p,
231          fmt2str => $self->{fmt2str},        );
232        }, \%p);        #my $urn = $self->Message::Field::Date::_date2str ({
233          #  format_template        => $p{urn_template},
234          #  date_time      => $date->unix_time,
235          #  zone   => $date->zone,
236          #  fmt2str        => $self->{fmt2str},
237          #}, \%p);
238        $hdr->add ('x-uri')->value ($urn);        $hdr->add ('x-uri')->value ($urn);
239      }      }
240    ## Additional information    ## Additional information
# Line 240  sub default_parameter ($@) { Line 264  sub default_parameter ($@) {
264    $self;    $self;
265  }  }
266    
267    =head1 $meta = $b->meta_information
268    
269    Gets meta information from resource requesting protocol.
270    Usually returned value is Message::Header object.
271    When resource is getten via HTTP, its content is HTTP response
272    header.
273    
274    =cut
275    
276    sub meta_information ($) {
277      my $self = shift;
278      $self->{meta_info};
279    }
280    
281  =head1 LICENSE  =head1 LICENSE
282    
283  Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.  Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24