Back to home page
Get LXR Cross Referencer at SourceForge.net. Fast, secure and Free Open Source software downloads

LXR self cross-referenced (under SQLite)

 
 

    


File indexing completed on 2017-05-02 17:45:25

0001 #!/usr/bin/perl -T
0002 ######################################################################
0003 #
0004 # source -- Present sourcecode as html, complete with references
0005 #  the '/icons' images are available in any standard Apache installation
0006 #
0007 #   Arne Georg Gleditsch <argggh@ifi.uio.no>
0008 #   Per Kristian Gjermshus <pergj@ifi.uio.no>
0009 #
0010 #
0011 # This program is free software; you can redistribute it and/or modify
0012 # it under the terms of the GNU General Public License as published by
0013 # the Free Software Foundation; either version 2 of the License, or
0014 # (at your option) any later version.
0015 #
0016 # This program is distributed in the hope that it will be useful,
0017 # but WITHOUT ANY WARRANTY; without even the implied warranty of
0018 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
0019 # GNU General Public License for more details.
0020 #
0021 # You should have received a copy of the GNU General Public License
0022 # along with this program; if not, write to the Free Software
0023 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
0024 #
0025 ######################################################################
0026 
0027 use strict;
0028 use lib do { $0 =~ m{(.*)/} ? "$1/lib" : 'lib' };  # if LXR modules are in ./lib
0029 
0030 =head1 source script
0031 
0032 This script manages navigation across the source-tree and individual
0033 file display.
0034 
0035 =cut
0036 
0037 use LXR::Common;
0038 use LXR::Markup;
0039 use LXR::Template;
0040 use Local;
0041 
0042 
0043 =head2 C<iconlink ($html_elt, $path)>
0044 
0045 Internal function C<iconlink> is a support routine for
0046 C<diricon> and C<fileicon>.
0047 It works around the protection implemented in C<fileref>
0048 which prevents from inserting HTML elements in the "description".
0049 
0050 =over
0051 
0052 =item 1
0053 
0054 C<$templ>
0055 
0056 a I<string> containing the HTML element without delimiters
0057 
0058 =item 2
0059 
0060 C<$path>
0061 
0062 a I<string> containing the path of the icon file
0063 
0064 =back
0065 
0066 Custom delimiters are added to the HTML element
0067 which is transformed into a file link by C<fileref>.
0068 The custom delimiters are replaced by standard HTML
0069 delimiters in the returned link which is then sent back
0070 to caller.
0071 
0072 =cut
0073 
0074 sub iconlink {
0075     my ($html_elt, $path) = @_;
0076     my $link = fileref
0077                 ( "\0S$html_elt\0E"
0078                 , ''
0079                 , $path
0080                 );
0081     $link =~ s/\0S/</g; # Starting delimiter
0082     $link =~ s/\0E/>/g; # Ending delimiter
0083     return $link;
0084 }
0085 
0086 
0087 =head2 C<diricon ($templ, $node, $dir)>
0088 
0089 Function C<diricon> is a "$variable" substitution function.
0090 It returns an HTML-string containing an C<E<lt> A E<gt>> block
0091 surrounding an C<E<lt> IMG E<gt>> tag for a folder icon.
0092 The link allows to jump to the directory.
0093 
0094 =over
0095 
0096 =item 1
0097 
0098 C<$templ>
0099 
0100 a I<string> containing the template (empty for a "variable")
0101 
0102 =item 2
0103 
0104 C<$node>
0105 
0106 a I<string> containing the name of the directory
0107 
0108 =item 3
0109 
0110 C<$dir>
0111 
0112 a I<string> containing the name of the parent directory
0113 
0114 =back
0115 
0116 If parameters C<'iconfolder'> and C<'diricon'> have been defined,
0117 use the designated icon; otherwise revert to the default Apache icon.
0118 
0119 =cut
0120 
0121 sub diricon {
0122     my ($templ, $node, $dir) = @_;
0123     my $img;
0124 
0125     if ($node eq '../') {
0126         if  (exists $config->{'iconfolder'}
0127             &&  exists $config->{'parenticon'}
0128             ) {
0129             $img = $config->{'iconfolder'} . $config->{'parenticon'};
0130         } else {
0131             $img = '/icons/back.gif';
0132         }
0133     } else {
0134         if  (exists $config->{'iconfolder'}
0135             &&  exists $config->{'diricon'}
0136             ) {
0137             $img = $config->{'iconfolder'} . $config->{'diricon'};
0138         } else {
0139             $img = '/icons/folder.gif';
0140         }
0141     }
0142 
0143     return iconlink
0144                 ( "img src=\"$img\" alt=\"folder\""
0145                 , $dir . $node
0146                 );
0147 }
0148 
0149 
0150 =head2 C<dirname ($templ, $node, $dir)>
0151 
0152 Function C<dirname> is a "$variable" substitution function.
0153 It returns an HTML-string containing an C<E<lt> A E<gt>> tag
0154 linking to the directory.
0155 
0156 =over
0157 
0158 =item 1
0159 
0160 C<$templ>
0161 
0162 a I<string> containing the template (empty for a "variable")
0163 
0164 =item 2
0165 
0166 C<$node>
0167 
0168 a I<string> containing the name of the directory
0169 
0170 =item 3
0171 
0172 C<$dir>
0173 
0174 a I<string> containing the name of the parent directory
0175 
0176 =back
0177 
0178 =cut
0179 
0180 sub dirname {
0181     my ($templ, $node, $dir) = @_;
0182 
0183     if ($node eq '../') {
0184         return fileref('Parent directory', 'dirfolder', $dir . $node);
0185     } else {
0186         return fileref($node, 'dirfolder', $dir . $node);
0187     }
0188 }
0189 
0190 
0191 =head2 C<fileicon ($templ, $node, $dir)>
0192 
0193 Function C<fileicon> is a "$variable" substitution function.
0194 It returns an HTML-string containing an C<E<lt> A E<gt>> block
0195 surrounding an C<E<lt> IMG E<gt>> tag for a file icon.
0196 The link allows to jump to the file.
0197 
0198 =over
0199 
0200 =item 1
0201 
0202 C<$templ>
0203 
0204 a I<string> containing the template (empty for a "variable")
0205 
0206 =item 2
0207 
0208 C<$node>
0209 
0210 a I<string> containing the name of the file
0211 
0212 =item 3
0213 
0214 C<$dir>
0215 
0216 a I<string> containing the name of the parent directory
0217 
0218 =back
0219 
0220 If parameters C<'iconfolder'> and various icon descriptors have been defined,
0221 use the designated icon; otherwise revert to the default Apache icon.
0222 
0223 =cut
0224 
0225 sub fileicon {
0226     my ($templ, $node, $dir) = @_;
0227     my $img;
0228     my $link;
0229     my $graphic = $config->{'graphicfile'};
0230     my $icons = $config->{'icons'};
0231 
0232     if (exists $config->{'iconfolder'}) {
0233         if ($node =~ m/(\.([^.]+)?)$/) {
0234             my $ext = $2;
0235 
0236             while (my ($pat, $iconfile) = each %$icons) {
0237                 if ($ext =~ m/^($pat)$/i) {
0238                     $img = $config->{'iconfolder'} . $iconfile;
0239                     keys %$icons;   # reset iterator
0240                     return iconlink
0241                             ( "img src=\"$img\" alt=\"file\""
0242                             , $dir . $node
0243                             );
0244                 }
0245             }
0246             if ($ext =~ m/^($graphic)$/) {
0247                 return iconlink
0248                             ( 'img src="'
0249                                 . $config->{'iconfolder'}
0250                                 . $config->{'graphicicon'}
0251                                 . "\" alt=\"graphic file\""
0252                             , $dir . $node);
0253             }
0254         }
0255 
0256         return iconlink ( 'img src="'
0257                             . $config->{'iconfolder'}
0258                             . $config->{'defaulticon'}
0259                             . '" alt="file"'
0260                         , $dir . $node
0261                         );
0262     }
0263 
0264 # Fallback to some generally universally available icons
0265 # in case the above feature is not defined
0266 # but they are usually not appealing.
0267     if (!defined $img) {
0268         if ($node =~ /\.[ch]$/) {
0269             $img = '/icons/c.gif';
0270         } elsif ($node =~ /\.(cpp|cc|java)$/) {
0271             $img = '/icons/c.gif';
0272         } elsif (substr($node, -4) eq '.txt') {
0273             $img = '/icons/text.gif';
0274         } elsif ($node =~ /\.(jar|war|ear|zip|tar|gz|tgz|cab)$/) {
0275             $img = '/icons/compressed.gif';
0276         } elsif ($node =~ /\.($graphic)$/) {
0277             $img = '/icons/image2.gif';
0278         } else {
0279             $img = '/icons/generic.gif';
0280         }
0281     }
0282     return iconlink ( "img src=\"$img\" alt=''",
0283                     , $dir . $node
0284                     );
0285 }
0286 
0287 
0288 =head2 C<filename ($templ, $node, $dir)>
0289 
0290 Function C<filename> is a "$variable" substitution function.
0291 It returns a HTML-string containing an C<E<lt> A E<gt>> tag
0292 linking to the file.
0293 
0294 =over
0295 
0296 =item 1
0297 
0298 C<$templ>
0299 
0300 a I<string> containing the template (empty for a "variable")
0301 
0302 =item 2
0303 
0304 C<$node>
0305 
0306 a I<string> containing the name of the file
0307 
0308 =item 3
0309 
0310 C<$dir>
0311 
0312 a I<string> containing the name of the parent directory
0313 
0314 =back
0315 
0316 =cut
0317 
0318 sub filename {
0319     my ($templ, $node, $dir) = @_;
0320     return fileref($node, 'dirfile', $dir . $node);
0321 }
0322 
0323 
0324 =head2 C<filesize ($templ, $node, $dir)>
0325 
0326 Function C<filesize> is a "$function" substitution function.
0327 It returns its expanded argument, inserting the file size
0328 where appropriate.
0329 
0330 =over
0331 
0332 =item 1
0333 
0334 C<$templ>
0335 
0336 a I<string> containing the template (i.e. the function argument)
0337 
0338 =item 2
0339 
0340 C<$node>
0341 
0342 a I<string> containing the name of the file
0343 
0344 =item 3
0345 
0346 C<$dir>
0347 
0348 a I<string> containing the name of the parent directory
0349 
0350 =back
0351 
0352 In the present implementation, specifying a size unit in the
0353 argument makes no difference. The size is "scaled" according
0354 to its textual length.
0355 
0356 =cut
0357 
0358 sub filesize {
0359     my ($templ, $node, $dir) = @_;
0360 
0361     my $s = $files->getfilesize($dir . $node, $releaseid);
0362     my $str;
0363 
0364     $str = $s . ' ';
0365     if (length($s) > 6) {
0366         $s >>= 10;
0367         $str = ${s} . 'ki';
0368         if (length($s) > 7) {
0369             $s >>= 10;
0370             $str = ${s} . 'Mi';
0371         }
0372     }
0373 #   if ($s < 1 << 10) {
0374 #       $str = "$s";
0375 #   } else {
0376 # 
0377 #       #      if ($s < 1<<20) {
0378 #       $str = ($s >> 10) . "k";
0379 # 
0380 #       #      } else {
0381 #       #          $str = ($s>>20) . "M";
0382 #       #      }
0383 #   }
0384     return expandtemplate(
0385         $templ,
0386         (
0387             'bytes'  => sub { return $str },
0388             'kbytes' => sub { return $str },
0389             'mbytes' => sub { return $str }
0390         )
0391     );
0392 }
0393 
0394 
0395 =head2 C<modtime ($templ, $node, $dir)>
0396 
0397 Function C<modtime> is a "$variable" substitution function.
0398 It returns a human-readable date/time string for the file
0399 last-modification date.
0400 
0401 =over
0402 
0403 =item 1
0404 
0405 C<$templ>
0406 
0407 a I<string> containing the template (empty for a "variable")
0408 
0409 =item 2
0410 
0411 C<$node>
0412 
0413 a I<string> containing the name of the file
0414 
0415 =item 3
0416 
0417 C<$dir>
0418 
0419 a I<string> containing the name of the parent directory
0420 
0421 =back
0422 
0423 The last-modification date is extracted from the database.
0424 
0425 =cut
0426 
0427 sub modtime {
0428     my ($templ, $node, $dir) = @_;
0429 
0430     my $file_time = $files->getfiletime($dir . $node, $releaseid);
0431     return '-' unless defined($file_time);
0432     return _edittime($file_time);
0433 }
0434 
0435 
0436 =head2 C<indextime ($templ, $node, $dir)>
0437 
0438 Function C<indextime> is a "$variable" substitution function.
0439 It returns a human-readable date/time string for the file
0440 indexation date by I<genxref>.
0441 
0442 =over
0443 
0444 =item 1
0445 
0446 C<$templ>
0447 
0448 a I<string> containing the template (empty for a "variable")
0449 
0450 =item 2
0451 
0452 C<$node>
0453 
0454 a I<string> containing the name of the file
0455 
0456 =item 3
0457 
0458 C<$dir>
0459 
0460 a I<string> containing the name of the parent directory
0461 
0462 =back
0463 
0464 The indexation date is extracted from the database.
0465 
0466 If it does not exist (file was never indexed or modified
0467 since indexation), a single dash is return.
0468 
0469 =cut
0470 
0471 sub indextime {
0472     my ($templ, $node, $dir) = @_;
0473 
0474     my $index_time = $index->filetimestamp
0475                         ( $dir . $node
0476                         , $files->filerev($dir . $node, $releaseid)
0477                         );
0478     return '-' if !$index_time;
0479     return _edittime($index_time);
0480 }
0481 
0482 
0483 =head2 C<descexpand ($templ, $node, $dir, $releaseid)>
0484 
0485 Function C<descexpand> is a "$function" substitution function.
0486 It returns a short description for a file or a subdirectory
0487 in a directory listing.
0488 If no description can be extracted, the called support routines
0489 MUST return the string "&nbsp;" to keep the table looking pretty.
0490 
0491 =over
0492 
0493 =item 1
0494 
0495 C<$templ>
0496 
0497 a I<string> containing the template (empty for a "variable")
0498 
0499 =item 2
0500 
0501 C<$node>
0502 
0503 a I<string> containing the name of the file
0504 
0505 =item 3
0506 
0507 C<$dir>
0508 
0509 a I<string> containing the name of the parent directory
0510 
0511 =item 4
0512 
0513 C<$releaseid>
0514 
0515 a I<string> containing the version name
0516 
0517 Presently, not used.
0518 
0519 =back
0520 
0521 Control is passed to custom function located in F<Local.pm>.
0522 
0523 =cut
0524 
0525 sub descexpand {
0526     my ($templ, $node, $dir, $releaseid) = @_;
0527     if (substr($node, -1) eq '/') {
0528         return expandtemplate
0529             ( $templ
0530             , ('desctext' => sub { return dirdesc($dir . $node, $releaseid); }
0531               )
0532             );
0533     } elsif (LXR::Lang::parseable($dir.$node, $releaseid)) {
0534         return expandtemplate
0535             ( $templ
0536             , ('desctext' => sub { return filedesc($node, $dir, $releaseid); }
0537               )
0538             );
0539     } else {
0540         return '&nbsp;';
0541     }
0542 }
0543 
0544 
0545 =head2 C<rowclass ($templ, $line)>
0546 
0547 Function C<indextime> is a "$variable" substitution function.
0548 It returns a CSS class name depending on line parity.
0549 
0550 =over
0551 
0552 =item 1
0553 
0554 C<$templ>
0555 
0556 a I<string> containing the template (empty for a "variable")
0557 
0558 =item 2
0559 
0560 C<$line>
0561 
0562 an I<integer> containing the line number of the display
0563 
0564 =back
0565 
0566 =cut
0567 
0568 sub rowclass {
0569     my ($templ, $line) = @_;
0570     return ((($line - 1) / 3) % 2) ? 'dirrow2' : 'dirrow1';
0571 }
0572 
0573 
0574 =head2 C<direxpand ($templ, $dir)>
0575 
0576 Function C<direxpand> is a "$function" substitution function.
0577 It returns its template argument expanded for every node in
0578 the directory.
0579 
0580 =over
0581 
0582 =item 1
0583 
0584 C<$templ>
0585 
0586 a I<string> containing the template
0587 
0588 =item 2
0589 
0590 C<$dir>
0591 
0592 a I<string> containing the directory name
0593 
0594 =back
0595 
0596 The directory content is obtained from the storage engine.
0597 
0598 The template is expanded depending on the nature of the node,
0599 file or directory, because processing of the nested substitutions
0600 is slightly different in each case.
0601 
0602 =cut
0603 
0604 sub direxpand {
0605     my ($templ, $dir) = @_;
0606     my $direx = '';
0607     my $line  = 1;
0608     my %index;
0609     my @nodes;
0610     my $node;
0611 
0612 #   Since CVS does not manage directory version,
0613 #   ensure we always request 'head' for directories.
0614     @nodes = $files->getdir
0615         ( $dir
0616         , $files->isa('LXR::Files::CVS')
0617             ? 'head'
0618             : $releaseid
0619         );
0620     unless (@nodes) {
0621         print(  "<p class=\"error\">\n<i>The directory " . $dir
0622               . " does not exist, is empty or is hidden by an exclusion rule.</i>\n</p>\n");
0623         if  (  $files->isa('LXR::Files::CVS')
0624             && !$HTTP->{'param'}{'_showattic'}
0625             ) {
0626             print("<p class=\"error\">\n");
0627             print("<i>This directory might exist in other versions,");
0628             print   ( " try 'Show attic files' or select a different",
0629                     , $config->{'variables'}{'v'}{'name'}
0630                     , ".</i>\n"
0631                     );
0632             print("</p>\n");
0633         }
0634         return;
0635     }
0636 
0637     unshift(@nodes, '../') unless $dir eq '/';
0638     foreach $node (@nodes) {
0639         if (substr($node, -1) eq '/') {
0640             $direx .= expandtemplate
0641                 (   $templ
0642                 ,   ( 'iconlink' => sub { diricon(@_, $node, $dir) }
0643                     , 'namelink' => sub { dirname(@_, $node, $dir) }
0644                     , 'filesize' => sub { '-' }
0645                     , 'modtime'  => sub { modtime(@_, $node, $dir) }
0646                     , 'indextime'=> sub { '' }
0647                     , 'dirclass' => sub { rowclass(@_, $line++) }
0648                     , 'dirindexclass' => sub { 'dirindex' }
0649                     , 'description' =>
0650                         sub { descexpand(@_, $node, $dir, $releaseid) }
0651                     )
0652                 );
0653         } else {
0654             $direx .= expandtemplate
0655                 (   $templ
0656                 ,   ( 'iconlink'    => sub { fileicon(@_, $node, $dir) }
0657                     , 'namelink'    => sub { filename(@_, $node, $dir) }
0658                     , 'filesize'    => sub { filesize(@_, $node, $dir) }
0659                     , 'modtime'     => sub { modtime(@_,  $node, $dir) }
0660                     , 'indextime'   => sub {
0661                         my $t = indextime(@_,  $node, $dir);
0662                         if ('-' eq $t) {
0663                             if (LXR::Lang::parseable($dir.$node, $releaseid)) {
0664                                 return 'Not valid'
0665                             };
0666                             return '-';
0667                         }
0668                         $t }
0669                     , 'dirclass'    => sub { rowclass(@_, $line++) }
0670                     , 'dirindexclass' =>
0671                         sub {   if  (   !$index->filetimestamp
0672                                             ( $dir.$node
0673                                             , $files->filerev
0674                                                 ( $dir.$node
0675                                                 , $releaseid
0676                                                 )
0677                                             )
0678                                     &&  LXR::Lang::parseable($dir.$node, $releaseid)
0679                                     ) {
0680                                     'dirindexinvalid'
0681                                 } else {
0682                                     'dirindex'
0683                                 }
0684                             }
0685                     , 'description' => sub {
0686                         ( $files->isa('LXR::Files::CVS')
0687                                 && 0 <= index   ( $files->toreal($dir . $node, $releaseid)
0688                                                 , 'Attic'
0689                                                 )
0690                             ? '<i>In Attic</i>  '
0691                             : ''
0692                         ) . descexpand(@_, $node, $dir, $releaseid);
0693                         }
0694                     )
0695                 );
0696         }
0697     }
0698     return ($direx);
0699 }
0700 
0701 
0702 =head2 C<printdir ($dir)>
0703 
0704 Procedure C<printdir> retrieves the C<'htmldir'> template
0705 and launches template expansion.
0706 
0707 =over
0708 
0709 =item 1
0710 
0711 C<$dir>
0712 
0713 a I<string> containing the directory name
0714 
0715 =back
0716 
0717 The procedure dispatches to C<dirdesc> (located in
0718 I<Local.pm>) for a description of the directory and
0719 to C<direxpand> for content edition.
0720 
0721 =cut
0722 
0723 sub printdir {
0724     my $dir = shift;
0725     my $templ;
0726 
0727     $templ = gettemplate
0728                 ( 'htmldir'
0729                 , "<ul>\n\$files{\n<li>\$iconlink \$namelink\n}</ul>\n"
0730                 );
0731 
0732     # print the listing itself
0733     print(expandtemplate
0734             ( $templ
0735             ,   ( 'files' => sub { direxpand(@_, $dir) }
0736                 , 'description' => sub { dirdesc($dir, $releaseid) }
0737                 , 'indexstate'  => sub { displayindexstate('source') }
0738                 )
0739             )
0740     );
0741 }
0742 
0743 
0744 =head2 C<next_annot ($currev, $r, $bg)>
0745 
0746 Function C<next_annot> returns an HTML C<E<lt> SPAN E<gt>> block
0747 containing revision and author information for the next file line.
0748 
0749 =over
0750 
0751 =item 1
0752 
0753 C<$currev>
0754 
0755 a I<string> containing the requested version for the file
0756 
0757 =item 2
0758 
0759 C<$r>
0760 
0761 a I<reference> to a I<string> containing the revision of the previous line
0762 
0763 =item 3
0764 
0765 C<$bg>
0766 
0767 a I<reference> to a flag toggling between 0 and 1
0768 
0769 =back
0770 
0771 I<References allow to keep values between calls.>
0772 
0773 It returns an empty string if the repository manager has no annotation
0774 (either by design, I<e.g.> plain files, or disabled by configuration
0775 parameters).
0776 
0777 The returned block is a blank string if the line is part of the
0778 same change set as the previous line (to have a cleaner screen).
0779 
0780 Revision information is checked for space overflow and eventually
0781 truncated as per repository rule.
0782 
0783 Finally, a CSS class is computed (latest revision or alternating
0784 styles).
0785 
0786 =cut
0787 
0788 sub next_annot {
0789     my ($currev, $r, $bg) = @_;
0790 
0791     # Get annotations from the storage engine and prepare their
0792     # layout in order to prefix every source line with its
0793     # associated annotation.
0794     my $rev = $files->getnextannotation($pathname, $releaseid);
0795     return '' if !defined($rev);
0796     my $auth = $files->getauthor($pathname, $releaseid, $rev);
0797 
0798     if ($rev eq $$r) {
0799         $rev = ' ' x 16;
0800         if ($$r eq $currev) {
0801             $rev = "<span class='annot-cur'>$rev</span>";
0802         } else {
0803             $rev = "<span class='annot$$bg'>$rev</span>";
0804         }
0805         return $rev;
0806     }
0807 
0808     $$r = $rev;
0809     # NOTE: modern VCSes return their annotations in Unicode, but user
0810     # may have requested another display encoding (e.g. ISO-8859-x).
0811     # We don't try to transcode since this may be time-consuming for
0812     # little benefit. We just hope that, on average, truncation will
0813     # not occur too frequently in the middle of an UTF-8 sequence.
0814     # UTF-8-aware length computation and truncation is attempted only
0815     # on author's name. Nothing is done on the revision id because
0816     # it usually does not contain fancy characters (read it is numeric
0817     # with eventual ASCII punctuation). svn allows more freedom in
0818     # revision naming and may conflict with this choice. You'll also
0819     # be in trouble when displaying UTF-8 with CVS returning ISO-8859.
0820     my $la;
0821     my $pat;
0822     if ('utf-8' ne $config->{'encoding'}) {
0823         $la = length($auth);
0824     } else {
0825         use utf8;
0826         $la = length($auth);
0827     };
0828     my $lr = length($rev);
0829     # After this call to length, $rev may be edited to contain
0830     # HTML element and $lr will be different from length($rev).
0831     # $lr reflects the number of character positions necessary
0832     # to display $rev on screen, not its content.
0833     if ($la > 0) {
0834         if ($lr+$la > 15) { # sum of 2 fields too long
0835             if  ( $la > 4
0836                 && $la > 14-$lr
0837                 ) { # truncate first author
0838                 $la = 14 - $lr;
0839                 $la = 4 if $la < 4;
0840                 $auth = pack('(U)'.$la, unpack('U*', $auth));
0841                 $auth .= '<span class="error">*</span>';
0842                 $la++;
0843             }
0844             if ($lr+$la >15) { # now truncate revision
0845                 $lr = 14 - $la;
0846                 $lr = $files->truncateannotation(\$rev, $lr);
0847             }
0848         }
0849         if ($lr+$la < 15) { # some space to distribute
0850             if ($la >= 8) {
0851                 $rev  .= ' ' x (15-$lr-$la);
0852             } elsif ($lr >= 7) {
0853                 $auth .= ' ' x (15-$lr-$la);
0854             } else {
0855                 $rev  .= ' ' x (7-$lr);
0856                 $auth .= ' ' x (8-$la);
0857             }
0858         }
0859         $rev .= ' ' . $auth;
0860     } else {
0861         if ($lr > 16) {
0862             $lr = $files->truncateannotation(\$rev, 15);
0863         } else {
0864             $rev .= ' ' x (16 - $lr);
0865         }
0866     }
0867     if ($$r eq $currev) {
0868         $rev = "<span class='annot-cur'>$rev</span>";
0869     } else {
0870         $$bg = 1 - $$bg;
0871         $rev = "<span class='annot$$bg'>$rev</span>";
0872     }
0873     return $rev;
0874 }
0875 
0876 
0877 =head2 C<printfile ($raw)>
0878 
0879 Procedure C<printfile> is the main driver for node display.
0880 
0881 =over
0882 
0883 =item 1
0884 
0885 C<$raw>
0886 
0887 a I<"boolean"> requesting I<raw mode> if non zero
0888 
0889 =back
0890 
0891 It checks first for a directory described by global variable
0892 C<$pathname> to be handled by C<printdir>.
0893 
0894 In I<raw mode>, source file is output "as is", without any
0895 editing or highlighting.
0896 
0897 Various information related to the source file are retrieved
0898 (last indexation time, VCS annotations, ...). They are checked
0899 and/or prepared for mixed output with source lines.
0900 
0901 If possible, links with other development tools are created
0902 and placed in the resulting HTML page.
0903 
0904 
0905 =cut
0906 
0907 sub printfile {
0908     my $raw = shift;
0909 
0910     if (substr($pathname, -1) eq '/') {
0911         printdir($pathname);
0912     } else {
0913 
0914         # Avoid UTF-8 sanity errors with non-text files
0915         # when tree is stored in a Git repository
0916         if  (   $files->isa('LXR::Files::GIT')
0917             &&  ! LXR::Lang::parseable($pathname, $releaseid)
0918             ) {
0919             $files->{'git-annotations'} = 0;
0920             $files->{'git_blame'} = 0;
0921         }
0922         # Request annotated content (through defined third argument)
0923         my $fileh = $files->getfilehandle($pathname, $releaseid, !$raw);
0924 
0925         if ($fileh) {
0926             if ($raw) {
0927                 print($fileh->getlines );
0928 
0929             #   } elsif ($node =~ /README$/) {
0930             #       print("<pre>",
0931             #             markupstring($fileh, $node, $index), # FIXME
0932             #             "</pre>");
0933             #   }
0934             } else {
0935                 # Check for a discrepancy between file and database states
0936                 if (! LXR::Lang::parseable($pathname, $releaseid)) {
0937                     print(
0938                         "<p class=\"indexstate warning\">\n<i class=error>Warning, </i>$pathname<i class=error> is written in an unsupported language."
0939                         , " File is not indexed.</i>\n</p>\n"
0940                     );
0941                 } else {
0942                     my $t = indextime(@_,  '', $pathname);
0943                     if ('-' eq $t) {
0944                         print(
0945                             "<p class=\"indexstate warning\">\n<i class=error>Warning, file </i>$pathname<i class=error> was not indexed"
0946                             , "\nor was modified since last indexation"
0947                             , " (in which case cross-reference links may be missing, inaccurate or erroneous).</i></p>\n"
0948                         );
0949                     } else {
0950                         print(
0951                             "<p class=indexstate>\nFile indexing completed on $t\n</p>\n"
0952                         );
0953                     }
0954                 }
0955 
0956                 if (exists($config->{'cvswebprefix'})) {
0957                     my $revtarget = '';
0958                     $revtarget = "#rev$releaseid" if lc($releaseid) ne 'head';
0959                     print '<a class="cvsweb" href="'
0960                       . $config->{'cvswebprefix'}
0961                       . $pathname
0962                       . $config->{'cvswebpostfix'}
0963                       . $revtarget
0964                       . '">View CVS Log</a>';
0965                 }
0966 
0967                 # Markup and output the source file
0968                 my $currev = $files->filerev($pathname, $releaseid);
0969                 my $bg = 1;
0970                 my $oldrev;
0971                 my $outfun = sub {
0972                     my $l;
0973                     $l = shift;
0974                     $l =~ s/(\n)/$1.next_annot($currev, \$oldrev, \$bg)/ge;
0975                     print $l;
0976                 };
0977                 print '<pre class="filecontent">';
0978                 markupfile($fileh, $outfun);
0979                 print "</pre>\n";
0980             }
0981         } else {
0982             print(
0983                 "<p class=\"error\">\n<i>The file $pathname does not exist.</i>\n</p>\n"
0984             );
0985             if  (  $files->isa('LXR::Files::CVS')
0986                 && !$HTTP->{'param'}{'_showattic'}
0987                 ) {
0988                 print("<p class=\"error\">\n");
0989                 print('<i>This file might exist in other versions,');
0990                 print   ( ' try \'Show attic files\' or select a different',
0991                         , $config->{'variables'}{'v'}{'name'}
0992                         , ".</i>\n"
0993                         );
0994                 print("</p>\n");
0995             }
0996         }
0997     }
0998 }
0999 
1000 
1001 =head2 Script entry point
1002 
1003 Selects the correct header and footer and launches C<printfile>
1004 for the real job.
1005 
1006 =cut
1007 
1008 httpinit;
1009 std_http_headers('source');
1010 
1011 if (exists($config->{'filter'}) && $pathname !~ $config->filter) {
1012     makeheader('source');
1013     print("<p class=\"error\">\n<i>Filename $pathname is discarded by the present <code>'filter'</code> rule.</i>\n</p>\n");
1014     makefooter('source');
1015     exit;
1016 }
1017 
1018 # Formerly, if the file was html, it was sent out as is.
1019 # Now, since we want to parse HTML files too, use URL parameter _raw
1020 # to interpret it through the browser, the same as for other files.
1021 if ($HTTP->{'param'}{'_raw'}) {
1022     printfile(1);
1023 } else {
1024     my $type = ((substr($pathname, -1) ne '/') ? 'source' : 'sourcedir');
1025 
1026     makeheader($type);
1027     printfile(0);
1028     makefooter($type);
1029 }
1030 
1031 httpclean;