root/lang/perl/blosxom/blosxom.nyarla.cgi @ 18391

Revision 7387, 19.1 kB (checked in by nyarla, 5 years ago)

lang/perl/blosxom/blosxom.nyarla.cgi: エントリの絞込みのバグを修正

Line 
1#!/usr/bin/perl
2
3# Blosxom
4# Author: Rael Dornfest <rael@oreilly.com>
5# Version: 2.0.2
6# Home/Docs/Licensing: http://www.blosxom.com/
7# Development/Downloads: http://sourceforge.net/projects/blosxom
8
9package blosxom;
10
11use strict;
12use warnings;
13
14our $version = '2.0.2';
15
16# -- require modules ----------------- #
17
18use FileHandle;
19use DirHandle;
20use FindBin ();
21use File::Find;
22use File::stat;
23use Time::localtime;
24use CGI qw( :standard :netscape );
25
26# -- package variables --------------- #
27
28our (
29    # weblog
30    $blog_title, $blog_description, $blog_language, $url,
31    # entries                               # flavour
32    $datadir, $depth, $file_extension,      $flavour_dir, $default_flavour,
33    # view                                  # plugins
34    $num_entries, $show_future_entries,     $plugin_dir, $plugin_state_dir, @plugin_order,
35    # request
36    $path_info, $path_info_yr, $path_info_mo, $path_info_mo_num, $path_info_da, $flavour,
37    # response              # system
38    $output, $header,       %template, @plugins, %plugins, %files, %indexes, %others,
39    # variables             # subroutines
40    %month2num, @num2month, $template, $interpolate, $entries,
41    # static
42    $static_or_dynamic, $static_dir, $static_password, @static_flavours, $static_entries,
43);
44
45my $fh = FileHandle->new;
46
47%month2num = (  nil => '00', Jan => '01', Feb => '02', Mar => '03',
48                Apr => '04', May => '05', Jun => '06', Jul => '07',
49                Aug => '08', Sep => '09', Oct => '10', Nov => '11', Dec => '12' );
50@num2month = sort { $month2num{$a} <=> $month2num{$b} } keys %month2num;
51
52# ------------------------------------ #
53
54# load configuration file
55{
56    my $file = env_value('config') || "$FindBin::Bin/config.pl";
57    eval { require $file };
58    die "Failed to load configuration file: $file: $@" if ( $@ );
59}
60
61# Use the stated preferred URL or figure it out automatically
62$url ||= url( -path_info => 1 );
63$url =~ s{^include:}{http:} if ( ( $ENV{'SERVER_PROTOCOL'} || q{} ) eq 'INCLUDED' );
64
65# NOTE: Since v3.12, it looks as if CGI.pm misbehaves for SSIs and
66# always appends path_info to the url. To fix this, we always
67# request an url with path_info, and always remove it from the end of the
68# string.
69{
70    my $path_info = ( $ENV{'PATH_INFO'} || q{} );
71    my $len = length $path_info;
72    my $frag = substr( $url, -$len );
73    substr( $url, -$len ) = q{} if ( $frag eq $path_info );
74}
75
76$url =~ s!/$!!;
77
78# Drop ending any / from dir settings
79for ( $datadir, $flavour_dir, $plugin_dir, $static_dir ) {
80    $_ =~ s{/$}{};
81}
82 
83# Fix depth to take into account datadir's path
84$depth += ( $datadir =~ tr{/}{} ) -1 if ( $depth );
85
86# Global variable to be used in head/foot.{flavour} templates
87$path_info = q{};
88
89$static_or_dynamic = (  !$ENV{'GATEWAY_INTERFACE'}
90                        && param('-password')
91                        && $static_password
92                        && param('-password') eq $static_password )
93                   ? 'static'
94                   : 'dynamic'
95                   ;
96param( -name => "-quiet", -value => 1 ) if ( $static_or_dynamic eq 'dynamic' );
97# Path Info Magic
98# Take a gander at HTTP's PATH_INFO for optional blog name, archive yr/mo/day
99my @path_info = split m{/+}, path_info() || param('path') || q{};
100shift @path_info;
101
102while ( $path_info[0] && $path_info[0] =~ /^[a-zA-Z].*$/ && $path_info[0] !~ /^.*\..*$/) {
103    $path_info .= '/' . shift @path_info;
104}
105
106# Flavour specified by ?flav={flav} or index.{flav}
107$flavour = q{};
108
109if ( $path_info[$#path_info] && $path_info[$#path_info] =~ /^(.+)\.(.+?)$/ ) {
110    $flavour = $2;
111    $path_info .= "/$1.$2" if ( $1 ne 'index' );
112    pop @path_info;
113}
114elsif ( ! -d "${datadir}${path_info}" ) {
115    $path_info .= ".${default_flavour}";
116    $flavour    = param('flav') || $default_flavour;
117}
118else {
119    $flavour = param('flav') || $default_flavour;
120}
121
122# Strip spurious slashes
123$path_info =~ s{^/*|/*$}{}g;
124
125# Date fiddling
126( $path_info_yr, $path_info_mo, $path_info_da ) = @path_info;
127$path_info_mo_num = ( $path_info_mo )
128                  ? ( ( $path_info_mo =~ /\d{2}/ )
129                      ? $path_info_mo
130                      : ($month2num{ucfirst(lc $path_info_mo)} || undef) )
131                  : undef ;
132
133$path_info_yr       ||= q{};
134$path_info_mo_num   ||= q{};
135$path_info_da       ||= q{};
136
137# Define standard template subroutine, plugin-overridable at Plugins: Template
138$template = sub {
139    my ( $path, $chunk, $flavour ) = @_;
140    my $dir = $flavour_dir || $datadir;
141    $path ||= q{};
142    do {
143        if ( $fh->open("${dir}/${path}/${chunk}.${flavour}", '<') ) {
144            my $file = do { local $/; <$fh> };
145            $fh->close;
146            return $file;
147        }
148    }
149    while ( $path =~ s{(/*[^/]*)$}{} && $1 );
150
151    # Check for definedness, since flavour can be the empty string
152    if ( defined $template{$flavour}{$chunk} ) {
153        return $template{$flavour}{$chunk};
154    }
155    elsif ( defined $template{'error'}{$chunk} ) {
156        return $template{'error'}{$chunk}
157    }
158    else {
159        return q{};
160    }
161};
162# Bring in the templates
163%template = ();
164while (<DATA>) {
165    last if ( $_ =~ m{^__END__$} );
166    my ( $flav, $chunk, $text ) = ( $_ =~ m{^(\S+)\s(\S+)(?:\s(.*))?$} ) or next;
167    $text =~ s{\\n}{\n}mg;
168    $template{$flav}{$chunk} .= "${text}\n";
169}
170
171# Plugins: Start
172if ( $plugin_dir ) {
173    if ( @plugin_order > 0 ) {
174        for my $plugin ( @plugin_order ) {
175            require "${plugin_dir}/${plugin}";
176            if ( $plugin->start() ) {
177                $plugins{$plugin} = 1;
178                push @plugins, $plugin;
179            }
180        }
181    }
182    elsif ( defined( my $dh = DirHandle->new( $plugin_dir ) ) ) {
183        for my $plugin ( grep { $_ =~ m{^\w+$} && -f "${plugin_dir}/${_}" } sort $dh->read ) {
184            next if ( $plugin =~ m{~$} ); # Ignore emacs backup
185            my ( $name, $off ) = ( $plugin =~ m{^\d*(\w+?)(_?)$} );
186            my $on_off = ( $off eq '_' ) ? -1 : 1 ;
187            require "${plugin_dir}/${plugin}";
188            if ( $name->start() ) {
189                $plugins{$name} = $on_off;
190                push @plugins, $name;
191            }
192        }
193        $dh->close;
194    }
195}
196
197# Plugins: Template
198# Allow for the first encountered plugin::template subroutine to override the
199# default built-in template subroutine
200overwrite_sub('template');
201
202# Provide backward compatibility for Blosxom < 2.0rc1 plug-ins
203sub load_template { $template->( @_ ) }
204
205# Define default entries subroutine
206$entries = sub {
207    my ( %files, %indexes, %others );
208    find(
209        sub {
210            my $currnet = $File::Find::dir =~ tr{/}{};
211            return if ( $depth && $currnet > $depth );
212
213            my $name = $File::Find::name;
214
215            return if ( -d $name );
216            return if ( ! -r $name );
217
218            my $time  = time;
219            my $mtime = stat($name)->mtime;
220
221            my ( $path, $fn )
222                = ( $name =~ m{^$datadir/(?:(.*)/)?(.+)\.$file_extension$} );
223
224            if ( ! $fn && $fn eq 'index' || $fn =~ m{\.} ) {
225                $others{$name} = $mtime;
226                return;
227            }
228
229            return if ( ! $show_future_entries && $mtime > $time );
230            $files{$name} = $mtime;
231
232            if ( $static_dir && $static_flavours[0] ) {
233                my $check = "${static_dir}/${path}/index.$static_flavours[0]";
234                if ( param('-all') || ! -f $check || stat($check)->mtime < $mtime ) {
235                    $indexes{$path} = 1;
236                    my $dir = join q{/}, (nice_date($mtime))[5,2,3];
237                    $indexes{$dir} = $dir;
238                    $indexes{( $path ? '${path}/' : '' )."${fn}.${file_extension}"} = 1
239                        if ( $static_entries );
240                }
241            }
242
243        },
244        $datadir,
245    );
246
247    return ( \%files, \%indexes, \%others, );
248};
249
250# Plugins: Entries
251# Allow for the first encountered plugin::entries subroutine to override the
252# default built-in entries subroutine
253overwrite_sub('entries');
254
255my ( $files, $indexes, $others ) = $entries->();
256%indexes = %{ $indexes };
257
258# Static
259if ( $static_or_dynamic eq 'static' ) {
260    print "Blosxom is generating static index pages...\n" if ( ! param('-quiet') );
261
262    # Home Page and Directory Indexes
263    my %done;
264    for my $item ( sort keys %indexes ) {
265        my $path = q{};
266        for ( '', split m{/+}, $item ) {
267            $path .= "/$_";
268            $path =~ s{^/}{};
269            $done{$path}++ and next;
270            if ( ! -d "${static_dir}/${path}" && $path !~ m{\.$file_extension$} ) {
271                mkdir "${static_dir}/${path}", 0755;
272            }
273            for $flavour ( @static_flavours ) {
274                my $content_type = $template->( $path, 'content_type', $flavour );
275                   $content_type =~ s{\n.*}{}s;
276                my $fn = ( $path =~ m{^(.+)\.$file_extension} ) ? $1 : "${path}/index" ;
277                print "${fn}.${flavour}\n" if ( ! param('-quiet') );
278                $fh->open( "${static_dir}/${fn}.${flavour}", '>' )
279                    or die "Couldn't open ${static_dir}/${path} for writing: $!";
280                $output = q{};
281                # dir, entry
282                if ( $indexes{$path} == 1 ) {
283                    $path_info = $path;
284                    $path_info =~ s{\.$file_extension}{.$flavour};
285                    print $fh &generate('static', $path_info, '', $flavour, $content_type);
286                }
287                # date
288                else {
289                    local ( $path_info_yr, $path_info_mo, $path_info_da, $path_info )
290                        = split m{/+}, $path, 4;
291                    $path_info = q{} if ( ! defined $path_info );
292                    print $fh &generate('static', '', $path, $flavour, $content_type );
293                }
294                $fh->close;
295            }
296        }
297    }
298}
299# Dynamic
300else {
301    my $content_type = $template->( $path_info, 'content_type', $flavour );
302       $content_type =~ s{\n.*}{}s;
303
304    $header = { -type => $content_type };
305
306    print generate('dynamic', $path_info, "$path_info_yr/$path_info_mo_num/$path_info_da", $flavour, $content_type);
307}
308
309# Plugins: End
310run_plugins('end');
311
312# Generate
313sub generate {
314    my ( $static_or_dynamic, $currentdir, $date, $flavour, $content_type ) = @_;
315
316    %files = %{ $files };
317    %others = ref $others ? %{ $others } : ();
318
319    # Plugins: Filter
320    run_plugins( filter => \%files, \%others );
321
322    my %f = %files;
323
324    # Plugins: Skip
325    # Allow plugins to decide if we can cut short story generation
326    my $skip;
327    if ( defined( my $flag = run_plugins_first('skip') ) ) {
328        $skip = $flag;
329    }
330
331    # Define default interpolation subroutine
332    $interpolate = sub {
333        package blosxom;
334        my $tmpl = shift;
335        $tmpl =~ s{(\$\w+(?:::)?\w*)}{"defined $1 ? $1 : ''"}gee;
336        return $tmpl;
337    };
338
339    if ( ! defined $skip || ! $skip ) {
340        # Plugins: Interpolate
341        # Allow for the first encountered plugin::interpolate subroutine to
342        # override the default built-in interpolate subroutine
343        overwrite_sub('interpolate');
344
345        # Head
346        my $head = $template->( $currentdir, 'head', $flavour ); 
347        # Plugins: Head
348        run_plugins( head => $currentdir, \$head );
349        $head = $interpolate->($head);
350        $output .= $head;
351       
352        # Stories
353        my $curdate = q{};
354        my $ne      = $num_entries;
355        if ( $currentdir =~ m{(.*?)([^/]+)\.(.+)$} && $2 ne 'index' ) {
356            $currentdir = "$1$2.$file_extension";
357            my $fullpath = "${datadir}/${currentdir}";
358            %f = ( $fullpath => $files{$fullpath} ) if ( $files{$fullpath} );
359        }
360        else {
361            $currentdir =~ s{/index\..+$}{};
362        }
363
364        # Define a default sort subroutine
365        my $sort = sub {
366            my ( $files_ref ) = @_;
367            return sort { $files_ref->{$b} <=> $files_ref->{$a} } keys %{ $files_ref };
368        };
369        # Plugins: Sort
370        # Allow for the first encountered plugin::sort subroutine to override the
371        # default built-in sort subroutine
372        if ( defined( my $sub = run_plugins_first('sort') ) ) {
373            $sort = $sub;
374        }
375
376        for my $path_file ( $sort->( \%f, \%others ) ) {
377            last if ( $ne <= 0 && $date !~ /\d/ );
378            use vars qw( $path $fn );
379            ( $path, $fn )
380                = ( $path_file =~ m{^$datadir/(?:(.*)/)?(.*)\.$file_extension} );
381            $path ||= q{};
382            # Only stories in the right hierarchy
383            if ( $path !~ m{^$currentdir} && $path_file ne "${datadir}/${currentdir}" ) {
384                next;
385            }
386           
387            # Prepend a slash for use in templates only if a path exists
388            $path &&= "/$path";
389
390            # Date fiddling for by-{year,month,day} archive views
391            use vars qw/ $dw $mo $mo_num $da $ti $yr $hr $min $hr12 $ampm /;
392            ( $dw, $mo, $mo_num, $da, $ti, $yr ) = nice_date( $files{"$path_file"} );
393            ( $hr, $min) = split m{:}, $ti;
394            ( $hr12, $ampm ) = ( $hr >= 12 ) ? ( $hr - 12,'pm' ) : ( $hr, 'am' ) ;
395            $hr12 =~ s{^0}{};
396            $hr12 = 12 if ( $hr12 == 0 );
397
398            # Only stories from the right date
399            my ( $path_info_yr, $path_info_mo_num, $path_info_da ) = split m{/+}, $date;
400            next if ( $path_info_yr && $yr != $path_info_yr );
401            last if ( $path_info_yr && $yr < $path_info_yr );
402            next if ( $path_info_mo_num && $mo ne $num2month[$path_info_mo_num] );
403            next if ( $path_info_da && $da != $path_info_da );
404            last if ( $path_info_da && $da < $path_info_da );
405
406            # Date
407            my $date = $template->( $path, 'date', $flavour );
408
409            # Plugins: Date
410            run_plugins( date => $currentdir, \$date, $files{$path_file}, $dw, $mo, $mo_num, $da, $ti, $yr );
411            $date = $interpolate->($date);
412
413            if ( $curdate ne $date ) {
414                $curdate = $date;
415                $output .= $date;
416            }
417
418            use vars qw( $title $body $raw );
419            if ( -f $path_file && $fh->open( $path_file, '<' ) ) {
420                chomp( $title   = <$fh> );
421                chomp( $body    = do { local $/; <$fh> } );
422                $fh->close;
423                $raw = "${title}\n{$body}";
424            }
425            my $story = $template->( $path, 'story', $flavour );
426
427            # Plugins: Story
428            run_plugins( story => $path, $fn, \$story, \$title, \$body );
429
430            if ( $content_type =~ m{\bxml\b} ) {
431                # Escape <, >, and &, and to produce valid RSS
432                my %escape = (
433                    '<' => '&lt;',
434                    '>' => '&gt;',
435                    '&' => '&amp;',
436                    '"' => '&quote;',
437                    "'" => '&apos;',
438                );
439                my $escape_re = join '|', keys %escape;
440                for ( $title, $body ) {
441                    $_ =~ s{($escape_re)}{$escape{$1}}g;
442                }
443            }
444
445            $story   = $interpolate->( $story );
446            $output .= $story;
447            $ne--;
448        }
449 
450        # Foot
451        my $foot = $template->( $currentdir, 'foot', $flavour );
452 
453        # Plugins: Foot
454        run_plugins( foot => $currentdir, \$foot );
455        $foot    = $interpolate->( $foot );
456        $output .= $foot;
457
458        # Plugins: Last
459        run_plugins('last');
460    }# End skip
461
462    # Finally, add the header, if any and running dynamically
463    $output = header( $header ) . $output
464        if ( $static_or_dynamic eq 'dynamic' && $header );
465    return $output;
466}
467
468sub run_plugins {
469    my ( $method, @args ) = @_;
470
471    for my $plugin ( @plugins ) {
472        if ( $plugins{$plugin} > 0 && $plugin->can($method) ) {
473            $entries = $plugin->$method( @args );
474        }
475    }
476}
477
478sub run_plugins_first {
479    my ( $method, @args ) = @_;
480
481    for my $plugin ( @plugins ) {
482        if (    $plugins{$plugin} > 0
483                && $plugin->can($method)
484                && defined( my $ret = $plugin->$method( @args ) )   ) {
485            return $ret;
486        }
487    }
488
489    return;
490}
491
492sub overwrite_sub {
493    my ( $method, @args ) = @_;
494
495    if ( defined( my $sub = run_plugins_first( $method => @args ) ) ) {
496        die "Return value of plugin is not CODE reference: method:$method"
497            if ( ref $sub ne 'CODE' );
498        no strict 'refs';
499        ${"${method}"} = $sub;
500    }
501}
502
503sub nice_date {
504    my ( $unixtime ) = @_;
505
506    my $ctime = ctime($unixtime);
507    my ( $dw, $mo, $da, $ti, $yr )
508        = ( $ctime =~ m{(\w{3})[ ]+(\w{3})[ ]+(\d{1,2})[ ]+(\d{2}:\d{2}):\d{2}[ ]+(\d{4})$} );
509    $da = sprintf('%02d', $da);
510    my $mo_num = $month2num{$mo};
511
512    return ( $dw, $mo, $mo_num, $da, $ti, $yr );
513}
514
515sub env_value {
516    my $prefix = uc __PACKAGE__;
517    my $key    = uc( shift @_ );
518
519    my $env = "${prefix}_${key}";
520
521    if ( exists $ENV{$env} ) {
522        return $ENV{$env};
523    }
524    return;
525}
526
527# Default HTML and RSS template bits
528__DATA__
529html content_type text/html
530
531html head <html>
532html head     <head>
533html head         <link rel="alternate" type="type="application/rss+xml" title="RSS" href="$url/index.rss" />
534html head         <title>$blog_title $path_info_da $path_info_mo $path_info_yr
535html head         </title>
536html head     </head>
537html head     <body>
538html head         <center>
539html head             <font size="+3">$blog_title</font><br />
540html head             $path_info_da $path_info_mo $path_info_yr
541html head         </center>
542html head         <p />
543
544html story        <p>
545html story            <a name="$fn"><b>$title</b></a><br />
546html story            $body<br />
547html story            <br />
548html story            posted at: $ti | path: <a href="$url$path">$path </a> | <a href="$url/$yr/$mo_num/$da#$fn">permanent link to this entry</a>
549html story        </p>
550
551html date         <h3>$dw, $da $mo $yr</h3>
552
553html foot
554html foot         <p />
555html foot         <center>
556html foot             <a href="http://www.blosxom.com/"><img src="http://www.blosxom.com/images/pb_blosxom.gif" border="0" /></a>
557html foot         </center>
558html foot     </body>
559html foot </html>
560
561rss content_type text/xml
562
563rss head <?xml version="1.0"?>
564rss head <!-- name="generator" content="blosxom/$version" -->
565rss head <!DOCTYPE rss PUBLIC "-//Netscape Communications//DTD RSS 0.91//EN" "http://my.netscape.com/publish/formats/rss-0.91.dtd">
566rss head
567rss head <rss version="0.91">
568rss head   <channel>
569rss head     <title>$blog_title $path_info_da $path_info_mo $path_info_yr</title>
570rss head     <link>$url</link>
571rss head     <description>$blog_description</description>
572rss head     <language>$blog_language</language>
573
574rss story   <item>
575rss story     <title>$title</title>
576rss story     <link>$url/$yr/$mo_num/$da#$fn</link>
577rss story     <description>$body</description>
578rss story   </item>
579
580rss date
581
582rss foot   </channel>
583rss foot </rss>
584
585error content_type text/html
586
587error head <html>
588error head <body>
589error head     <p><font color="red">Error: I'm afraid this is the first I've heard of a "$flavour" flavoured Blosxom.  Try dropping the "/+$flavour" bit from the end of the URL.</font>
590
591
592error story <p><b>$title</b><br />
593error story $body <a href="$url/$yr/$mo_num/$da#fn.$default_flavour">#</a></p>
594
595error date <h3>$dw, $da $mo $yr</h3>
596
597error foot     </body>
598error foot </html>
599__END__
600
601=head1 AUTHOR
602
603Original script by Rael Dornfest
604
605Based on blosxom 2.0.2 in SourceForge.net
606
607Modified by Naoki Okamura (Nyarla) E<lt>thotep@nyarla.netE<gt>
Note: See TracBrowser for help on using the browser.