view release on metacpan or  search on metacpan

lib/Data/Edit/Xml/Lint.pm  view on Meta::CPAN

  for my $e(@e)                                                                 # Reduce error line
   {my @c = split /:/, $e;
    $c{$c[-1]}++;
   }                                                                            # Format compressed errors block

  if (my $n = scalar(keys %c))
   {my @t = (qq(<!--compressedErrors: $n -->));                                 # Number of errors
    for my $e(sort keys %c)                                                     # Each unique reduced error line
     {push @t, qq(<!--${e}-->);
     }
    my $t = join "\n", '', @t;
    return $t;
   }
  qq(<!--compressedErrors: 0 -->);                                              # No errors
 }

sub nolint($@)                                                                  # Store just the attributes in a file so that they can be retrieved later to process non xml objects referenced in the xml - like images
 {my ($lint, %attributes) = @_;                                                 # Linter, attributes to be recorded as xml comments
  !$lint->source or confess "Source specified for nolint(), use lint()";        # Source not permitted for nolint()
  my $file = $lint->file;                                                       # File to be written to
     $file or confess "Use the ->file method to provide the target file";       # Check that we have an output file

# for(qw(author ditaType file guid project title))                              # Map parameters to attributes
  for(qw(author catalog ditaType docType dtds errors file guid header idDefs),
      qw(inputFile labelDefs labels linted processes project sha256),
      qw(source title))
   {my $a = $lint->$_;
    $attributes{$_}  = $a if $a;
   }

  my $time = "<!--linted: ".dateStamp." -->\n";                                 # Time stamp marks the start of the added comments
  my $attr = &formatAttributes({%attributes});                                  # Attributes to be recorded with the xml

  if (my $r = $lint->{reusedInProject})
   {$attr .= &reuseInProject($_) for @$r;
   }

  writeFile($file, "\n$time\n$attr");                                           # Write attributes to file
 } # nolint

sub formatAttributes(%)                                                         #P Format the attributes section of the output file
 {my ($attributes) = @_;                                                        # Hash of attributes
  my @s;
  for(sort keys %$attributes)
   {my $v = $attributes->{$_};                                                  # Attribute value

   !defined($v) and m(docType) and confess "No doc type set for the xml to be linted";
    defined($v) or confess "Attribute $_ has no value";
    $v =~ s/--/\\-\\-/gs;                                                       # Replace -- with \-\- as -- will upset the use of xml comments to hold the data in a greppable form - but only for title - for files we need to see an error message
#   $v =~ m/--/s and confess "Found -- in value of $_=>$v";                     # Confess if -- present in attribute value as this will mess up the xml comments
    push @s, "<!--${_}: $v -->";                                                # Place attribute inside a comment
   }
  join "\n", @s
 }

sub read($)                                                                     #S Reread a linted xml L<file|/file> and extract the L<attributes|/Attributes> associated with the L<lint|/lint>
 {my ($file) = @_;                                                              # File containing xml
  my $s = readFile($file);                                                      # Read xml from file
  my %a = $s =~ m/<!--(\w+):\s+(.+?)\s+-->/igs;                                 # Get attributes
  my @a = split m/\n/, $s;                                                      # Split into lines
  my $l = {};                                                                   # Reconstructed labels

  for(@a)                                                                       # Each source line
   {if (/<!--labels:\s+(.+?)\s+-->/gs)                                          # Labels line
     {my ($w) = my @w = split /\s+/, $1;                                        # Id, labels
      $l->{$_} = $w for @w;                                                     # Associate each id and label with the id
     }
   }

  my $d = {};                                                                   # Id definitions
  for(@a)                                                                       # Each source line
   {if (/<!--definition:\s+(.+?)\s+-->/gs)                                      # Definition
     {$d->{$1}++;                                                               # Record definition
      $l->{$1} = $1;                                                            # An id also defines a label
     }
   }

  my $r = {};                                                                   # Reused in project
  for(@a)                                                                       # Each source line
   {if (/<!--reusedInProject:\s+(.+?)\s+-->/gs)                                 # Definition
     {$r->{$1}++;                                                               # Record definition
     }
   }

  my ($S, @S) = split /(?=<!--linted:)/s, $s;                                   # Split source on errors
  my ($U, $C) = split /(?=<!--compressedErrors:)/s, $S[-1]//'';                 # Split errors
  my @U = $U ? split /\n+/, $U : ();                                            # Split uncompressed errors
  my @C = $C ? split /\n+/, $C : ();                                            # Split   compressed errors
  shift @C;                                                                     # Remove the number of compressed errors
  $_ = nws($_) for @C;                                                          # Normalize white space

  my $lint = bless                                                              # Create a matching linter
   {%a,                                                                         # Directly loaded fields
    source              =>  $S,                                                 # Computed fields
#    header              =>  $a[0],                                             # Available in end of file comments
#    docType             =>  $a[1],
    file                =>  $file,
    idDefs              =>  $d,
    labels              =>  undef,                                              #  2019.03.16 01:42:37 property of the parse tree only
    labelDefs           =>  $l,
    reusedInProject     => [sort keys %$r],
    compressedErrorText => [@C],
    errorText           => [@U],
   };

  $lint->project          //= q();                                              # Supply a default bank project
  $lint->errors           //= 0;
  $lint->compressedErrors //= 0;
  $lint                                                                         # Return a matching linter
 } # read

sub reload($)                                                                   # Reload a parse tree from a linted file restoring any labels and return the parse tree or B<undef> if the file is not a lint file.
 {my ($file) = @_;                                                              # File to read

  return undef unless my $l = &read($file);                                     # Read lint file or fail
  my %labels;                                                                   # Labels for each id
  my %labelDefs = %{$l->labelDefs};                                             # Label definitions
  for my $label(sort keys %labelDefs)                                           # Each label definition
   {my $id = $labelDefs{$label};                                                # Id for label
    if ($id ne $label)                                                          # Ignore self definitions