aboutsummaryrefslogtreecommitdiff
path: root/bin/feature-check.pl
blob: fca50a9fe2d9391b575bb9ddcef7b70b013d63e6 (plain)
  1. #!/usr/bin/perl
  2. use v5.14;
  3. use utf8;
  4. use warnings;
  5. no warnings 'experimental::smartmatch';
  6. use open qw( :std :encoding(UTF-8) );
  7. use Getopt::Long 2.24 qw(:config gnu_getopt);
  8. use IO::Interactive qw(is_interactive);
  9. my $USE_COLOR;
  10. BEGIN {
  11.     $USE_COLOR = !(
  12.            exists $ENV{NO_COLOR}
  13.         or $ENV{COLORand !$ENV{COLOR} )
  14.         or !is_interactive
  15.     );
  16.     $Pod::Usage::Formatter 'Pod::Text::Color' if $USE_COLOR;
  17. }
  18. use Pod::Usage;
  19. my $COPYRIGHT;
  20. use Pod::Constants
  21.     -trim => 1,
  22.     'COPYRIGHT AND LICENSE' =>
  23.     sub { ($COPYRIGHT) = s/C<< (.*) >>/$1/gr$COPYRIGHT =~ s/©/©/g };
  24. use List::Util qw(max);
  25. use Readonly::Tiny;
  26. use Path::Tiny;
  27. use Log::Any qw($log);
  28. use Log::Any::Adapter;
  29. use Term::Table;
  30. use Graph::Easy;
  31. use Graph::Easy::Parser;
  32. # TODO: handle options --quiet/--verbose/--debug
  33. # TODO: handle output scope, with options --threshold/--all
  34. # TODO: handle custom basepath (with builtin as default), taken as argument
  35. # TODO: handle multiple basepaths
  36. # TODO: check scripts (not only documentation)
  37. Log::Any::Adapter->set( 'Screen', use_color => $USE_COLOR );
  38. =head1 NAME
  39. feature-check - examine maturity and availability status of Redpill features
  40. =head1 VERSION
  41. Version v0.1.0
  42. =cut
  43. our $VERSION = 'v0.1.0';
  44. my $progname = path($0)->basename;
  45. our %OPT = ();
  46. my @OPT = ();
  47. =head1 SYNOPSIS
  48.     feature-check [ --help | --version ]
  49.     feature-check [OPTION...]
  50.     feature-check --format graphviz | fdp -Tx11
  51. =head1 DESCRIPTION
  52. B<feature-check> is a command-line tool
  53. to parse and examine a set of Redpill features,
  54. and print a summary on standard output.
  55. Usability of each feature is evaluated
  56. based on coverage and embedded annotations of its documentation.
  57. =head1 OPTIONS
  58. =head2 Rendering
  59. =over 16
  60. =item B<--format>
  61. Output format, either of I<table> I<ascii> I<ansi> I<svg> I<inkscape> I<graphviz>
  62. S<(default value: I<ansi>)>
  63. =back
  64. =cut
  65. push @OPT, qw(
  66.     format=s
  67. );
  68. $OPT{'format'} = 'ansi';
  69. =head2 General
  70. =over 16
  71. =item B<-h>, B<--help>
  72. print help message and exit
  73. =item B<--man>
  74. print manual and exit
  75. =item B<-v>, B<--version>
  76. print version and copyright information and exit
  77. =back
  78. =cut
  79. push @OPTqw(
  80.     verbose
  81.     help|h
  82.     man
  83.     version|v
  84. );
  85. GetOptions\%OPT@OPT or pod2usage(2);
  86. pod2usage(1if $OPT{help} );
  87. pod2usage(-exitval => 0, -verbose => 2)  if ($OPT{man});
  88. if $OPT{version} ) { version(); exit 0; }
  89. pod2usagejoin "\n"map {"Unknown argument: $_"@ARGV )
  90.     if @ARGV;
  91. my $BASEDIR path('../..');
  92. my @TARGET qw(executive user expert);
  93. readonly \@TARGET;
  94. my @MATURITY qw(unusable buggy incomplete usable good);
  95. readonly \@MATURITY;
  96. use enum qw(
  97.     UNUSABLE=0 BUGGY INCOMPLETE USABLE GOOD
  98.     EXECUTIVE=0 USER EXPERT
  99. );
  100. my %DOCFILE = (
  101.     ADMIN    => EXPERT,
  102.     INTRO    => USER,
  103.     OVERVIEW => EXECUTIVE,
  104.     README   => EXECUTIVE,
  105.     SETUP    => EXPERT,
  106.     USE      => USER,
  107. );
  108. readonly \%DOCFILE;
  109. my $threshold USABLE;
  110. $log->info("acceptance threshold: $MATURITY[$threshold]");
  111. my $graph Graph::Easy::Parser->from_text('graph { flow: east; }');
  112. $graph->catch_messages(1);
  113. my $root 'features';
  114. my $featureref path("$BASEDIR")->visit\&feature );
  115. #use DDP; p $featureref if $log->is_debug;
  116. my @row%node );
  117. $node{$root} = $graph->add_node($root);
  118. for my $feature sort keys %$featureref ) {
  119.     my @target @$featureref->{$feature}{target} };
  120.     next unless $featureref->{$feature}{maturity} >= $threshold;
  121.     push @row, [ $featuremap join ', 'sort keys %{ $target[$_]{docs} } if $target[$_]{maturity} >= $threshold EXECUTIVE..EXPERT ]
  122.         if $featureref->{$feature}{maturity} >= $threshold;
  123.     next if defined $node{$feature};
  124.     $node{$feature} = undef;
  125. }
  126. for my $feature sort keys %node ) {
  127.     next if defined $node{$feature};
  128.     if $feature =~ /^([^-]+).*\K-(?=[^-]+$)/ and defined $node{$`} and !defined $node{$feature} ) {
  129.         ( undef, $node{$feature} ) = $graph->add_edge( $node{$`}, $feature );
  130.         $node{$feature}->set_attribute'label',  $feature );
  131.     }
  132.     else {
  133.         undef$node{$feature} ) = $graph->add_edge$node{$root}, $feature );
  134.     }
  135. }
  136. my $table Term::Table->new(
  137.     header => [ 'feature'@TARGET ],
  138.     rows   => \@row,
  139. );
  140. for $OPT{format} ) {
  141.     when ('table') { map say $_ $table->render }
  142.     when ('ascii') { print $graph->as_ascii() }
  143.     when ('ansi') { print $graph->as_boxart() }
  144.     when ('svg') { print $graph->as_svg() }
  145.     when ('graphviz') { print $graph->as_graphviz() }
  146.     when ('inkscape') {
  147.         $_ $graph->as_svg();
  148.         # define Inkscape namespace, for declaring "connectors"
  149.         s{<svg\s[^>]*\K}{ xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"};
  150.         # collect identifiers for nodes
  151.         my %node;
  152.         $node{$2} = $1 while m{<g\s+id="(\d+)"\s+class="node">\s*<!--\s*(\S+),\s+rect\s+-->}g;
  153.         # replace concrete arrows with abstract "connectors"
  154.         s{
  155.             class="edge">\s*
  156.             <!--\s+
  157.                 from\s+(?<from>\S+)\s+
  158.                 to\s+(?<to>\S+)\s+
  159.             -->(?<space>\s*)
  160.             # drop these
  161.             \K
  162.             (?:
  163.                 \s*<!--\s*[^>]*\s*-->
  164.                 (?:
  165.                     \s*<line\s[^>]*>
  166.                 |
  167.                     \s*<g\s+[^>]*>
  168.                     \s*<line\s[^>]*>
  169.                     \s*<line\s[^>]*>
  170.                     \s*</g>
  171.                 )
  172.             )+
  173.             \s*<use\s[^>]*>
  174.         }{ inkscape_path\%+, \%node ) }gsxe;
  175.         # keep edges away from nodes
  176.         s{<g\s+id="(\d+)"\s+class="node"\K}{ inkscape:connector-avoid="true"}g;
  177.         # fix styling of edges
  178.         s/\.edge\s*{\s*font-size:\s*13px;(\s*)stroke:(\s*)black;\K/$1fill:$2none;/;
  179.         print $_;
  180.     }
  181.     default $log->fatal("unsupported format:$_") && exit }
  182. }
  183. $log->error($_for $graph->errors();
  184. $log->warn($_for $graph->warnings();
  185. sub inkscape_path {
  186.     my $mref$nref ) = @_;
  187.     return join $mref->{space},
  188.         "<path d=\"\" inkscape:connector-type=\"polyline\"",
  189.         " inkscape:connector-curvature=\"0\"",
  190.         " inkscape:connection-start=\"#$nref->{$mref->{from}}\"",
  191.         " inkscape:connection-end=\"#$nref->{$mref->{to}}\" />"
  192. }
  193. sub feature {
  194.     my ($path$state) = @_;
  195.     my $feature$docs$maturity );
  196.     return unless $path->is_dir;
  197.     return if $path->basename =~ qr/\.$/;
  198.     $feature $path->basename;
  199.     $log->trace("found feature: $feature");
  200.     $docs $path->visit\&docfile );
  201.     for my $target (EXECUTIVE..EXPERT) {
  202.         my $maturity;
  203.         if exists $docs->{$target} ) {
  204.             $state->{$feature}{target}[$target]{docs} = $docs->{$target};
  205.             $maturity max map $_->{maturity} } values %{ $docs->{$target} };
  206.         }
  207.         else {
  208.             $maturity UNUSABLE;
  209.         }
  210.         $state->{$feature}{target}[$target]{maturity} = $maturity;
  211.         $log->debug("resolved feature $feature target $target maturity: $maturity");
  212.     }
  213.     if exists $state->{$feature}{target}[EXECUTIVE]{docs} && exists $state->{$feature}{target}[EXECUTIVE]{docs}{README} ) {
  214.         $maturity $state->{$feature}{target}[EXECUTIVE]{maturity};
  215.     }
  216.     elsif INCOMPLETE $state->{$feature}{target}[EXECUTIVE]{maturity} ) {
  217.         $maturity INCOMPLETE;
  218.     }
  219.     else {
  220.         $maturity $state->{$feature}{target}[EXECUTIVE]{maturity};
  221.     }
  222.     $state->{$feature}{maturity} = $maturity;
  223.     $log->warningf('skipping %s feature: %s'$MATURITY[$maturity], $feature)
  224.         if $maturity $threshold;
  225. }
  226. sub docfile {
  227.     my ($path$state) = @_;
  228.     my $doc$category$content$maturity );
  229.     return unless $path->is_file;
  230.     $doc $path->basename('.md');
  231.     return if $path->basename eq $doc;
  232.     return unless exists $DOCFILE{$doc};
  233.     $category $DOCFILE{$doc}
  234.         // return;
  235.     $content $path->slurp_utf8;
  236.     if $content =~ qr/\bFIXME\b/ ) {
  237.         $maturity BUGGY;
  238.     }
  239.     elsif $content =~ qr/\bTODO\b/ ) {
  240.         $maturity INCOMPLETE;
  241.     }
  242.     else {
  243.         $maturity //USABLE;
  244.     }
  245.     $state->{$category}{$doc}{maturity} = $maturity;
  246.     $log->trace("found docfile: $doc", { maturity => $maturity });
  247. }
  248. =head1 MATURITY
  249. =head2 Documentation file
  250. A documentation file is considered broken
  251. if it contains any B<FIXME> annotations,
  252. or otherwise considered unfinished
  253. if it contains any B<TODO> annotations.
  254. =head2 Targeted documentation
  255. A targeted documentation,
  256. for each of the Redpill targets B<executive>, B<user> and B<expert>,
  257. is as mature as the most mature of their files,
  258. or unusable if none exist for the target.
  259. =head2 Feature
  260. A feature is as mature as the most mature targeted documentation,
  261. except it is at most unfinished
  262. unless documentation complies with standard-readme specification.
  263. =head1 ENVIRONMENT
  264. =over 6
  265. =item NO_COLOR
  266. If defined, will disable color.
  267. Consulted before COLOR.
  268. =item COLOR
  269. Can be set to 0 to explicitly disable colors.
  270. The default is to use color when connected to a terminal.
  271. =item LOG_LEVEL
  272. =item QUIET
  273. =item VERBOSE
  274. =item DEBUG
  275. =item TRACE
  276. Used to emit varying details about discoveries to STDERR.
  277. See L<Log::Any::Adapter::Screen> for more details.
  278. =item LOG_PREFIX
  279. The default formatter groks these variables.
  280. See B<formatter> in L<Log::Any::Adapter::Screen> for more details.
  281. =back
  282. =encoding UTF-8
  283. =head1 AUTHOR
  284. Jonas Smedegaard C<< <dr@jones.dk> >>
  285. =head1 COPYRIGHT AND LICENSE
  286.   Copyright 2021-2022  Jonas Smedegaard
  287. This program is free software:
  288. you can redistribute it and/or modify it
  289. under the terms of the GNU Affero General Public License
  290. as published by the Free Software Foundation,
  291. either version 3, or (at your option) any later version.
  292. This program is distributed in the hope that it will be useful,
  293. but WITHOUT ANY WARRANTY;
  294. without even the implied warranty
  295. of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  296. See the GNU Affero General Public License for more details.
  297. You should have received a copy
  298. of the GNU Affero General Public License along with this program.
  299. If not, see <https://www.gnu.org/licenses/>.
  300. =cut
  301. 1;