summaryrefslogtreecommitdiffstats
path: root/lib/Lintian/Reporting
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Lintian/Reporting')
-rw-r--r--lib/Lintian/Reporting/ResourceManager.pm233
-rw-r--r--lib/Lintian/Reporting/Util.pm217
2 files changed, 450 insertions, 0 deletions
diff --git a/lib/Lintian/Reporting/ResourceManager.pm b/lib/Lintian/Reporting/ResourceManager.pm
new file mode 100644
index 0000000..171b6b7
--- /dev/null
+++ b/lib/Lintian/Reporting/ResourceManager.pm
@@ -0,0 +1,233 @@
+# Copyright (C) 2014 Niels Thykier <niels@thykier.net>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+# A simple resource manager for html_reports
+package Lintian::Reporting::ResourceManager;
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Carp qw(croak);
+use Const::Fast;
+use File::Basename qw(basename);
+use File::Copy qw(copy);
+use Unicode::UTF8 qw(encode_utf8);
+
+use Lintian::Util qw(get_file_digest);
+
+const my $SPACE => q{ };
+const my $SLASH => q{/};
+const my $EQUALS => q{=};
+
+const my $BASE64_UNIT => 4;
+const my $WIDELY_READABLE_FOLDER => oct(755);
+
+=head1 NAME
+
+Lintian::Reporting::ResourceManager -- A simple resource manager for html_reports
+
+=head1 SYNOPSIS
+
+ use Lintian::Reporting::ResourceManager;
+
+ my $resMan = Lintian::Reporting::ResourceManager->new(
+ 'html_dir' => 'path/to/HTML-root',
+ );
+ # Copy the resource
+ $resMan->install_resource('path/to/my-image.png', { install_method => 'copy'} );
+ # Move the resource
+ $resMan->install_resource('path/to/generated-styles.css');
+ print encode_utf8('Image: ' . $resMan->resource_url('my-image.png'), "\n");
+ print encode_utf8('CSS: ' . $resMan->resource_url('generated-styles.css'), "\n");
+
+=head1 DESCRIPTION
+
+A simple resource manager for Lintian's reporting tool,
+B<html_reports>.
+
+
+=head1 CLASS METHODS
+
+=over 4
+
+=item new(TYPE, OPTS)
+
+Instantiates a new resource manager.
+
+OPTS is a key-value list, which must contain the key "html_dir" set to
+the root of the HTML path. It is beneath this path that all resources
+will be installed
+
+=cut
+
+sub new {
+ my ($class, %opts) = @_;
+ my $self = {%opts,};
+ croak encode_utf8('Missing required parameter html_dir (or it is undef)')
+ if not defined $opts{'html_dir'};
+ $self->{'_resource_cache'} = {};
+ $self->{'_resource_integrity'} = {};
+ return bless($self, $class);
+}
+
+=back
+
+=head1 INSTANCE METHODS
+
+=over 4
+
+=item install_resource(RESOURCE[, OPT])
+
+Installs RESOURCE into the html root. The resource may be renamed
+(based on content etc.).
+
+Note that the basename of RESOURCE must be unique between all
+resources installed. See L</resource_url(RESOURCE_NAME)>.
+
+If OPT is given, it must be a hashref with 0 or more of the following
+keys (and values).
+
+=over 4
+
+=item install_method
+
+Can be "copy" or "move" (default). If set to "move", the original file
+will be renamed into its new location. Otherwise, a copy is done and
+the original file is left in place.
+
+=item source_file
+
+By default, the path denoted by RESOURCE is both the resource name and
+the source file. This option can be used to install a given file as
+RESOURCE regardless of the basename of the source file.
+
+If this is passed, RESOURCE must be a basename (i.e. without any
+slashes).
+
+=back
+
+=cut
+
+sub install_resource {
+ my ($self, $resource_name, $opt) = @_;
+ my $resource_root = $self->{'html_dir'} . '/resources';
+ my $method = 'move';
+ my ($basename, $install_name, $resource, $digest, $b64digest);
+ $method = $opt->{'install_method'}
+ if $opt && exists($opt->{'install_method'});
+ if ($opt && exists($opt->{'source_file'})) {
+ $basename = $resource_name;
+ $resource = $opt->{'source_file'};
+
+ if ($basename =~ m{ / }msx) {
+
+ croak encode_utf8(
+ join($SPACE,
+ qq(Resource "${resource_name}" must not contain "/"),
+ 'when source_file is given')
+ );
+ }
+ } else {
+ $basename = basename($resource_name);
+ $resource = $resource_name;
+ }
+ $digest = get_file_digest('sha256', $resource);
+ $install_name = $digest->clone->hexdigest;
+ $b64digest = $digest->b64digest;
+
+ while (length($b64digest) % $BASE64_UNIT) {
+ $b64digest .= $EQUALS;
+ }
+
+ croak encode_utf8("Resource name ${basename} already in use")
+ if defined($self->{'_resource_cache'}{$basename});
+ if ($basename =~ m/^.+(\.[^\.]+)$/xsm) {
+ my $ext = $1;
+ $install_name .= $ext;
+ }
+
+ if (!-d $resource_root) {
+ mkdir($resource_root, $WIDELY_READABLE_FOLDER)
+ or die encode_utf8("Cannot mkdir $resource_root");
+ }
+
+ my $target_file = "$resource_root/$install_name";
+ if ($method eq 'move') {
+ rename($resource, $target_file)
+ or die encode_utf8("Cannot rename $resource to $target_file");
+
+ } elsif ($method eq 'copy') {
+ copy($resource, $target_file)
+ or croak encode_utf8("Cannot copy $resource to $target_file: $!");
+ } else {
+ croak encode_utf8(
+ join($SPACE,
+ "Unknown install method ${method}",
+ '- please use "move" or "copy"')
+ );
+ }
+ $self->{'_resource_cache'}{$basename} = $target_file;
+ $self->{'_resource_integrity'}{$basename} = "sha256-${b64digest}";
+ return;
+}
+
+=item resource_url(RESOURCE_NAME)
+
+Returns the path (relative to the HTML root) to a resource installed
+via L</install_resource(RESOURCE)>, where RESOURCE_NAME is the
+basename of the path given to install_resource.
+
+=cut
+
+sub resource_url {
+ my ($self, $resource_name) = @_;
+ croak encode_utf8("Unknown resource $resource_name")
+ if not defined($self->{'_resource_cache'}{$resource_name});
+ return $self->{'_resource_cache'}{$resource_name};
+}
+
+=item resource_integrity_value(RESOURCE_NAME)
+
+Return a string that is valid in the "integrity" field of a C<< <link>
+>> HTML tag. (See https://www.w3.org/TR/SRI/)
+
+=cut
+
+sub resource_integrity_value {
+ my ($self, $resource_name) = @_;
+ croak encode_utf8("Unknown resource $resource_name")
+ if not defined($self->{'_resource_integrity'}{$resource_name});
+ return $self->{'_resource_integrity'}{$resource_name};
+}
+
+=back
+
+=head1 AUTHOR
+
+Originally written by Niels Thykier <niels@thykier.net> for Lintian.
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
diff --git a/lib/Lintian/Reporting/Util.pm b/lib/Lintian/Reporting/Util.pm
new file mode 100644
index 0000000..ecf34cf
--- /dev/null
+++ b/lib/Lintian/Reporting/Util.pm
@@ -0,0 +1,217 @@
+# Hey emacs! This is a -*- Perl -*- script!
+# Lintian::Reporting::Util -- Perl utility functions for lintian's reporting framework
+
+# Copyright (C) 1998 Christian Schwarz
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+package Lintian::Reporting::Util;
+
+=head1 NAME
+
+Lintian::Reporting::Util - Lintian utility functions
+
+=head1 SYNOPSIS
+
+ use Lintian::Reporting::Util qw(load_state_cache find_backlog);
+
+ my $cache = load_state_cache('path/to/state-dir');
+ my @backlog = find_backlog('2.12', $cache);
+
+=head1 DESCRIPTION
+
+This module contains a number of utility subs that are nice to have
+for the reporting framework, but on their own did not warrant their
+own module.
+
+Most subs are imported only on request.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=cut
+
+use v5.20;
+use warnings;
+use utf8;
+
+use Const::Fast;
+use Exporter qw(import);
+use File::Temp qw(tempfile);
+use List::Util qw(shuffle);
+use Path::Tiny;
+use Syntax::Keyword::Try;
+use Unicode::UTF8 qw(encode_utf8);
+use YAML::XS ();
+
+use Lintian::Relation::Version qw(versions_equal versions_comparator);
+
+our @EXPORT_OK = (
+ qw(
+ load_state_cache
+ save_state_cache
+ find_backlog
+ )
+);
+
+const my $WIDELY_READABLE => oct(644);
+
+=item load_state_cache(STATE_DIR)
+
+[Reporting tools only] Load the state cache from STATE_DIR.
+
+=cut
+
+sub load_state_cache {
+ my ($state_dir) = @_;
+ my $state_file = "$state_dir/state-cache";
+ my $state = {};
+
+ return $state
+ unless -e $state_file;
+
+ my $yaml = path($state_file)->slurp;
+
+ try {
+ $state = YAML::XS::Load($yaml);
+
+ } catch {
+ # Not sure what Load does in case of issues; perldoc YAML says
+ # very little about it. Based on YAML::Error, I guess it will
+ # write stuff to STDERR and use die/croak, but it remains a
+ # guess.
+ die encode_utf8(
+ "$state_file was invalid; please fix or remove it.\n$@");
+ }
+
+ $state //= {};
+
+ if (ref($state) ne 'HASH') {
+ die encode_utf8("$state_file was invalid; please fix or remove it.");
+ }
+ return $state;
+}
+
+=item save_state_cache(STATE_DIR, STATE)
+
+[Reporting tools only] Save the STATE cache to STATE_DIR.
+
+=cut
+
+sub save_state_cache {
+ my ($state_dir, $state) = @_;
+ my $state_file = "$state_dir/state-cache";
+ my ($tmp_fd, $tmp_path);
+
+ ($tmp_fd, $tmp_path) = tempfile('state-cache-XXXXXX', DIR => $state_dir);
+ ## TODO: Should tmp_fd be binmode'd as we use YAML::XS?
+
+ # atomic replacement of the state file; not a substitute for
+ # proper locking, but it will at least ensure that the file
+ # is in a consistent state.
+ try {
+ print {$tmp_fd} encode_utf8(YAML::XS::Dump($state));
+
+ close($tmp_fd) or die encode_utf8("close $tmp_path: $!");
+
+ # There is no secret in this. Set it to 0644, so it does not
+ # require sudo access on lintian.d.o to read the file.
+ chmod($WIDELY_READABLE, $tmp_path);
+
+ rename($tmp_path, $state_file)
+ or die encode_utf8("rename $tmp_path -> $state_file: $!");
+
+ } catch {
+ my $err = $@;
+ if (-e $tmp_path) {
+ # Ignore error as we have a more important one
+ unlink($tmp_path)
+ or warn encode_utf8("Cannot unlink $tmp_path");
+ }
+ die encode_utf8($err);
+
+ # perlcritic 1.140-1 requires the semicolon on the next line
+ };
+
+ return 1;
+}
+
+=item find_backlog(LINTIAN_VERSION, STATE)
+
+[Reporting tools only] Given the current lintian version and the
+harness state, return a list of group ids that are part of the
+backlog. The list is sorted based on what version of Lintian
+processed the package.
+
+Note the result is by design not deterministic to reduce the
+risk of all large packages being in the same run (e.g. like
+gcc-5 + gcc-5-cross + gcc-6 + gcc-6-cross).
+
+=cut
+
+sub find_backlog {
+ my ($lintian_version, $state) = @_;
+ my (@backlog, %by_version, @low_priority);
+ for my $group_id (keys(%{$state->{'groups'}})) {
+ my $last_version = '0';
+ my $group_data = $state->{'groups'}{$group_id};
+ my $is_out_of_date;
+ # Does this group repeatedly fail with the current version
+ # of lintian?
+ if ( exists($group_data->{'processing-errors'})
+ and $group_data->{'processing-errors'} > 2
+ and exists($group_data->{'last-error-by'})
+ and $group_data->{'last-error-by'} ne $lintian_version) {
+ # To avoid possible "starvation", we will give lower priority
+ # to packages that repeatedly fail. They will be retried as
+ # the backlog is cleared.
+ push(@low_priority, $group_id);
+ next;
+ }
+ if (exists($group_data->{'out-of-date'})) {
+ $is_out_of_date = $group_data->{'out-of-date'};
+ }
+ if (exists($group_data->{'last-processed-by'})) {
+ $last_version = $group_data->{'last-processed-by'};
+ }
+ $is_out_of_date = 1
+ if not versions_equal($last_version, $lintian_version);
+ push(@{$by_version{$last_version}}, $group_id) if $is_out_of_date;
+ }
+ for my $v (sort(versions_comparator keys(%by_version))) {
+ push(@backlog, shuffle(@{$by_version{$v}}));
+ }
+ push(@backlog, shuffle(@low_priority)) if @low_priority;
+ return @backlog;
+}
+
+=back
+
+=head1 SEE ALSO
+
+lintian(1)
+
+=cut
+
+1;
+
+# Local Variables:
+# indent-tabs-mode: nil
+# cperl-indent-level: 4
+# End:
+# vim: syntax=perl sw=4 sts=4 sr et
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-22 18:11:10 +0000