add script feature-check

1 files changed, 305 insertions, 0 deletions

diff --git a/bin/feature-check.pl b/bin/feature-check.pl
new file mode 100755
index 0000000..b53f4a2
--- /dev/null
+++ b/bin/feature-check.pl
@@ -0,0 +1,305 @@
+#!/usr/bin/perl
+
+use v5.14;
+use utf8;
+use warnings;
+
+use Getopt::Long 2.24 qw(:config gnu_getopt);
+use IO::Interactive qw(is_interactive);
+
+my $USE_COLOR;
+BEGIN {
+	$USE_COLOR = !(
+		   exists $ENV{NO_COLOR}
+		or ( $ENV{COLOR} and !$ENV{COLOR} )
+		or !is_interactive
+	);
+	$Pod::Usage::Formatter = 'Pod::Text::Color' if $USE_COLOR;
+}
+use Pod::Usage;
+
+my $COPYRIGHT;
+use Pod::Constants
+	-trim => 1,
+	'COPYRIGHT AND LICENSE' =>
+	sub { ($COPYRIGHT) = s/C<< (.*) >>/$1/gr; $COPYRIGHT =~ s/©/©/g };
+
+use List::Util qw(max);
+use Readonly::Tiny;
+use Path::Tiny;
+use Log::Any qw($log);
+use Log::Any::Adapter;
+use Term::Table;
+
+# TODO: handle options --quiet/--verbose/--debug
+# TODO: handle output scope, with options --threshold/--all
+# TODO: handle custom basepath (with builtin as default), taken as argument
+# TODO: handle multiple basepaths
+# TODO: check scripts (not only documentation)
+
+Log::Any::Adapter->set( 'Screen', use_color => $USE_COLOR );
+
+=head1 NAME
+
+feature-check - examine maturity and availability status of Redpill features
+
+=head1 VERSION
+
+Version v0.1.0
+
+=cut
+
+our $VERSION = 'v0.1.0';
+
+my $progname = path($0)->basename;
+
+our %OPT = ();
+my @OPT = ();
+
+=head1 SYNOPSIS
+
+    feature-check [ --help | --version ]
+
+    feature-check [OPTION...]
+
+=head1 DESCRIPTION
+
+B<feature-check> is a command-line tool
+to parse and examine a set of Redpill features,
+and print a summary on standard output.
+
+Usability of each feature is evaluated
+based on coverage and embedded annotations of its documentation.
+
+=head1 OPTIONS
+
+=head2 General
+
+=over 16
+
+=item B<-h>, B<--help>
+
+print help message and exit
+
+=item B<--man>
+
+print manual and exit
+
+=item B<-v>, B<--version>
+
+print version and copyright information and exit
+
+=back
+
+=cut
+
+push @OPT, qw(
+	verbose
+	help|h
+	man
+	version|v
+);
+
+GetOptions( \%OPT, @OPT ) or pod2usage(2);
+
+pod2usage(1) if ( $OPT{help} );
+pod2usage(-exitval => 0, -verbose => 2)  if ($OPT{man});
+if ( $OPT{version} ) { version(); exit 0; }
+
+pod2usage( join "\n", map {"Unknown argument: $_"} @ARGV )
+	if @ARGV;
+
+my $BASEDIR = path('../..');
+
+my @TARGET = qw(executive user expert);
+readonly \@TARGET;
+
+my @MATURITY = qw(unusable buggy incomplete usable good);
+readonly \@MATURITY;
+
+use enum qw(
+	UNUSABLE=0 BUGGY INCOMPLETE USABLE GOOD
+	EXECUTIVE=0 USER EXPERT
+);
+
+my %DOCFILE = (
+	ADMIN    => EXPERT,
+	INTRO    => USER,
+	OVERVIEW => EXECUTIVE,
+	README   => EXECUTIVE,
+	SETUP    => EXPERT,
+	USE      => USER,
+);
+readonly \%DOCFILE;
+
+my $threshold = USABLE;
+$log->info("acceptance threshold: $MATURITY[$threshold]");
+
+my $featureref = path("$BASEDIR")->visit( \&feature );
+
+#use DDP; p $featureref if $log->is_debug;
+
+my @row;
+for my $feature ( sort keys %$featureref ) {
+	my @target = @{ $featureref->{$feature}{target} };
+
+	push @row, [ $feature, map { join ', ', sort keys %{ $target[$_]{docs} } if $target[$_]{maturity} >= $threshold } EXECUTIVE..EXPERT ];
+}
+
+my $table = Term::Table->new(
+	header => [ 'feature', @TARGET ],
+	rows   => \@row,
+);
+
+say $_ for $table->render;
+
+sub feature {
+	my ($path, $state) = @_;
+	my ( $feature, $docs, $maturity );
+
+	return unless $path->is_dir;
+	return if $path->basename =~ qr/\.$/;
+
+	$feature = $path->basename;
+	$log->trace("found feature: $feature");
+
+	$docs = $path->visit( \&docfile );
+
+	for my $target (EXECUTIVE..EXPERT) {
+		my $maturity;
+
+		if ( exists $docs->{$target} ) {
+			$state->{$feature}{target}[$target]{docs} = $docs->{$target};
+			$maturity = max map { $_->{maturity} } values %{ $docs->{$target} };
+		}
+		else {
+			$maturity = UNUSABLE;
+		}
+
+		$state->{$feature}{target}[$target]{maturity} = $maturity;
+		$log->debug("resolved feature $feature target $target maturity: $maturity");
+	}
+
+	if ( exists $state->{$feature}{target}[EXECUTIVE]{docs} && exists $state->{$feature}{target}[EXECUTIVE]{docs}{README} ) {
+		$maturity = $state->{$feature}{target}[EXECUTIVE]{maturity};
+	}
+	elsif ( INCOMPLETE < $state->{$feature}{target}[EXECUTIVE]{maturity} ) {
+		$maturity = INCOMPLETE;
+	}
+	else {
+		$maturity = $state->{$feature}{target}[EXECUTIVE]{maturity};
+	}
+
+	$state->{$feature}{maturity} = $maturity;
+	$log->warning("skipping unacceptable feature: $feature")
+		if $maturity < $threshold;
+}
+
+sub docfile {
+	my ($path, $state) = @_;
+	my ( $doc, $category, $content, $maturity );
+
+	return unless $path->is_file;
+	$doc = $path->basename('.md');
+	return if $path->basename eq $doc;
+	return unless exists $DOCFILE{$doc};
+	$category = $DOCFILE{$doc}
+		// return;
+
+	$content = $path->slurp_utf8;
+	if ( $content =~ qr/\bFIXME\b/ ) {
+		$maturity = BUGGY;
+	}
+	elsif ( $content =~ qr/\bTODO\b/ ) {
+		$maturity = INCOMPLETE;
+	}
+	else {
+		$maturity //= USABLE;
+	}
+
+	$state->{$category}{$doc}{maturity} = $maturity;
+	$log->trace("found docfile: $doc", { maturity => $maturity });
+}
+
+
+=head1 MATURITY
+
+=head2 Documentation file
+
+A documentation file is considered broken
+if it contains any B<FIXME> annotations,
+or otherwise considered unfinished
+if it contains any B<TODO> annotations.
+
+=head2 Targeted documentation
+
+A targeted documentation,
+for each of the Redpill targets B<executive>, B<user> and B<expert>,
+is as mature as the most mature of their files,
+or unusable if none exist for the target.
+
+=head2 Feature
+
+A feature is as mature as the most mature targeted documentation,
+except it is at most unfinished
+unless documentation complies with standard-readme specification.
+
+=head1 ENVIRONMENT
+
+=over 6
+
+=item NO_COLOR
+
+If defined, will disable color.
+Consulted before COLOR.
+
+=item COLOR
+
+Can be set to 0 to explicitly disable colors.
+The default is to use color when connected to a terminal.
+
+=item LOG_LEVEL
+=item QUIET
+=item VERBOSE
+=item DEBUG
+=item TRACE
+
+Used to emit varying details about discoveries to STDERR.
+See L<Log::Any::Adapter::Screen> for more details.
+
+=item LOG_PREFIX
+
+The default formatter groks these variables.
+See B<formatter> in L<Log::Any::Adapter::Screen> for more details.
+
+=back
+
+=encoding UTF-8
+
+=head1 AUTHOR
+
+Jonas Smedegaard C<< <dr@jones.dk> >>
+
+=head1 COPYRIGHT AND LICENSE
+
+  Copyright © 2021 Jonas Smedegaard
+
+This program is free software:
+you can redistribute it and/or modify it
+under the terms of the GNU Affero General Public License
+as published by the Free Software Foundation,
+either version 3, 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 Affero General Public License for more details.
+
+You should have received a copy
+of the GNU Affero General Public License along with this program.
+If not, see <https://www.gnu.org/licenses/>.
+
+=cut
+
+1;