home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / Debian / DocBase / DocBaseFile.pm < prev    next >
Encoding:
Perl POD Document  |  2009-01-05  |  13.7 KB  |  476 lines
  1. # vim:cindent:ts=2:sw=2:et:fdm=marker:cms=\ #\ %s
  2. #
  3. # $Id: DocBaseFile.pm 171 2009-01-05 21:25:22Z robert $
  4. #
  5.  
  6. package Debian::DocBase::DocBaseFile;
  7.  
  8. use strict;
  9. use warnings;
  10.  
  11.  
  12. use File::Glob ':glob';
  13. use Debian::DocBase::Common;
  14. use Debian::DocBase::Utils;
  15. use Scalar::Util qw(weaken);
  16. use Carp;
  17.  
  18. our %CONTROLFILES = ();
  19.  
  20.  
  21. # constants for _PrsErr function
  22. use constant PRS_FATAL_ERR    => 1;   # fatal error, marks documents as invalid
  23. use constant PRS_ERR_IGN      => 2;   # error, marks documents as invalid
  24. use constant PRS_WARN         => 3;   # warning, marks document as invalid
  25.  
  26. my %valid_sections = ();
  27.  
  28. #################################################
  29. ###        PUBLIC STATIC FUNCTIONS            ###
  30. #################################################
  31.  
  32. sub GetDocIdFromRegisteredFile($) { # {{{
  33.   my $file = shift;
  34.   my $data = Debian::DocBase::DB::GetFilesDB()->GetData($file);
  35.   return undef unless $data;
  36.   return $data->{'ID'};
  37. } # }}}
  38.  
  39. sub GetAllDocBaseFiles() { # {{{
  40.   my @global = ();
  41.   my @local  = ();
  42.   if (opendir(DIR, $CONTROL_DIR)) {
  43.     @global = grep { $_ = "$CONTROL_DIR/$_" if -f "$CONTROL_DIR/$_" } readdir(DIR);
  44.     closedir DIR;
  45.   }
  46.   if (opendir(DIR, $LOCAL_CONTROL_DIR)) {
  47.     @local = grep { $_ = "$LOCAL_CONTROL_DIR/$_"
  48.                        if $_ ne "README"
  49.                           and $_ !~ /\.(bak|swp|dpkg-tmp|dpkg-new|dpkg-old|~)$/o
  50.                           and -f "$LOCAL_CONTROL_DIR/$_" } readdir(DIR);
  51.     closedir DIR;
  52.   }
  53.   return (@global, @local);
  54. }  # }}}
  55.  
  56. sub GetChangedDocBaseFiles($$){ # {{{
  57.   my ($toremove, $toinstall) = @_;
  58.  
  59.   my @changed = ();
  60.  
  61.   my %files = map { $_ => (stat $_)[$CTIME_FIELDNO] } GetAllDocBaseFiles();
  62.  
  63.   my $db    = Debian::DocBase::DB::GetFilesDB()->GetDB();
  64.   foreach my $file ( keys %{$db} ) {
  65.     my $realfile =  Debian::DocBase::DB::GetFilesDB()->DecodeKey($file);
  66.     if ($files{$realfile} ) {
  67.       push @changed, $realfile if $files{$realfile} != $db->{$file}->{'CT'};
  68.       delete $files{$realfile}
  69.     } elsif (defined $db->{$file}->{'ID'}) {
  70.       push @$toremove, $realfile;
  71.     } else {
  72.       # file no longer exists at file system and ID was not defined,
  73.       # so it was never registered and can't be de-registered. Don't
  74.       # try to de-register it, just remove entry from files.db
  75.       Debian::DocBase::DB::GetFilesDB()->RemoveData($realfile);
  76.     }
  77.   }
  78.   @$toinstall = keys %files;
  79.  
  80.   my @retval = ($#{$toremove}+1, $#changed+1, $#{$toinstall}+1);
  81.  
  82.   push @$toinstall, @changed;
  83.   push @$toremove, @changed;
  84.   undef @changed;
  85.   return @retval;
  86. } # }}}
  87.  
  88. sub new { # {{{
  89.     my $class         = shift;
  90.     my $filename      = shift;
  91.     my $do_add_checks = shift;
  92.     if (defined  $CONTROLFILES{$filename}) {
  93.       return $CONTROLFILES{$filename}
  94.     }
  95.  
  96.     my $self = {
  97.         MAIN_DATA     => {},    # hash of main_fld=>value
  98.         FORMAT_LIST   => {},    # array of format data hashes
  99.         FILE_NAME     => $filename,
  100.         CTIME         => 0,
  101.         DO_ADD_CHECKS => $do_add_checks ? 1 : 0,
  102.         WARNERR_CNT   => 0, # errors/warnings count
  103.         INVALID       => 1,
  104.         PARSED        => 0
  105.     };
  106.     bless($self, $class);
  107.     $self->_ReadStatusDB();
  108.     $CONTROLFILES{$filename} = $self;
  109.     weaken $CONTROLFILES{$filename};
  110.     return $self;
  111.  } # }}}
  112.  
  113. #################################################
  114. ###            PUBLIC FUNCTIONS               ###
  115. #################################################
  116.  
  117. sub DESTROY { # {{{
  118.   my $self = shift;
  119.   delete $CONTROLFILES{$self->GetSourceFileName()};
  120. } # }}}
  121.  
  122. sub GetDocumentID() { # {{{
  123.   my $self = shift;
  124.   $self->_CheckParsed();
  125.   return $self->{'MAIN_DATA'}->{$FLD_DOCUMENT};
  126. } # }}}
  127.  
  128. sub GetFldValue($$) { # {{{
  129.   my $self = shift;
  130.   my $fld  = shift;
  131.   $self->_CheckParsed();
  132.   return $self->{'MAIN_DATA'}->{$fld};
  133. } # }}}
  134.  
  135. sub GetFormat($$) { # {{{
  136.   my $self = shift;
  137.   my $format_name = shift;
  138.   $self->_CheckParsed();
  139.   return $self->{'FORMAT_LIST'}->{$format_name};
  140. } # }}}
  141.  
  142. # returns list of all format names defined in control file
  143. sub GetFormatNames($$) { # {{{
  144.   my $self   = shift;
  145.   my @fnames = sort keys %{$self->{'FORMAT_LIST'}};
  146.   return @fnames;
  147. } # }}}
  148.  
  149. sub GetSourceFileName() { # {{{
  150.   my $self = shift;
  151.   return $self->{'FILE_NAME'};
  152. } # }}}
  153.  
  154. sub Invalid() { # {{{
  155.   my $self = shift;
  156.   return $self->{'INVALID'};
  157. } # }}}
  158.  
  159. sub GetWarnErrCount() { # {{{
  160.   my $self = shift;
  161.   return $self->{'WARNERR_CNT'};
  162. } # }}}
  163.  
  164. sub OnRegistered($$) { # {{{
  165.   my ($self, $valid)  = @_;
  166.   my $docid = $valid ? $self->GetDocumentID() : undef;
  167.   my $data  = { CT => $self->{'CTIME'},
  168.                 ID => $docid,
  169.              };
  170.   Debug("OnRegistered (".$self->GetSourceFileName().", $valid)");
  171.   Debian::DocBase::DB::GetFilesDB()->PutData($self->GetSourceFileName(), $data);
  172. } # }}}
  173.  
  174. sub OnUnregistered() { # {{{
  175.   my $self = shift;
  176.   Debug("OnUnregistered (".$self->GetSourceFileName().")");
  177.  
  178.   Debian::DocBase::DB::GetFilesDB()->RemoveData($self->GetSourceFileName());
  179.  
  180. } # }}}
  181.  
  182. sub GetLastChangeTime($) { # {{{
  183.   my $self = shift;
  184.   return $self->{'CTIME'};
  185. } # }}}
  186.  
  187. sub _ReadStatusDB($) { # {{{
  188.   my $self = shift;
  189.   my $data = Debian::DocBase::DB::GetFilesDB()->GetData($self->GetSourceFileName());
  190.   return unless $data;
  191.   $self->{'MAIN_DATA'}->{$FLD_DOCUMENT} = $data->{'ID'};
  192.   $self->{'CTIME'} = $data->{'CT'}
  193. } # }}}
  194.  
  195.  
  196. sub Parse { # {{{
  197.   my $self      = shift;
  198.   my $file      = $self->{'FILE_NAME'};
  199.   my $fh        = undef;
  200.   my $docid     = undef;
  201.  
  202.   # is file already parsed
  203.   return if $self->{'PARSED'};
  204.  
  205.   open($fh, "<", $file) or
  206.     carp "Cannot open control file `$file' for reading: $!";
  207.  
  208.   $self->{'CTIME'} = (stat $fh)[$CTIME_FIELDNO];
  209.  
  210.   $self->_ReadControlFile($fh);
  211.  
  212.   $self->{'PARSED'} = 1;
  213.  
  214.   close($fh);
  215. } # }}}
  216.  
  217. #################################################
  218. ###            PRIVATE FUNCTIONS              ###
  219. #################################################
  220.  
  221. # Parsing errors routine
  222. # The first argument should be
  223. #     PRS_FATAL_ERR, which sets global exit status to 1 and {'INVALID'} to 1
  224. #  or PRS_ERR      , INVALID to 1
  225. #  or PRS_WARN     , does not change INVALID
  226. # The second argument should be the message
  227. sub _PrsErr($$) { # {{{
  228.   my $self = shift;
  229.   my $flag = shift;
  230.   my $msg = shift;
  231.   my $filepos =  "`" . $self->GetSourceFileName()  . ($. ? "', line $." : "");
  232.  
  233.  
  234.   $self->{'WARNERR_CNT'}++;
  235.   $self->{'INVALID'} = 1 if $flag != PRS_WARN;
  236.  
  237.   if ($flag == PRS_FATAL_ERR) {
  238.     Error("Error in $filepos: $msg");
  239.   } elsif ($flag == PRS_ERR_IGN) {
  240.     ErrorNF("Error in $filepos: $msg");
  241.   } elsif ($flag == PRS_WARN) {
  242.     Warn("Warning in $filepos: $msg");
  243.   } else {
  244.     croak ("Internal error: Unknown flag ($flag, $msg)");
  245.   }
  246.  
  247.   return undef;
  248. } # }}}
  249.  
  250. # Check if input is UTF-8 encoded.  If it's not recode and warn
  251. # Parameters: $line- input line
  252. #             $fld - original field name
  253. sub _CheckUTF8($$) { # {{{
  254.   my ($self, $line, $fld) = @_;
  255.   my $is_utf8_expr= '^(?:[\x{00}-\x{7f}]|[\x{80}-\x{255}]{2,})*$';
  256.  
  257.   return $line if length($line) > 512;
  258.  
  259.   if ($line !~ /$is_utf8_expr/o) {
  260.       $self->_PrsErr(PRS_WARN, "line in field `$fld' seems not to be UTF-8 encoded, recoding");
  261.       utf8::encode($line);
  262.   }
  263.   return $line;
  264. } # }}}
  265.  
  266. ##
  267. ## assuming filehandle IN is the control file, read a section (or
  268. ## "stanza") of the doc-base control file and adds data in that
  269. ## section to the hash reference passed as an argument.  Returns 1 if
  270. ## there is data, 0 if it was empty or undef in case of parse error
  271. ##
  272. sub _ReadControlFileSection($$$) { # {{{
  273.   my $self     = shift;
  274.   my $fh       = shift;    # file handle
  275.   my $pfields  = shift;    # read fields
  276.   my $fldstype = shift;    # $FLDTYPE_MAIN or $FLDTYPE_FORMAT
  277.  
  278.  
  279.   my $empty = 1;
  280.   my ($origcf, $cf,$v);
  281.   while (<$fh>) {
  282.     chomp;
  283.     s/\s*$//o;                   # trim trailing whitespace
  284.  
  285.     # empty line?
  286.     if (/^\s*$/o) {
  287.       $empty ? next : last;
  288.     }
  289.  
  290.     $empty = 0;
  291.  
  292.     # new field?
  293.     if (/^(\S+)\s*:\s*(.*)$/o) {
  294.       ($origcf, $cf, $v) = ($1, lc $1, $2);
  295.       if (exists $pfields->{$cf}) {
  296.         $self->_PrsErr(PRS_WARN, "control field `$origcf' already defined");
  297.         next;
  298.       } elsif (not defined $FIELDS_DEF{$cf}) {
  299.         $self->_PrsErr(PRS_WARN, "unrecognised control field `$origcf'");
  300.         next;
  301.       } elsif ($FIELDS_DEF{$cf}->{$FLDDEF_TYPE} != $fldstype) {
  302.         $self->_PrsErr(PRS_WARN, "field `$origcf' in incorrect section (missing empty line before the field?)");
  303.         next;
  304.       }
  305.       $pfields->{$cf} = $self->_CheckUTF8($v, $origcf);
  306.  
  307.     } elsif (/^\s+(\S.*)$/o) {
  308.       $v = $&;
  309.       defined($cf) or return $self->_PrsErr(PRS_FATAL_ERR, "syntax error - no field specified");
  310.       not defined($FIELDS_DEF{$cf}) or $FIELDS_DEF{$cf}->{$FLDDEF_MULTILINE} or return $self->_PrsErr(PRS_FATAL_ERR, "field `$origcf' can't consist of multi lines");
  311.     #print STDERR "$cf -> $v (continued)\n";
  312.       $$pfields{$cf} .= "\n" . $self->_CheckUTF8($v, $origcf);
  313.     } else {
  314.       return $self->_PrsErr(PRS_FATAL_ERR, "syntax error in control file: $_");
  315.     }
  316.   }
  317.   return $self->_CheckRequiredFields($pfields, $fldstype) unless $empty and $fldstype == $FLDTYPE_FORMAT;
  318.   return not $empty;
  319. } # }}}
  320.  
  321. sub _CheckParsed() { # {{{
  322.   my $self      = shift;
  323.   my $filename  = $self->GetSourceFileName();
  324.   croak ('Internal error: file `' . (defined $filename ?  $filename : "") . "' not parsed")
  325.     unless $self->{'PARSED'};
  326. } # }}}
  327.  
  328. sub _CheckSection($$) { # {{{
  329.   my $self          = shift;
  330.   my $orig_section  = shift;
  331.  
  332.   ReadMap($DOCBASE_VALID_SECTIONS_LIST, \%valid_sections, 1) unless %valid_sections;
  333.   my $section  = lc $orig_section;
  334.   $section  =~ s/[\/\s]+$//g;
  335.   $section  =~ s/^[\/\s]+//g;
  336.  
  337.   while ($section) {
  338.     return if $valid_sections{$section};
  339.     last unless $section =~ s/\/[^\/]+$//;
  340.   }
  341.  
  342.  $self->_PrsErr(PRS_WARN, "unknown section: `$orig_section'\n");
  343. } # }}}
  344.  
  345. sub _CheckRequiredFields($$$) { # {{{
  346.   my $self       = shift;
  347.   my $pfields    = shift;
  348.   my $fldstype   = shift;    # $FLDTYPE_MAIN or $FLDTYPE_FORMAT
  349.  
  350.   foreach my $fldname (sort keys (%FIELDS_DEF)) {
  351.     if (
  352.         $FIELDS_DEF{$fldname} -> {$FLDDEF_TYPE} == $fldstype
  353.         and $FIELDS_DEF{$fldname} -> {$FLDDEF_REQUIRED}
  354.         and not exists $pfields->{$fldname}
  355.        ) {
  356.       return $self -> _PrsErr(PRS_FATAL_ERR, "`" . ucfirst($fldname) . "' value not specified");
  357.     }
  358.   }
  359.   return 1;
  360. } # }}}
  361.  
  362. # reads control file specified as argument
  363. # output:
  364. #    sets $docid
  365. #    sets $doc_data to point to a hash containing the document data
  366. #    sets @format_list, a list of pointers to hashes containing the format data
  367. sub _ReadControlFile { # {{{
  368.   my $self      = shift;
  369.   my $fh        = shift;
  370.   my ($tmp, $tmpnam);
  371.  
  372.   # first find doc id
  373.   $_ = <$fh>;
  374.   return $self->_PrsErr(PRS_FATAL_ERR, "the first line does not contain valid `Document' field")
  375.     unless defined $_ and /^\s*Document\s*:\s*(\S+)\s*$/i;
  376.   $self->{'MAIN_DATA'} = { $FLD_DOCUMENT => ($tmp = $1) };
  377.   $self->_PrsErr(PRS_WARN, "invalid value of `Document' field")
  378.     unless $tmp =~ /^[a-z0-9\.\+\-]+$/;
  379.  
  380.   my $doc_data = $self->{'MAIN_DATA'};
  381.   # parse rest of the file
  382.   $self->_ReadControlFileSection($fh, $doc_data, $FLDTYPE_MAIN)
  383.     or return undef;
  384.   return $self->_PrsErr(PRS_WARN, "unsupported Version: $$doc_data{'version'}") if
  385.     defined $$doc_data{'version'};
  386.  
  387.   $self->_CheckSection($doc_data->{$FLD_SECTION}) if $self->{'DO_ADD_CHECKS'};
  388.  
  389.  
  390.   $self->{'MAIN_SECTION'} = $doc_data;
  391.   undef $doc_data;
  392.  
  393.  
  394.   my $format_data = {};
  395.   my $status      = 0;
  396.   while ($status = $self->_ReadControlFileSection($fh, $format_data, $FLDTYPE_FORMAT)) {
  397.     my $format = $$format_data{'format'};
  398.  
  399.     # adjust control fields
  400.     $format =~ tr/A-Z/a-z/;
  401.  
  402.     if (defined $self->{FORMAT_LIST}->{$format}) {
  403.       return $self->_PrsErr(PRS_ERR_IGN, "format $format already defined");
  404.     }
  405.  
  406.     if (not grep { $_ eq $format } @SUPPORTED_FORMATS) {
  407.       $self->_PrsErr(PRS_WARN, "format `$$format_data{'format'}' is not supported");
  408.       next;
  409.     }
  410.  
  411.     my $index_value = undef;
  412.     # Check `Index' field
  413.     if (grep { $_ eq $format } @NEED_INDEX_FORMATS) {
  414.         $index_value = $tmp = $$format_data{'index'};
  415.         $tmpnam = "Index";
  416.  
  417.         # a) does the field exist?
  418.         defined $tmp
  419.           or return $self->_PrsErr(PRS_FATAL_ERR,"`$tmpnam' value missing for format `$format'");
  420.  
  421.         # b) does it start with / ?
  422.         if ($$format_data{'index'} !~ /^\//) {
  423.           $self->_PrsErr(PRS_WARN, "`$tmpnam' value has to be specified with absolute path: $tmp");
  424.           next;
  425.        }
  426.  
  427.        # c) does the index file exist?
  428.        if (not -e $opt_rootdir.$tmp) {
  429.         $self->_PrsErr(PRS_WARN, "file `$tmp' does not exist" .
  430.                        ($opt_rootdir eq "" ? "" : " (using `$opt_rootdir' as the root directory)"));
  431.         next;
  432.       }
  433.     }
  434.  
  435.  
  436.     # `Files' fields checks
  437.     # a) is field defined?
  438.     $tmp    =  $$format_data{'files'};
  439.     $tmpnam = "Files";
  440.     if (not defined $tmp) {
  441.       $self->_PrsErr(PRS_WARN, "`$tmpnam' value not specified for format `$format'");
  442.       next;
  443.     }
  444.  
  445.     if (not defined $index_value or $tmp ne $index_value) {
  446.       my @masks = split /\s+/, $tmp;
  447.       # b) do values start with / ?
  448.       my @invalid = grep { /^[^\/]/ } @masks;
  449.       if ($#invalid > -1) {
  450.         $self->_PrsErr(PRS_WARN, "`$tmpnam' value has to be specified with absolute path: " . join (' ', @invalid));
  451.         next;
  452.       }
  453.  
  454.       # c) do files exist ?
  455.       if (not grep { &bsd_glob($opt_rootdir.$_, GLOB_NOSORT) }  @masks) {
  456.         $self->_PrsErr(PRS_WARN, "file mask `" . join(' ', @masks) . "' does not match any files" .
  457.                          ($opt_rootdir eq "" ? "" : " (using `$opt_rootdir' as the root directory)"));
  458.         next;
  459.       }
  460.     }
  461.  
  462.    $self->{FORMAT_LIST}->{$format} = $format_data;
  463.   } continue {
  464.    $format_data = {};
  465.   }
  466.   return undef unless defined $status;
  467.  
  468.   return $self->_PrsErr(PRS_ERR_IGN, "no valid `Format' section found") if (keys %{$self->{FORMAT_LIST}} < 0);
  469.  
  470.  $self->{'INVALID'} = 0;
  471. } # }}}
  472.  
  473.  
  474.  
  475. 1;
  476.