getnetrc

#!/usr/bin/env perl
# getnetrc -- query passwords from ~/.netrc
use v5.8;
use warnings;
use strict;
use Getopt::Long qw(:config gnu_getopt no_ignore_case);
use Net::Netrc;

$::arg0 = (split m!/!, $0)[-1];

sub warnx {
	my ($msg) = @_;
	warn "$::arg0: $msg\n";
}

sub errx {
	my ($exit, $msg) = @_;
	warnx($msg) if $msg;
	exit $exit;
}

my $format		= "%l:%p";
my $format_nonewline	= 0;
my $format_url_encode	= 0;
my $service_required	= 0;
my $no_default		= 0;
my $quiet		= 0;

sub usage {
	print "$_\n" for
	"Usage: $::arg0 [-dnsu] [-f format] [service/]machine [login]",
	"",
	"Retrieve a password from the ~/.netrc file.",
	"",
	"Options:",
	"  -d            disable fallback to 'default' entry",
	"  -f format     format the output as specified (default is %l:%p)",
	"  -n            suppress final newline",
	"  -s            disable fallback from '<service>/<machine>' to '<machine>'",
	"  -u            URL-encode output (each field encoded separately)",
	"  -q            quiet on failure to find machine entry",
	"",
	"Format strings:",
	"  %m, %h        result machine (hostname)",
	"  %l, %u        result login (username)",
	"  %p            result password",
	"  %a            result account",
	"  %M            query machine",
	"  %S            query service",
	"  %%, %n, %0    percent sign, newline, null byte",
	"",
	"The .netrc file format is described in the manual page of ftp(1), with",
	"the exception of 'service/machine' syntax which is a custom extension.";
}

sub lookup {
	my ($machines, $login) = @_;
	my $fallback;
	for my $machine (@$machines) {
		my $en = Net::Netrc->lookup($machine, $login);
		if (defined $en) {
			if (defined $en->{machine}) {
				return $en;
			} elsif (!$no_default) {
				$fallback //= $en;
			}
		}
	}
	return $fallback;
}

sub _fmt_expn {
	my ($data, $raw, $key) = @_;
	if ($key eq "%") {
		return $key;
	} elsif (exists $data->{$key}) {
		return $data->{$key} // "";
	} else {
		warnx("unknown format character '$raw'");
		return "$raw";
	}
}

sub fmt {
	my ($str, $data) = @_;
	$str =~ s!%(?:([^{])|\{(.+?)\})!_fmt_expn($data, $&, $1 // $2)!ge;
	return $str;
}

sub uri_encode {
	my ($str) = @_;
	if (defined $str) {
		$str =~ s/([^A-Za-z0-9.!~*'()-])/sprintf("%%%02X", ord($1))/seg;
	}
	return $str;
}

sub lookuparg {
	my ($machine, $login, $strip_service) = @_;

	my $service;
	if ($machine =~ m{^([^/]+)[@/](.+)$}) {
		$service = $1;
		$machine = $2;
	}

	my @machines;
	if ($service && !$strip_service) {
		push @machines, $service.'/'.$machine;
		push @machines, $service.'@'.$machine;
	} else {
		push @machines, $machine;
	}

	my $entry = lookup(\@machines, $login);
	if ($entry) {
		my %output = (
			%$entry,
			a => $entry->{account},
			h => $entry->{machine},
			l => $entry->{login},
			m => $entry->{machine},
			p => $entry->{password},
			u => $entry->{login},
			M => $machine,
			S => $service,
		);
		if ($format_url_encode) {
			$output{$_} = uri_encode($output{$_}) for keys %output;
		}
		@output{"n", "0"} = ("\n", "\0");

		if (!$format_nonewline) {
			$format .= "%n";
		}
		print fmt($format, \%output);
		return 1;
	}
	return 0;
}

# parse command line

GetOptions(
	"help"			=> sub { usage(); exit; },
	"f|format=s"		=> \$format,
	"n|no-newline"		=> \$format_nonewline,
	"u|urlencode"		=> \$format_url_encode,
	"s|service-required"	=> \$service_required,
	"d|no-default"		=> \$no_default,
	"q|quiet!"		=> \$quiet,
) or exit 2;

my ($machinearg, $login) = @ARGV;

unless (defined($machinearg) && length($machinearg)) {
	errx(2, "missing machine name");
}

my @machinearg = split(/[\s,]+/, $machinearg);

# First try all machine names as-is, then try them again without the "service@"
# prefix. (This prioritizes a service/* match over a */host one, as it's more
# likely that a specific service will have its unique credentials.)

for my $machine (@machinearg) {
	exit 0 if lookuparg($machine, $login, 0);
}

if (!$service_required) {
	for my $machine (@machinearg) {
		exit 0 if lookuparg($machine, $login, 1);
	}
}

if ($quiet) {
	errx(1);
} elsif (length($login)) {
	errx(1, "could not find '$machinearg' as '$login' in ~/.netrc");
} else {
	errx(1, "could not find '$machinearg' in ~/.netrc");
}