/[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.1 by wakaba, Sun Jun 16 02:50:54 2002 UTC revision 1.6 by wakaba, Tue Sep 10 23:37:43 2002 UTC
# Line 1  Line 1 
1    
2  =head1 NAME  =head1 NAME
3    
4  Bunshin  Bunshin --- A shimbun implemrntion written in Perl
5    
6  =cut  =cut
7    
# Line 11  use vars qw($DEBUG $MYNAME $VERSION); Line 11  use vars qw($DEBUG $MYNAME $VERSION);
11  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
12  $MYNAME = 'Bunshin';  $MYNAME = 'Bunshin';
13  $DEBUG = 0;  $DEBUG = 0;
 use Time::Local;  
14  use FileHandle;  use FileHandle;
15  require Message::Entity;  require Message::Entity;
16  require Message::Util;  require Message::Util;
# Line 21  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 52  sub set_hook_function ($$\&) { Line 51  sub set_hook_function ($$\&) {
51    $self->{'hook_'.$name} = $function;    $self->{'hook_'.$name} = $function;
52  }  }
53    
54    sub set_element_decoders ($%) {
55      my $self = shift;
56      my %list = @_;
57      for (keys %list) {
58        if ($list{$_} eq 'enentity_html') {
59          $list{$_} = \&Message::Util::enentity_html;
60        } elsif ($list{$_} eq 'deentity_html') {
61          $list{$_} = \&Message::Util::deentity_html;
62        ## TODO: escape_uri, unescape_uri
63        }
64      }
65      $self->{element_decoder} = %list;
66    }
67    
68  sub set_format ($$\&) {  sub set_format ($$\&) {
69    my $self = shift;    my $self = shift;
70    my $name = shift;    my $name = shift;
# Line 68  sub set_elements ($$@) { Line 81  sub set_elements ($$@) {
81  sub set_source ($%) {  sub set_source ($%) {
82    my $self = shift;    my $self = shift;
83    my %option = @_;    my %option = @_;
84      ($self->{source}, $self->{meta_info}) = $self->_get_resource (%option);
85      $self->default_parameter (base_uri => $option{uri}) if $option{uri};
86            ## BUG: Doesn't support redirection
87      if ($option{uri} || $option{file}) {
88        my $c = $self->{hook_code_conversion} || \&_code_conversion;
89        $self->{source} = &$c ($self, $self->{source}, \%option, $self->{meta_info});
90      }
91      $self->{source} =~ s/\x0D(?!\x0A)/\x0D\x0A/g;
92      $self->{source} =~ s/(?<!\x0D)\x0A/\x0D\x0A/g;
93      $self;
94    }
95    
96    sub _get_resource ($%) {
97      my $self = shift;
98      my %option = @_;
99      my ($resource, $meta);
100    if (defined $option{value}) {    if (defined $option{value}) {
101      $self->{source} = $option{value};      $resource = $option{value};
102    } elsif ($option{uri}) {    } elsif ($option{uri}) {
103      require Message::Field::UA;      require Message::Field::UA;
104      require LWP::UserAgent;      require LWP::UserAgent;
# Line 80  sub set_source ($%) { Line 109  sub set_source ($%) {
109      $lwp->agent ($ua->stringify);      $lwp->agent ($ua->stringify);
110      my $req = HTTP::Request->new (GET => $option{uri});      my $req = HTTP::Request->new (GET => $option{uri});
111      my $res = $lwp->request ($req);      my $res = $lwp->request ($req);
112      my $c = $self->{hook_code_conversion} || \&_code_conversion;      $resource = $res->content;
113      $self->{source} = &$c ($self, $res->content, \%option);      $meta = parse Message::Header $res->headers_as_string,
114      $self->default_parameter (base_uri => $option{uri});        -parse_all => 0, -format => 'http-response',
115        ;
116    } elsif ($option{file}) {    } elsif ($option{file}) {
117      my $f = new FileHandle $option{file} => 'r';      my $f = new FileHandle $option{file} => 'r';
118      Carp::croak "set_source: $option{file}: $!" unless defined $f;      Carp::croak "set_source: $option{file}: $!" unless defined $f;
119      my $c = $self->{hook_code_conversion} || \&_code_conversion;      my $c = $self->{hook_code_conversion} || \&_code_conversion;
120      local $/ = undef;      local $/ = undef;
121      $self->{source} = &$c ($self, $f->getline, \%option);      $resource = $f->getline;
     close SRC;  
122    } else {    } else {
123      Carp::croak "set_source: $_[0]: Unsupported data source type";      Carp::croak "_get_resource: $_[0]: Unsupported data source type";
124    }    }
125    $self->{source} =~ s/\x0D(?!\x0A)/\x0D\x0A/g;    ($resource, $meta);
   $self->{source} =~ s/(?<!\x0D)\x0A/\x0D\x0A/g;  
   $self;  
126  }  }
127    
128  ## $self->_code_conversion ($string, \%option)  ## $self->_code_conversion ($string, \%option, $meta_info)
129  sub _code_conversion ($$\%) {  sub _code_conversion ($$\%$) {
130    $_[1];    $_[1];
131  }  }
132    
# Line 124  sub make_msgs ($) { Line 151  sub make_msgs ($) {
151      for my $i (0..$#{$self->{elements_message}}) {      for my $i (0..$#{$self->{elements_message}}) {
152        $p{$self->{elements_message}->[$i]} = ${$i+1};        $p{$self->{elements_message}->[$i]} = ${$i+1};
153      }      }
154        for my $n (keys %{$self->{element_decoder}}) {
155          if ($p{$n} && ref $self->{element_decoder}->{$n}) {
156            $p{$n} = &{ $self->{element_decoder}->{$n} } ($p{$n});
157          }
158        }
159      my $msg = &$f ($self, %p);      my $msg = &$f ($self, %p);
160      push @msg, $msg;      push @msg, $msg;
161    }gesx;    }gesx;
# Line 138  sub _make_a_msg ($@) { Line 170  sub _make_a_msg ($@) {
170      -fill_date  => 0,      -fill_date  => 0,
171      -fill_msgid => 0,      -fill_msgid => 0,
172      -fill_ua_name       => 'x-shimbun-agent',      -fill_ua_name       => 'x-shimbun-agent',
173        -format     => 'news-usefor',
174      -parse_all  => 1,      -parse_all  => 1,
175    ;    ;
176    my $hdr = $msg->header;    my $hdr = $msg->header;
177    ## Originator and date    ## Originator and date
178      my $from = $hdr->field ('from')->add ($p{from_mail});      my $from = $hdr->field ('from')->add ($p{from_mail} || 'foo@bar.invalid');
179      $from->display_name ($p{from_name}) if length $p{from_name};      $from->display_name ($p{from_name}) if length $p{from_name};
180      my $date = $hdr->field ('date');      my $date = $hdr->field ('date');
181      $p{date_year} ||= (gmtime)[5];      $p{date_year} ||= (gmtime)[5];
182      $date->set_datetime (@p{qw/date_year date_month      $date->set_datetime (@p{qw/date_year date_month
183        date_day date_hour date_minute date_second/},        date_day date_hour date_minute date_second/},
184        zone => $p{date_zone});        zone => $p{date_zone});
185      $hdr->add ('x-uri' => $p{from_uri}) if $p{from_uri};      $hdr->add (x_uri => $p{from_uri}) if $p{from_uri};
186      if ($p{from_face}) {      if ($p{from_face}) {
187        $msg->header->field ('x-face')->value ($p{from_face});        $msg->header->field ('x-face')->value ($p{from_face});
188      } elsif ($p{faces}->{$p{from_mail}}) {      } elsif ($p{faces}->{$p{from_mail}}) {
# Line 160  sub _make_a_msg ($@) { Line 193  sub _make_a_msg ($@) {
193    ## Message attribute    ## Message attribute
194      if (length $p{msg_id}) {      if (length $p{msg_id}) {
195        $hdr->add ('message-id' => $p{msg_id});        $hdr->add ('message-id' => $p{msg_id});
196      } else {      } elsif ($p{msg_id_from} || $p{msg_id_right} || $p{list_id}) {
       my $id_right = $p{msg_id_right} || $p{list_id};  
197        my $c = $p{msg_count};        my $c = $p{msg_count};
198        $c = '.d'.(0+$date) unless defined $p{msg_count};        $c = '.d'.(0+$date) unless defined $p{msg_count};
199        my $mid = sprintf '<msg%s.BS%%list@%s>', $c, $id_right;        my $mid;
200        $mid = sprintf '<msg%s.BS%%%s>', $c, $p{msg_id_from} if $p{msg_id_from};        if ($p{msg_id_from}) {
201            $mid = sprintf '<msg%s.BS%%%s%%%s>', $c, $p{list_id}, $p{msg_id_from};
202          } elsif ($p{msg_id_right}) {
203            $mid = sprintf '<msg%s.BS%%%s%%list@%s>', $c, $p{list_id}, $p{msg_id_right};
204          } else { #if ($p{list_id}) {
205            $mid = sprintf '<msg%s.BS%%list@%s>', $c, $p{list_id};
206          }
207        $hdr->add (($DEBUG?'x-':'').'message-id' => $mid);        $hdr->add (($DEBUG?'x-':'').'message-id' => $mid);
208      }      }
209      $hdr->add (subject => $p{subject}) if length $p{subject};      if (length $p{subject}) {
210          $hdr->add (subject => $p{subject});
211        } elsif (length $p{DEFAULT_subject}) {
212          $hdr->add (subject => $p{DEFAULT_subject});
213        }
214      my $a;      my $a;
215      for (grep {/^misc_/} keys %p) {      for (grep {/^misc_/} keys %p) {
216        $a = $hdr->field ('content-x-properties') unless ref $a;        $a = $hdr->field ('content-x-properties') unless ref $a;
# Line 176  sub _make_a_msg ($@) { Line 218  sub _make_a_msg ($@) {
218        $name =~ tr/_/-/;        $name =~ tr/_/-/;
219        if ($p{base_uri} && /uri/ && length $p{$_}) {        if ($p{base_uri} && /uri/ && length $p{$_}) {
220          require URI::WithBase;          require URI::WithBase;
221          $a->add ($name => URI::WithBase->new ($_, $p{base_uri})->abs);          $a->add ($name => URI::WithBase->new ($p{$_}, $p{base_uri})->abs);
222          } elsif (/color/) {
223            $p{$_} = '#'.$p{$_} if $p{$_} =~ /^[A-Za-z0-9]{6}$/;
224            $a->add ($name => $p{$_}) if length $p{$_};
225        } else {        } else {
226          $a->add ($name => $p{$_}) if length $p{$_};          $a->add ($name => $p{$_}) if length $p{$_};
227        }        }
# Line 190  sub _make_a_msg ($@) { Line 235  sub _make_a_msg ($@) {
235        $lid->value ($p{list_id});        $lid->value ($p{list_id});
236        $lid->display_name ($p{list_name}) if length $p{list_name};        $lid->display_name ($p{list_name}) if length $p{list_name};
237      }      }
238      $hdr->add ('x-mail-count' => $p{msg_count}) if defined $p{msg_count};      $hdr->add (x_mail_count => $p{msg_count}) if defined $p{msg_count};
239      $hdr->add ('x-ml-info' => $p{list_info}) if defined $p{list_info};      $hdr->add (x_ml_info => $p{list_info}) if defined $p{list_info};
240      if ($p{base_uri}) {      if ($p{base_uri}) {
241        my $uri = $hdr->add (x_uri => '');        my $uri = $hdr->add (x_uri => '');
242        $uri->value ($p{base_uri});        $uri->value ($p{base_uri});
243        $uri->display_name ($p{list_name}) if length $p{list_name};        $uri->display_name ($p{list_name}) if length $p{list_name};
244      }      }
245      if ($p{urn_template}) {      if ($p{urn_template}) {
246        my $urn = $self->Message::Field::Date::_date2str ({        my $urn = $date->stringify (
247          format_template => $p{urn_template},          -format_macros  => $self->{fmt2str},
248          date_time       => $date->unix_time,          -format_template        => $p{urn_template},
249          zone    => $date->zone,          -format_parameters      => \%p,
250          fmt2str => $self->{fmt2str},        );
251        });        #my $urn = $self->Message::Field::Date::_date2str ({
252          #  format_template        => $p{urn_template},
253          #  date_time      => $date->unix_time,
254          #  zone   => $date->zone,
255          #  fmt2str        => $self->{fmt2str},
256          #}, \%p);
257        $hdr->add ('x-uri')->value ($urn);        $hdr->add ('x-uri')->value ($urn);
258      }      }
259    ## Additional information    ## Additional information
# Line 233  sub default_parameter ($@) { Line 283  sub default_parameter ($@) {
283    $self;    $self;
284  }  }
285    
286    =head1 $meta = $b->meta_information
287    
288    Gets meta information from resource requesting protocol.
289    Usually returned value is Message::Header object.
290    When resource is getten via HTTP, its content is HTTP response
291    header.
292    
293    =cut
294    
295    sub meta_information ($) {
296      my $self = shift;
297      $self->{meta_info};
298    }
299    
300  =head1 LICENSE  =head1 LICENSE
301    
302  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.1  
changed lines
  Added in v.1.6
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24