fradrive/utils/makehelp.pl

#!/usr/bin/env perl

use strict;
use warnings;

my %msg = ();
my %reorder = (help=>-1);

# We do not want every Makefile syntax error to break help completely,
# so we just disable the kind of features where the syntax error occurs
# In that case we store also the error message here
my %brokenFeatures = ();

my @blocks = ();
my @plainCode = ();

READ: while(<>) {
  my $lnum = $.;
  if(m/^# HELP HEADER START/) {
    my @start = ();
    while(<>) {
      do {
        push @blocks, { kind=>'start', text=>\@start, line=>$lnum };
        next READ
      } if m/^# HELP HEADER END/;
      if(m/# (.*)/) {
        push @start, $1
      } else {
        die "$0: Invalid HELP HEADER section in Makefile!\n";
      }
    }
    push @blocks, { kind=>'start', text=>\@start, line=>$lnum };
    next READ
  }
  if(m/^# HELP((?:\((?:[^\(\)]|\([^\(\)]+\))+\))?):\s*(.*)/) {
    my ($target, $message) = ($1, $2);
    if($target=~m/\((.*)\)/) {
      $target = $1;
    } else {
      my $line = <>;
      die "$0: Unexpected end of file, target expected!\n" if not defined $line;
      $line=~m/^([^:]+):/ or die "$0: HELP marker expects target but no target found!\n";
      $target = $1
    }
    push @blocks, { kind=>'target', target=>$target, message=>$message, line=>$lnum };
    next READ
  }
  if(m/^# HELPVAR\((.*)\)/) {
    push @blocks, { kind=>'helpvar', content=>$1, line=>$lnum };
    next READ;
  }
  push @plainCode, [$lnum, $_]
}

my %kindBlocks = ();
for(@blocks) {
  push @{$kindBlocks{$_->{kind}}}, $_
}

my @matchies = ();
HELPVARS: {
  for my $hv(@{$kindBlocks{helpvar}}) {
    my $reVar = qr((?:\$\((?<name>[A-Z]+)(?:,(?<re>[^\(\)]+))?\)));
    my $reVarNoGroups = qr((?:\$\((?:[A-Z]+)(?:,(?:[^\(\)]+))?\)));
    my @parts = split /($reVarNoGroups)/, $hv->{content};
    my %setvars = ();
    my @reParts = ();
    for my $p(@parts) {
      if($p=~m#^$reVar$#) {
        my $name = $+{name};
        my $re = $+{re};
        if(defined $re) {
          if(exists $setvars{$name}) {
            $brokenFeatures{helpvars} = "Makefile line $hv->{line}: Multiple definitions of variable $name found!";
            last HELPVARS
          }
          $setvars{$name} = $re;
          push @reParts, [1,qr((?<$name>$re))];
        } else {
          if(not exists $setvars{$name}) {
            $brokenFeatures{helpvars} = "Makefile line $hv->{line}: Variable $name used without definition!";
            last HELPVARS
          }
          push @reParts, [0,$name]; #qr((?:\k<$name>)); -- problem: cannot reference variable when not defined
        }
      } else {
        push @reParts, [1,qr((?:\Q$p\E))];
      }
    }
    my $reCol = qr((?:));
    for my $r(@reParts) {
      my ($isRe, $reg) = @$r;
      if($isRe) {
        $reCol = qr((?:$reCol$reg));
      } else {
        eval {
        $reCol = qr((?:$reCol(?:\k<$reg>)));
        };
        if($@) {
          $brokenFeatures{helpvars} = "Makefile line $hv->{line}: Variable $reg caused an internal error ($@)!";
          last HELPVARS
        }
      }
    }
    push @matchies, $reCol
  }
}

my %helpvars = ();

for my $rowr(@plainCode) {
  my ($lnum, $row) = @$rowr;
  my @matches = ();
  for my $re(@matchies) {
    if($row=~m#^$re$#) {
      my %h = %+;
      push @matches, \%h
    }
  }
  if(@matches>1) {
    $brokenFeatures{helpvars} = "Makefile line $lnum: Multiple variable definitions match on row '$row'\n";
  }
  if(1==@matches) {
    my %h = %{$matches[0]};
    for my $k(keys %h) {
      push @{$helpvars{$k}}, $h{$k}
    }
  }
}

my @start = ();
@start = @{$kindBlocks{start}} if exists $kindBlocks{start};

for my $tg(@{$kindBlocks{target}}) {
  my $tgv = $tg->{target};
  my @build = ();
  $tgv=~s#\$\(([A-Z]+)(?:,[^\(\)]*)?\)#push @build, {name=>$1,elm=>$helpvars{$1}}; $1#ge;
  unshift @build, $tg->{message};
  $msg{$tgv} = \@build;
}

sub msgprinter {
  my $el = shift;
  if('HASH' eq ref $el) {
    print "  Where $el->{name} is one of\n";
    print "    $_\n" for @{$el->{elm}};
    return
  }
  $el =~ s#(.{40,76})\s+#$1\n  #g;
  print "  $el\n";
}

for(@start) {
  print "$_\n" for @{$_->{text}}
}
print "\n" if @start;
for my $tar(sort {($reorder{$a}||0) <=> ($reorder{$b}||0) || $a cmp $b } keys %msg) {
  print "$tar\n";
  msgprinter($_) for @{$msg{$tar}};
  print "\n";
}

for my $k(keys %brokenFeatures) {
  warn "\n!!!!!\nFailed to complete construct the help message from the Makefile.\nFeature '$k' disabled, because: $brokenFeatures{$k}\n\n";
}