# This file is part of GNU Pies.
# Copyright (C) 2020-2021 Sergey Poznyakoff
#
# GNU Pies 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 3, or (at your option)
# any later version.
#
# GNU Pies 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 GNU Pies. If not, see .
use strict;
use warnings;
use Getopt::Long qw(:config gnu_getopt no_ignore_case);
use File::Basename;
use File::Spec;
use File::Path qw(make_path);
use Pod::Usage;
my $dirname = '.';
my $pkgname;
my $srcname;
my $output_name;
my @includes;
GetOptions("h" => sub {
pod2usage(-message => "$0: generate docs",
-exitstatus => 0);
},
"help" => sub {
pod2usage(-exitstatus => 0, -verbose => 2);
},
"usage" => sub {
pod2usage(-exitstatus => 0, -verbose => 0);
},
'source|s=s' => \$srcname,
'directory|C=s' => \$dirname,
'output|o=s' => \$output_name,
'include|I=s@' => \@includes
) or exit(1);
$pkgname = shift @ARGV or pod2usage(-exitstatus => 1, -verbose => 0);
$srcname //= "${pkgname}.texi";
my $template_name = shift @ARGV or pod2usage(-exitstatus => 1, -verbose => 0);
unless (-d $dirname) {
make_path($dirname);
}
unless ($output_name) {
$output_name = File::Spec->catfile($dirname, (fileparse($template_name, qr/\.[^.]*/))[0]);
}
if (@includes) {
@includes = map { '-I '.$_} @includes;
# FIXME: Not used yet
}
sub template_scan {
my $file = shift;
open(FH, '<', $file) or die "can't open $file: $!\n";
my $line = 0;
while () {
chomp;
++$line;
s{ \$ ((?:BASE)?FILE|SIZE) \( ([a-z_]+) \) }{
eval { Gendocs->instance($2, $pkgname, $srcname) };
if ($@) {
if ($@ =~ m{Can't locate object method "new"}) {
die "$file:$line: unknown format: $2\n";
} else {
die $@;
}
}
}gex;
}
close FH
}
sub template_expand {
my ($infile, $outfile) = @_;
open(IFH, '<', $infile) or die "can't open $infile: $!\n";
open(OFH, '>', $outfile) or die "can't open $outfile: $!\n";
while () {
chomp;
s{ \$ ((?:BASE)?FILE|SIZE) \( ([a-z_]+) \) }{
if ($1 eq 'FILE') {
Gendocs->instance($2)->output;
} elsif ($1 eq 'BASEFILE') {
basename(Gendocs->instance($2)->output);
} else {
Gendocs->instance($2)->size;
}
}gex;
print OFH "$_\n";
}
}
template_scan $template_name;
Gendocs->generate();
template_expand($template_name, $output_name);
Gendocs->sweep();
package Gendocs;
use strict;
use warnings;
my %registry;
sub generate {
my ($class) = @_;
my @keys = keys %registry;
foreach my $k (@keys) {
$registry{$k}->build();
$registry{$k}->mark();
}
}
sub sweep {
my ($class) = @_;
my @keys = keys %registry;
foreach my $k (@keys) {
unless ($registry{$k}->has_mark) {
$registry{$k}->remove;
delete $registry{$k};
}
}
}
sub new {
my ($class, $pkgname, $name) = @_;
unless (exists($registry{$class})){
$registry{$class} = bless { pkgname => $pkgname, input => $name }, $class;
}
return $registry{$class}
}
sub instance {
my ($class, $fmt, @args) = @_;
my $subclass = "Gendocs::".ucfirst($fmt);
unless (exists($registry{$subclass})) {
$registry{$subclass} = $subclass->new(@args);
}
return $registry{$subclass};
}
sub runcom {
my $self = shift;
system @_;
if ($? == -1) {
die "failed to execute $_[0]: $!";
} elsif ($? & 127) {
die sprintf("$_[0] died with signal %d\n", $? & 127);
} elsif ($? >> 8) {
warn sprintf("$_[0] exited with value %d\n", $? >> 8);
}
}
sub mark { shift->{mark} = 1 }
sub has_mark { shift->{mark} }
sub remove {
my ($self) = @_;
if ($self->{output}) {
unlink $self->{output};
delete $self->{output};
}
}
sub size {
my ($self) = @_;
my $s = (stat($self->output))[7];
if ($s > 1048576) {
$s = int($s / 1048576) . 'M';
} elsif ($s > 1024) {
$s = int($s / 1024) . 'K';
}
return $s;
}
sub pkgname { shift->{pkgname} }
sub input { shift->{input} }
sub output { shift->{output} }
package Gendocs::Makeinfo;
use strict;
use warnings;
use base 'Gendocs';
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
$self->{makeinfo} = $ENV{'MAKEINFO'} || 'makeinfo';
return $self;
}
package Gendocs::Info;
use strict;
use warnings;
use base 'Gendocs::Makeinfo';
sub build {
my ($self) = @_;
unless ($self->{output}) {
my $output = File::Spec->catfile($dirname, $self->pkgname . '.info');
print "Generating info file: " . $self->input . " -> $output\n";
$self->runcom("$self->{makeinfo} -o $output " . $self->input);
$self->{output} = $output;
}
return $self->{output};
}
package Gendocs::Info_gz;
use strict;
use warnings;
use base 'Gendocs';
sub build {
my ($self) = @_;
unless ($self->{output}) {
my $input = Gendocs->instance('info', $self->pkgname, $self->input)->build();
my $output = "$input.gz";
print "Compressing info file: $input -> $output\n";
$self->runcom("gzip -f -9 -c $input > $output");
$self->{output} = $output;
}
return $self->{output};
}
package Gendocs::Ascii;
use strict;
use warnings;
use base 'Gendocs::Makeinfo';
sub build {
my ($self) = @_;
unless ($self->{output}) {
my $output = File::Spec->catfile($dirname, $self->pkgname . '.txt');
print "Generating ascii file: " . $self->input . " -> $output\n";
$self->runcom("$self->{makeinfo} -o $output --no-split --no-headers " . $self->input);
$self->{output} = $output;
}
return $self->{output};
}
package Gendocs::Ascii_gz;
use strict;
use warnings;
use base 'Gendocs';
sub build {
my ($self) = @_;
unless ($self->{output}) {
my $input = Gendocs->instance('ascii', $self->pkgname, $self->input)->build();
my $output = "$input.gz";
print "Compressing ascii file: $input -> $output\n";
$self->runcom("gzip -f -9 -c $input > $output");
$self->{output} = $output;
}
return $self->{output};
}
package Gendocs::Texinfo_gz;
use strict;
use warnings;
use base 'Gendocs';
sub build {
my ($self) = @_;
unless ($self->{output}) {
my $output = File::Spec->catfile($dirname, $self->pkgname . '.tar.gz');
print "Creating compressed sources: $output\n";
$self->runcom("tar czfh $output *.texinfo *.texi *.txi *.eps 2>/dev/null || /bin/true");
$self->{output} = $output;
}
return $self->{output};
}
package Gendocs::Dvi;
use strict;
use warnings;
use base 'Gendocs';
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
$self->{texi2dvi} = $ENV{'TEXI2DVI'} || 'texi2dvi --build=tidy -t @finalout';
return $self;
}
sub build {
my ($self) = @_;
unless ($self->{output}) {
my $output = File::Spec->catfile($dirname, $self->pkgname . '.dvi');
my $cmd = "$self->{texi2dvi} -o $output $self->{input}";
print "Creating dvi: $cmd\n";
$self->runcom($cmd);
$self->{output} = $output;
}
return $self->{output};
}
package Gendocs::Dvi_gz;
use strict;
use warnings;
use base 'Gendocs';
sub build {
my ($self) = @_;
unless ($self->{output}) {
my $input = Gendocs->instance('dvi', $self->pkgname, $self->input)->build();
my $output = "$input.gz";
print "Compressing dvi file: $input -> $output\n";
$self->runcom("gzip -f -9 -c $input > $output");
$self->{output} = $output;
}
return $self->{output};
}
package Gendocs::Pdf;
use strict;
use warnings;
use base 'Gendocs::Dvi';
sub build {
my ($self) = @_;
unless ($self->{output}) {
my $output = File::Spec->catfile($dirname, $self->pkgname . '.pdf');
my $cmd = "$self->{texi2dvi} -o $output --pdf $self->{input}";
print "Creating pdf: $cmd\n";
$self->runcom($cmd);
$self->{output} = $output;
}
return $self->{output};
}
__END__
=head1 NAME
gendocs.pl - generate documentation in various formats
=head1 SYNOPSIS
B
[B<-C> I]
[B<-s> I