view release on metacpan or  search on metacpan

eg/manpath.PL  view on Meta::CPAN

#!/usr/bin/env perl

use 5.008;

use strict;
use warnings;

use Config;
use Cwd qw{ abs_path };
use Getopt::Long 2.33 qw{ :config auto_version };
use File::Glob qw{ bsd_glob };
use File::Spec;
use List::Util qw{ uniq };
use Pod::Usage;

our $VERSION = '0.014';

use constant PATH_SEP	=> qr/ $Config{path_sep} /smx;
use constant MANPATH_APPEND	=> qr/ (?<= $Config{path_sep} \z ) /smx;
use constant MANPATH_EMBED	=>
    qr/ (?<= $Config{path_sep} ) (?= $Config{path_sep} ) /smx;
use constant MANPATH_PREPEND	=> qr/ \A (?= $Config{path_sep} ) /smx;
use constant MAN_CONF	=> {
    darwin	=> [ '/private/etc/man.conf' ],
    freebsd	=> [ '/etc/man.conf', '/usr/local/etc/man.d/*.conf' ],
    haiku	=> [ '/packages/man-*/.settings/man.conf' ],
    linux	=> [ '/etc/manpath.config' ],
    openbsd	=> [ '/etc/man.conf' ],
}->{$^O} || [];

my %opt = (
    1	=> ! -t STDOUT,
);

GetOptions( \%opt,
    qw{ 1! debug! },
    help => sub { pod2usage( { -verbose => 2 } ) },
) or pod2usage( { -verbose => 0 } );

my $exit_status = 0;

if ( @ARGV ) {
    my @manpath = man_path();
    while ( @ARGV ) {
	my $section = ( @ARGV > 1 && $ARGV[0] =~ m/ \A [1-9] \z /smx ) ?
	    shift @ARGV : undef;
	my $prog = shift @ARGV;
	if ( my $path = find_man( $prog, $section ) ) {
	    print "$path\n";
	    $exit_status = 0;
	} elsif ( defined $section ) {
	    warn "No entry for $prog in section $section of the manual\n";
	    $exit_status = 1;
	} else {
	    warn "No manual entry for $prog\n";
	    $exit_status = 1;
	}
    }
} else {
    local $\ = "\n";
    if ( $opt{1} ) {
	print for man_path();
    } else {
	print join $Config{path_sep}, man_path();
    }
}

exit $exit_status;

sub find_man {
    my ( $prog, $section ) = @_;

    defined $section
	or $section = '?';

    # NOTE: Experimentation with Linux shows that locale is applied here
    # rather than in man_path. Furthermore,
    # env LC_MESSAGES=es_ES.UTF-8 man -w man
    # prints '/usr/share/man/es/man1/man.1.gz'
    # Even further more, environment variables appear to be taken in the

eg/manpath.PL  view on Meta::CPAN

    # Or maybe the territory gets delimited by [_-] rather than [_],
    # though I think not.
    # https://www.shellhacks.com/linux-define-locale-language-settings/
    # was helpful here. See also
    # https://en.wikipedia.org/wiki/Locale_(computer_software)
    # Unfortunately the referenced ISO/IEC 15897 costs CHF 158 per
    # https://www.iso.org/standard/50707.html

    my @lang_dir;
    foreach my $env_name ( qw{ LC_MESSAGES LC_ALL LANG LANGUAGE } ) {
	defined $ENV{$env_name}
	    or next;
	$opt{debug}
	    and warn "Debug - translating $env_name";
	my ( $language, $territory, $codeset, $modifiers ) =
	$ENV{$env_name} =~ m/ \A
	    ( [[:alpha:][:digit:]]+ )	# language
	    ( _ \w+ )?			# territory
	    ( [.] [\w-]+ )?		# codeset
	    ( \@ .+)?			# modifier
	    \z /smx
	    or die "Invalid $env_name '$ENV{$env_name}";
	foreach ( $territory, $codeset, $modifiers ) {
	    defined $_
		or $_ = '';
	}
	push @lang_dir, "/$ENV{$env_name}", "/$language$territory",
	    "/$language";
	last;
    }
    @lang_dir = uniq( @lang_dir, '' );
    if ( $opt{debug} ) {
	require Data::Dumper;
	no warnings qw{ once };
	local $Data::Dumper::Indent = 1;
	local $Data::Dumper::Terse = 1;
	local $Data::Dumper::Sortkeys = 1;
	warn 'Debug - lang_dir is ', Data::Dumper::Dumper( \@lang_dir );
    }

    foreach my $dir ( man_path () ) {
	foreach my $lang ( @lang_dir ) {
	    foreach my $suffix ( '', "man$section/" ) {
		foreach my $path (
		    bsd_glob( "$dir$lang/$suffix$prog.$section*" )
		) {
		    return $path;
		}
	    }
	}
    }
    return;
}

sub man_path {

    my $manpath = $ENV{MANPATH};

    if ( defined $manpath ) {
	$manpath =~ MANPATH_PREPEND
	    or $manpath =~ MANPATH_EMBED
	    or $manpath =~ MANPATH_APPEND
	    or return split PATH_SEP, $ENV{MANPATH};
    }

    my $auto_path = ! {
	openbsd	=> 1,
    }->{$^O};
    my @man_path;
    my %man_path_map = map { $_ => undef } File::Spec->path();
    my @mandatory;

    foreach my $man_conf ( map { bsd_glob( $_ ) } @{ ( MAN_CONF ) } ) {
	open my $fh, '<', $man_conf
	    or next;
	local $_ = undef;	# while (<>) ... does not localize $_.
	while ( <$fh> ) {
	    m/ \A \s* (?: \z | [#] ) /smx
		and next;
	    s/ \A \s+ //smx;
	    s/ \s+ \z //smx;
	    my ( $verb, @arg ) = split qr< \s+ >smx;
	    my $code = {
		AUTOPATH	=> sub {
		    $auto_path = 0;
		},
		MANDATORY_MANPATH	=> sub {
		    -d $arg[0]
			and push @mandatory, $arg[0];
		},
		MANPATH		=> sub {
		    -d $arg[0]
			and push @man_path, $arg[0];
		},
		manpath		=> sub {
		    -d $arg[0]
			and push @man_path, $arg[0];
		},
		MANPATH_MAP	=> sub {
		    exists $man_path_map{$arg[0]}
			and @arg > 1
			and -d $arg[1]
			and push @{ $man_path_map{$arg[0]} }, $arg[1];
		},
	    }->{$verb}
		or next;
	    $code->();
	}
    }
    push @man_path, @mandatory;
    push @man_path, grep { -d } @{
	{
	    darwin	=> [ qw{
		/Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX.sdk/usr/share/man
		/Applications/Xcode.app/Contents/Developer/usr/share/man
		/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/share/man
		}
	    ]
	}->{$^O} || []
    };

    unless ( @man_path || $auto_path ) {
	push @man_path, grep { -d } @{
	{
	    openbsd	=> [ qw{ /usr/share/man /usr/X11R6/man
		/usr/local/man } ],
	}->{$^O} || [] };
    }

    {
	my @auto;
	foreach my $path ( File::Spec->path() ) {
	    if ( $man_path_map{$path} ) {
		push @auto, @{ $man_path_map{$path} };
	    } elsif ( $auto_path ) {
		foreach my $suffix (
		    qw{ share/man share/openssl/man man }
		) {
		    my $man = abs_path( "$path/../$suffix" )
			or next;
		    -d $man
			or next;
		    push @auto, $man;
		}
	    }
	}
	splice @man_path, 0, 0, @auto;

	if ( defined $manpath ) {
	    my $dflt = join $Config{path_sep}, @man_path;
	    foreach my $re ( MANPATH_PREPEND, MANPATH_EMBED,
		MANPATH_APPEND ) {
		$manpath =~ s/ $re /$dflt/smx
		    and last;
	    }
	    @man_path = split PATH_SEP, $manpath;
	}
    }

    return uniq( @man_path );
}

__END__

=head1 TITLE

manpath.PL - Perl implementation of the manpath (1) command

=head1 SYNOPSIS

 manpath.PL
 manpath.PL -help
 manpath.PL -version

=head1 OPTIONS

=head2 -1

If this Boolean option is asserted, output is one path per line. If
negated, output is all on one line, separated by the system's path
separator. Yes, the name of the option is the digit C<1>, not a
lower-case letter "ell". Think L<ls (1)>.

The default is C<-no-1> if output is to a terminal, or C<-1> otherwise.

=head2 -debug

If this Boolean option is asserted, debug information is sent to STDERR.

The default is C<-nodebug>.

=head2 -help

This option displays the documentation for this script. The script then
exits.

=head2 -version

This option displays the version of this script. The script then exits.

=head1 DETAILS

This Perl script attempts to implement the L<manpath (1)> command.
Originally it was a study in whether it was practical to look up
L<man (1)> pages directly rather than spawn the L<man (1)> command.

By value of C<$^O>, here are the results so far:

=over

=item darwin