doc-base 0.10.7 / usr / share / perl5 / Debian / DocBase / DocBaseFile.pm

# vim:cindent:ts=2:sw=2:et:fdm=marker:cms=\ #\ %s
#
# $Id: DocBaseFile.pm 228 2011-03-06 17:51:46Z robert $
#

package Debian::DocBase::DocBaseFile;

use strict;
use warnings;


use File::Glob ':glob';
use Debian::DocBase::Common;
use Debian::DocBase::Utils;
use Debian::DocBase::Gettext;
use Scalar::Util qw(weaken);

our %CONTROLFILES = ();


# constants for _PrsErr function
use constant PRS_FATAL_ERR    => 1;   # fatal error, marks documents as invalid
use constant PRS_ERR_IGN      => 2;   # error, marks documents as invalid
use constant PRS_WARN         => 3;   # warning, marks document as invalid

my %valid_sections    = ();
my $global_errors_cnt = 0;

#################################################
###        PUBLIC STATIC FUNCTIONS            ###
#################################################

sub GetDocIdFromRegisteredFile($) { # {{{
  my $file = shift;
  my $data = Debian::DocBase::DB::GetFilesDB()->GetData($file);
  return undef unless $data;
  return $data->{'ID'};
} # }}}

sub GetAllDocBaseFiles() { # {{{
  my @result;;
  my @dirs   = ($CONTROL_DIR, $LOCAL_CONTROL_DIR);
  foreach my $idx (0 .. $#dirs)
  {
    if (opendir(DIR, $dirs[$idx])) {
      push @result, grep { $_ = "$dirs[$idx]/$_"
                        if $_ ne "README"
                          and $_ !~ /(\.(bak|swp|dpkg-tmp|dpkg-new|dpkg-old)|~)$/o
                          and -f "$dirs[$idx]/$_" } readdir(DIR);
      closedir DIR;
    }
  }
  return @result;
}  # }}}

sub GetChangedDocBaseFiles($$){ # {{{
  my ($toremove, $toinstall) = @_;

  my @changed_reg   = ();
  my @changed_unreg = ();

  my %files   = map { $_ => (stat $_)[$CTIME_FIELDNO] } GetAllDocBaseFiles();

  my $filesdb = Debian::DocBase::DB::GetFilesDB();
  my @dbkeys  = $filesdb->GetDBKeys();
  foreach my $realfile ( @dbkeys ) {
    my $dbdata      = $filesdb->GetData($realfile);
    my $registered  = defined $dbdata->{'ID'};

    if ($files{$realfile} ) {
      my $changed = $files{$realfile} != $dbdata->{'CT'};
      push @changed_reg,   $realfile if $changed and $registered;
      push @changed_unreg, $realfile if $changed and ! $registered;
      delete $files{$realfile}

    } elsif ($registered) {
      push @$toremove, $realfile;

    } else {
      # file no longer exists at file system and ID was not defined,
      # so it was never registered and can't be unregistered. Don't
      # try to unregister it, just remove entry from files.db
      $filesdb->RemoveData($realfile);
    }
  }
  @$toinstall = keys %files;

  my @retval = ($#{$toremove} + 1, $#changed_reg + $#changed_unreg + 2, $#{$toinstall} + 1);

  push @$toinstall, @changed_reg;
  push @$toinstall, @changed_unreg;
  push @$toremove,  @changed_reg;
  undef @changed_reg;
  undef @changed_unreg;
  return @retval;
} # }}}


sub DisplayErrorNote()
{
  return unless  $global_errors_cnt;
  return if $opt_verbose;
  Inform(_ng(
        "Note: `install-docs --verbose --check file_name' may give more details about the above error.",
        "Note: `install-docs --verbose --check file_name' may give more details about the above errors.",
        $global_errors_cnt));
}
sub new { # {{{
    my $class         = shift;
    my $filename      = shift;
    my $do_add_checks = shift;
    if (defined  $CONTROLFILES{$filename}) {
      return $CONTROLFILES{$filename}
    }

    my $self = {
        MAIN_DATA     => {},    # hash of main_fld=>value
        FORMAT_LIST   => {},    # array of format data hashes
        FILE_NAME     => $filename,
        CTIME         => 0,
        DO_ADD_CHECKS => $do_add_checks ? 1 : 0,
        WARNERR_CNT   => 0, # errors/warnings count
        INVALID       => 1,
        PARSED        => 0
    };
    bless($self, $class);
    $self->_ReadStatusDB();
    $CONTROLFILES{$filename} = $self;
    weaken $CONTROLFILES{$filename};
    return $self;
 } # }}}

#################################################
###            PUBLIC FUNCTIONS               ###
#################################################

sub DESTROY { # {{{
  my $self = shift;
  delete $CONTROLFILES{$self->GetSourceFileName()};
} # }}}

sub GetDocumentID() { # {{{
  my $self = shift;
  $self->_CheckParsed();
  return $self->{'MAIN_DATA'}->{$FLD_DOCUMENT};
} # }}}

sub GetFldValue($$) { # {{{
  my $self = shift;
  my $fld  = shift;
  $self->_CheckParsed();
  return $self->{'MAIN_DATA'}->{$fld};
} # }}}

sub GetFormat($$) { # {{{
  my $self = shift;
  my $format_name = shift;
  $self->_CheckParsed();
  return $self->{'FORMAT_LIST'}->{$format_name};
} # }}}

# returns list of all format names defined in control file
sub GetFormatNames($$) { # {{{
  my $self   = shift;
  my @fnames = sort keys %{$self->{'FORMAT_LIST'}};
  return @fnames;
} # }}}

sub GetSourceFileName() { # {{{
  my $self = shift;
  return $self->{'FILE_NAME'};
} # }}}

sub Invalid() { # {{{
  my $self = shift;
  return $self->{'INVALID'};
} # }}}

sub GetWarnErrCount() { # {{{
  my $self = shift;
  return $self->{'WARNERR_CNT'};
} # }}}

sub OnRegistered($$) { # {{{
  my ($self, $valid)  = @_;
  my $docid = $valid ? $self->GetDocumentID() : undef;
  my $data  = { CT => $self->{'CTIME'},
                ID => $docid,
             };
  Debug("OnRegistered (".$self->GetSourceFileName().", $valid)");
  Debian::DocBase::DB::GetFilesDB()->PutData($self->GetSourceFileName(), $data);
} # }}}

sub OnUnregistered() { # {{{
  my $self = shift;
  Debug("OnUnregistered (".$self->GetSourceFileName().")");

  Debian::DocBase::DB::GetFilesDB()->RemoveData($self->GetSourceFileName());

} # }}}

sub GetLastChangeTime($) { # {{{
  my $self = shift;
  return $self->{'CTIME'};
} # }}}

sub _ReadStatusDB($) { # {{{
  my $self = shift;
  my $data = Debian::DocBase::DB::GetFilesDB()->GetData($self->GetSourceFileName());
  return unless $data;
  $self->{'MAIN_DATA'}->{$FLD_DOCUMENT} = $data->{'ID'};
  $self->{'CTIME'} = $data->{'CT'}
} # }}}


sub Parse { # {{{
  my $self      = shift;
  my $file      = $self->{'FILE_NAME'};
  my $fh        = undef;
  my $docid     = undef;

  # is file already parsed
  return if $self->{'PARSED'};

  open($fh, "<", $file) or
    Fatal($ERR_PROCESSING, _g("Cannot open file `%s' for reading: %s."), $file, $!);

  $self->{'CTIME'} = (stat $fh)[$CTIME_FIELDNO];

  $self->_ReadControlFile($fh);

  $self->{'PARSED'} = 1;

  close($fh);

  # if document doesn't contain valid document id,
  # mark that document file exists in our files.db
  $self->OnRegistered(0) unless defined $self->GetDocumentID();

} # }}}

#################################################
###            PRIVATE FUNCTIONS              ###
#################################################

# Parsing errors routine
# The first argument should be
#     PRS_FATAL_ERR, which sets global exit status to 1 and {'INVALID'} to 1
#  or PRS_ERR      , INVALID to 1
#  or PRS_WARN     , does not change INVALID
# The second argument should be the message
sub _PrsErr($$) { # {{{
  my $self = shift;
  my $flag = shift;
  my $fmt  = shift;
  my $msg  = sprintf ($fmt, @_);
  my $filepos = $. ?  sprintf _g("`%s', line %d"), $self->GetSourceFileName(), $.
                   :  sprintf "`%s'", $self->GetSourceFileName();

  $self->{'WARNERR_CNT'}++;
  $self->{'INVALID'} = 1 if $flag != PRS_WARN;

  if ($flag == PRS_FATAL_ERR) {
    ++$global_errors_cnt;
    Error(_g("Error in %s: %s."), $filepos, $msg);
  } elsif ($flag == PRS_ERR_IGN) {
    ++$global_errors_cnt;
    ErrorNF(_g("Error in %s: %s."), $filepos, $msg);
  } elsif ($flag == PRS_WARN) {
    Warn(_g("Warning in %s: %s."), $filepos, $msg);
  } else {
    Fatal($ERR_INTERNAL, _g("Unknown flag (%s, %s)."), $flag, $msg);
  }

  return undef;
} # }}}

# Check if input is UTF-8 encoded.  If it's not recode and warn
# Parameters: $line- input line
#             $fld - original field name
sub _CheckUTF8($$) { # {{{
  my ($self, $line, $fld) = @_;
  my $is_utf8_expr= '^(?:[\x{00}-\x{7f}]|[\x{80}-\x{255}]{2,})*$';

  return $line if length($line) > 512;

  if ($line !~ /$is_utf8_expr/o) {
      $self->_PrsErr(PRS_WARN, _g("line in field `%s' seems not to be UTF-8 encoded, recoding"), $fld);
      utf8::encode($line);
  }
  return $line;
} # }}}

##
## assuming filehandle IN is the control file, read a section (or
## "stanza") of the doc-base control file and adds data in that
## section to the hash reference passed as an argument.  Returns 1 if
## there is data, 0 if it was empty or undef in case of parse error
##
sub _ReadControlFileSection($$$) { # {{{
  my $self     = shift;
  my $fh       = shift;    # file handle
  my $pfields  = shift;    # read fields
  my $fldstype = shift;    # $FLDTYPE_MAIN or $FLDTYPE_FORMAT


  my $empty = 1;
  my ($origcf, $cf,$v);
  while (<$fh>) {
    chomp;
    s/\s*$//o;                   # trim trailing whitespace

    # empty line?
    if (/^\s*$/o) {
      $empty ? next : last;
    }

    $empty = 0;

    # new field?
    if (/^(\S+)\s*:\s*(.*)$/o) {
      ($origcf, $cf, $v) = ($1, lc $1, $2);
      if (exists $pfields->{$cf}) {
        $self->_PrsErr(PRS_WARN, _g("control field `%s' already defined"), $origcf);
        next;
      } elsif (not defined $FIELDS_DEF{$cf}) {
        $self->_PrsErr(PRS_WARN, _g("unrecognised control field `%s'"), $origcf);
        next;
      } elsif ($FIELDS_DEF{$cf}->{$FLDDEF_TYPE} != $fldstype) {
        $self->_PrsErr(PRS_WARN, _g("field `%s' in incorrect section (missing empty line before the field?)"), $origcf);
        next;
      }
      $pfields->{$cf} = $self->_CheckUTF8($v, $origcf);

    } elsif (/^\s+(\S.*)$/o) {
      $v = $&;
      defined($cf) or return $self->_PrsErr(PRS_FATAL_ERR, _g("syntax error - no field specified"));
      not defined($FIELDS_DEF{$cf}) or $FIELDS_DEF{$cf}->{$FLDDEF_MULTILINE} or return $self->_PrsErr(PRS_FATAL_ERR, _g("field `%s' cannot consist of multi lines"), $origcf);
    #print STDERR "$cf -> $v (continued)\n";
      $$pfields{$cf} .= "\n" . $self->_CheckUTF8($v, $origcf);
    } else {
      return $self->_PrsErr(PRS_FATAL_ERR, _g("syntax error in control file: %s"), $_);
    }
  }
  return $self->_CheckRequiredFields($pfields, $fldstype) unless $empty and $fldstype == $FLDTYPE_FORMAT;
  return not $empty;
} # }}}

sub _CheckParsed() { # {{{
  my $self      = shift;
  my $filename  = $self->GetSourceFileName();
  Fatal($ERR_INTERNAL, _g("File `%s' not yet parsed."), (defined $filename ?  $filename : ""))
    unless $self->{'PARSED'};
} # }}}

sub _CheckSection($$) { # {{{
  my $self          = shift;
  my $orig_section  = shift;

  ReadMap($DOCBASE_VALID_SECTIONS_LIST, \%valid_sections, 1) unless %valid_sections;
  my $section  = lc $orig_section;
  $section  =~ s/[\/\s]+$//g;
  $section  =~ s/^[\/\s]+//g;

  while ($section) {
    return if $valid_sections{$section};
    last unless $section =~ s/\/[^\/]+$//;
  }

 $self->_PrsErr(PRS_WARN, _g("unknown section: `%s'"), $orig_section);
} # }}}

sub _CheckRequiredFields($$$) { # {{{
  my $self       = shift;
  my $pfields    = shift;
  my $fldstype   = shift;    # $FLDTYPE_MAIN or $FLDTYPE_FORMAT

  foreach my $fldname (sort keys (%FIELDS_DEF)) {
    if (
        $FIELDS_DEF{$fldname} -> {$FLDDEF_TYPE} == $fldstype
        and $FIELDS_DEF{$fldname} -> {$FLDDEF_REQUIRED}
        and not exists $pfields->{$fldname}
       ) {
      return $self -> _PrsErr(PRS_FATAL_ERR, _g("value of `%s' not specified"), ucfirst($fldname));
    }
  }
  return 1;
} # }}}

# reads control file specified as argument
# output:
#    sets $docid
#    sets $doc_data to point to a hash containing the document data
#    sets @format_list, a list of pointers to hashes containing the format data
 sub _ReadControlFile { # {{{
  my $self      = shift;
  my $fh        = shift;
  my ($tmp, $tmpnam);

  # first find doc id
  $_ = <$fh>;
  return $self->_PrsErr(PRS_FATAL_ERR, _g("the first line does not contain valid `Document' field"))
    unless defined $_ and /^\s*Document\s*:\s*(\S+)\s*$/i;
  $self->{'MAIN_DATA'} = { $FLD_DOCUMENT => ($tmp = $1) };
  $self->_PrsErr(PRS_WARN, _g("invalid value of `Document' field"))
    unless $tmp =~ /^[a-z0-9\.\+\-]+$/;

  my $optdirmsg = ($opt_rootdir eq "") ? "" : " " . sprintf ( _g("(using `%s' as the root directory)"),
                                                         $opt_rootdir);

  my $doc_data = $self->{'MAIN_DATA'};
  # parse rest of the file
  $self->_ReadControlFileSection($fh, $doc_data, $FLDTYPE_MAIN)
    or return undef;
  return $self->_PrsErr(PRS_WARN, _g("unsupported doc-base file version: %s"), $$doc_data{'version'})
    if defined $$doc_data{'version'};

  $self->_CheckSection($doc_data->{$FLD_SECTION}) if $self->{'DO_ADD_CHECKS'};


  $self->{'MAIN_SECTION'} = $doc_data;
  undef $doc_data;


  my $format_data = {};
  my $status      = 0;
  my $fmts_count  = 0;
  while ($status = $self->_ReadControlFileSection($fh, $format_data, $FLDTYPE_FORMAT)) {
    my $format = $$format_data{'format'};
    ++$fmts_count;

    # adjust control fields
    $format =~ tr/A-Z/a-z/;

    if (defined $self->{FORMAT_LIST}->{$format}) {
      return $self->_PrsErr(PRS_ERR_IGN, _g("format `%s' already defined"), $format);
    }

    if (not grep { $_ eq $format } @SUPPORTED_FORMATS) {
      $self->_PrsErr(PRS_WARN, _g("format `%s' is not supported"), $$format_data{'format'});
      next;
    }

    my $index_value = undef;
    # Check `Index' field
    if (grep { $_ eq $format } @NEED_INDEX_FORMATS) {
        $index_value = $tmp = $$format_data{'index'};
        $tmpnam = "Index";

        # a) does the field exist?
        defined $tmp
          or return $self->_PrsErr(PRS_FATAL_ERR, _g("`%s' value missing for format `%s'"), $tmpnam, $format);

        # b) does it start with / ?
        if ($$format_data{'index'} !~ /^\//) {
          $self->_PrsErr(PRS_WARN, _g("`%s' value has to be specified with absolute path: %s"), $tmpnam, $tmp);
          next;
       }

       # c) does the index file exist?
       if (not -e $opt_rootdir.$tmp) {
          $self->_PrsErr(PRS_WARN, _g("file `%s' does not exist").$optdirmsg, $tmp) ;
          next;
      }
    }


    # `Files' fields checks
    # a) is field defined?
    $tmp    =  $$format_data{'files'};
    $tmpnam = "Files";
    if (not defined $tmp) {
      $self->_PrsErr(PRS_WARN, _g("`%s' value not specified for format `%s'"), $tmpnam, $format);
      next;
    }

    if (not defined $index_value or $tmp ne $index_value) {
      my @masks = split /\s+/, $tmp;
      # b) do values start with / ?
      my @invalid = grep { /^[^\/]/ } @masks;
      if ($#invalid > -1) {
        $self->_PrsErr(PRS_WARN, _g("`%s' value  has to be specified with absolute path: %s"), $tmpnam,  join (' ', @invalid));
        next;
      }

      # c) do files exist ?
      if (not grep { &bsd_glob($opt_rootdir.$_, GLOB_NOSORT) }  @masks) {
        $self->_PrsErr(PRS_WARN, _g("file mask `%s' does not match any files") . $optdirmsg,
                                  join (" ", @masks));
        next;
      }
    }

   $self->{FORMAT_LIST}->{$format} = $format_data;
  } continue {
   $format_data = {};
  }

  unless (keys %{$self->{FORMAT_LIST}})
  {
    return $self->_PrsErr(PRS_ERR_IGN, _g("no `Format' section found")) unless $fmts_count;
    return $self->_PrsErr(PRS_ERR_IGN, _g("all `Format' sections are invalid"));
  }

 $self->{'INVALID'} = 0;
} # }}}



1;