aboutsummaryrefslogtreecommitdiff
path: root/bin/feature-check.pl
blob: 12ae7edbe453fa34efab10aa270a3cfca940c755 (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{COLOR} and !$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<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 @OPT, qw(
  80. verbose
  81. help|h
  82. man
  83. version|v
  84. );
  85. GetOptions( \%OPT, @OPT ) or pod2usage(2);
  86. pod2usage(1) if ( $OPT{help} );
  87. pod2usage(-exitval => 0, -verbose => 2) if ($OPT{man});
  88. if ( $OPT{version} ) { version(); exit 0; }
  89. pod2usage( join "\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, [ $feature, map { 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. default { $log->fatal("unsupported format:$_") && exit 1 }
  147. }
  148. $log->error($_) for $graph->errors();
  149. $log->warn($_) for $graph->warnings();
  150. sub feature {
  151. my ($path, $state) = @_;
  152. my ( $feature, $docs, $maturity );
  153. return unless $path->is_dir;
  154. return if $path->basename =~ qr/\.$/;
  155. $feature = $path->basename;
  156. $log->trace("found feature: $feature");
  157. $docs = $path->visit( \&docfile );
  158. for my $target (EXECUTIVE..EXPERT) {
  159. my $maturity;
  160. if ( exists $docs->{$target} ) {
  161. $state->{$feature}{target}[$target]{docs} = $docs->{$target};
  162. $maturity = max map { $_->{maturity} } values %{ $docs->{$target} };
  163. }
  164. else {
  165. $maturity = UNUSABLE;
  166. }
  167. $state->{$feature}{target}[$target]{maturity} = $maturity;
  168. $log->debug("resolved feature $feature target $target maturity: $maturity");
  169. }
  170. if ( exists $state->{$feature}{target}[EXECUTIVE]{docs} && exists $state->{$feature}{target}[EXECUTIVE]{docs}{README} ) {
  171. $maturity = $state->{$feature}{target}[EXECUTIVE]{maturity};
  172. }
  173. elsif ( INCOMPLETE < $state->{$feature}{target}[EXECUTIVE]{maturity} ) {
  174. $maturity = INCOMPLETE;
  175. }
  176. else {
  177. $maturity = $state->{$feature}{target}[EXECUTIVE]{maturity};
  178. }
  179. $state->{$feature}{maturity} = $maturity;
  180. $log->warningf('skipping %s feature: %s', $MATURITY[$maturity], $feature)
  181. if $maturity < $threshold;
  182. }
  183. sub docfile {
  184. my ($path, $state) = @_;
  185. my ( $doc, $category, $content, $maturity );
  186. return unless $path->is_file;
  187. $doc = $path->basename('.md');
  188. return if $path->basename eq $doc;
  189. return unless exists $DOCFILE{$doc};
  190. $category = $DOCFILE{$doc}
  191. // return;
  192. $content = $path->slurp_utf8;
  193. if ( $content =~ qr/\bFIXME\b/ ) {
  194. $maturity = BUGGY;
  195. }
  196. elsif ( $content =~ qr/\bTODO\b/ ) {
  197. $maturity = INCOMPLETE;
  198. }
  199. else {
  200. $maturity //= USABLE;
  201. }
  202. $state->{$category}{$doc}{maturity} = $maturity;
  203. $log->trace("found docfile: $doc", { maturity => $maturity });
  204. }
  205. =head1 MATURITY
  206. =head2 Documentation file
  207. A documentation file is considered broken
  208. if it contains any B<FIXME> annotations,
  209. or otherwise considered unfinished
  210. if it contains any B<TODO> annotations.
  211. =head2 Targeted documentation
  212. A targeted documentation,
  213. for each of the Redpill targets B<executive>, B<user> and B<expert>,
  214. is as mature as the most mature of their files,
  215. or unusable if none exist for the target.
  216. =head2 Feature
  217. A feature is as mature as the most mature targeted documentation,
  218. except it is at most unfinished
  219. unless documentation complies with standard-readme specification.
  220. =head1 ENVIRONMENT
  221. =over 6
  222. =item NO_COLOR
  223. If defined, will disable color.
  224. Consulted before COLOR.
  225. =item COLOR
  226. Can be set to 0 to explicitly disable colors.
  227. The default is to use color when connected to a terminal.
  228. =item LOG_LEVEL
  229. =item QUIET
  230. =item VERBOSE
  231. =item DEBUG
  232. =item TRACE
  233. Used to emit varying details about discoveries to STDERR.
  234. See L<Log::Any::Adapter::Screen> for more details.
  235. =item LOG_PREFIX
  236. The default formatter groks these variables.
  237. See B<formatter> in L<Log::Any::Adapter::Screen> for more details.
  238. =back
  239. =encoding UTF-8
  240. =head1 AUTHOR
  241. Jonas Smedegaard C<< <dr@jones.dk> >>
  242. =head1 COPYRIGHT AND LICENSE
  243. Copyright 2021-2022 Jonas Smedegaard
  244. This program is free software:
  245. you can redistribute it and/or modify it
  246. under the terms of the GNU Affero General Public License
  247. as published by the Free Software Foundation,
  248. either version 3, or (at your option) any later version.
  249. This program is distributed in the hope that it will be useful,
  250. but WITHOUT ANY WARRANTY;
  251. without even the implied warranty
  252. of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  253. See the GNU Affero General Public License for more details.
  254. You should have received a copy
  255. of the GNU Affero General Public License along with this program.
  256. If not, see <https://www.gnu.org/licenses/>.
  257. =cut
  258. 1;