各種 BSDの manpagesを調べる

man.pl

#!/usr/bin/env perl
use strict;
use warnings;

use 5.010;

use Config::Pit;
use File::Which qw(which);
use Getopt::Long;
use URI;

my %os_version = (
    netbsd => 'NetBSD-current',
    freebsd => 'FreeBSD+8.1-RELEASE',
    openbsd => 'OpenBSD+Current',
);

my %base_url = (
    netbsd  => 'http://netbsd.gw.com/cgi-bin/man-cgi',
    freebsd => 'http://www.freebsd.org/cgi/man.cgi',
    openbsd => 'http://www.openbsd.org/cgi-bin/man.cgi',
);

my $w3m = which('w3m');
die "Please install w3m\n" unless $w3m;

GetOptions(
    "section|s=i" => \my $section,
    "apropos|a"   => \my $apropos,
);

unless (scalar @ARGV == 2) {
    die "Usage $0 (Free|Net|Open)[BSD] query\n";
}

my ($os, $query) = (lc $ARGV[0], $ARGV[1]);

if ($os =~ m{^(?:free|net|open)$}) {
    $os .= "bsd";
}

unless (exists $os_version{$os}) {
    die "First argument is FreeBSD or NetBSD or OpenBSD\n";
}

my $url = get_url($os, {
    section => $section,
    apropos => $apropos,
    query   => $query,
});

my $domain = get_domain();
if (defined $domain) {
    my $config = pit_get($domain);
    set_proxy($config->{proxy}) if exists $config->{proxy};
}

exec $w3m, $url;

sub get_url {
    my ($os, $opts) = @_;

    my $uri;

    my $section = $opts->{section} // 0;
    my $apropos = $opts->{apropos} // 0;

    if ($os eq 'netbsd') {
        my $base = $base_url{$os};
        $base .= '/apropos' if $apropos;

        $uri = URI->new( $base );
        $uri->query( join '+', $opts->{query}, $section, $os_version{$os});
    } else {
        $uri = URI->new( $base_url{$os} );

        my $query = {
            query   => $opts->{query},
            apropos => $apropos,
            sektion => $section,
            manpath => $os_version{$os},
            format  => 'html',
        };

        if ($os eq 'openbsd') {
            $query->{arch} = 'i386';
        }

        $uri->query_form($query);
    }

    return $uri->as_string;
}

sub set_proxy {
    my $proxy = shift;
    $ENV{http_proxy} = $ENV{HTTP_PROXY} = $proxy;
}

sub get_domain {
    my $resolv_conf = "/etc/resolv.conf";
    my $domain;

    open my $fh, "<", $resolv_conf or die "Can't open $resolv_conf\n";
    while (my $line = <$fh>) {
        chomp $line;
        if ($line =~ m{^domain \s (.+)$}xms) {
            $domain = $1;
            last;
        }
    }
    close $fh;

    return $domain;
}