Andrew's git - gitweb.git/blob - contrib/credential/netrc/test.pl

   1#!/usr/bin/perl
   2use lib (split(/:/, $ENV{GITPERLLIB}));
   3
   4use warnings;
   5use strict;
   6use Test::More qw(no_plan);
   7use File::Basename;
   8use File::Spec::Functions qw(:DEFAULT rel2abs);
   9use IPC::Open2;
  10
  11BEGIN {
  12        # t-git-credential-netrc.sh kicks off our testing, so we have to go from there.
  13        Test::More->builder->current_test(1);
  14        Test::More->builder->no_ending(1);
  15}
  16
  17my @global_credential_args = @ARGV;
  18my $scriptDir = dirname rel2abs $0;
  19my $netrc = catfile $scriptDir, 'test.netrc';
  20my $gcNetrc = catfile $scriptDir, 'git-credential-netrc';
  21local $ENV{PATH} = join ':'
  22                      , $scriptDir
  23                      , $ENV{PATH}
  24                      ? $ENV{PATH}
  25                      : ();
  26
  27diag "Testing insecure file, nothing should be found\n";
  28chmod 0644, $netrc;
  29my $cred = run_credential(['-f', $netrc, 'get'],
  30                          { host => 'github.com' });
  31
  32ok(scalar keys %$cred == 0, "Got 0 keys from insecure file");
  33
  34diag "Testing missing file, nothing should be found\n";
  35chmod 0644, $netrc;
  36$cred = run_credential(['-f', '///nosuchfile///', 'get'],
  37                       { host => 'github.com' });
  38
  39ok(scalar keys %$cred == 0, "Got 0 keys from missing file");
  40
  41chmod 0600, $netrc;
  42
  43diag "Testing with invalid data\n";
  44$cred = run_credential(['-f', $netrc, 'get'],
  45                       "bad data");
  46ok(scalar keys %$cred == 4, "Got first found keys with bad data");
  47
  48diag "Testing netrc file for a missing corovamilkbar entry\n";
  49$cred = run_credential(['-f', $netrc, 'get'],
  50                       { host => 'corovamilkbar' });
  51
  52ok(scalar keys %$cred == 0, "Got no corovamilkbar keys");
  53
  54diag "Testing netrc file for a github.com entry\n";
  55$cred = run_credential(['-f', $netrc, 'get'],
  56                       { host => 'github.com' });
  57
  58ok(scalar keys %$cred == 2, "Got 2 Github keys");
  59
  60is($cred->{password}, 'carolknows', "Got correct Github password");
  61is($cred->{username}, 'carol', "Got correct Github username");
  62
  63diag "Testing netrc file for a username-specific entry\n";
  64$cred = run_credential(['-f', $netrc, 'get'],
  65                       { host => 'imap', username => 'bob' });
  66
  67ok(scalar keys %$cred == 2, "Got 2 username-specific keys");
  68
  69is($cred->{password}, 'bobwillknow', "Got correct user-specific password");
  70is($cred->{protocol}, 'imaps', "Got correct user-specific protocol");
  71
  72diag "Testing netrc file for a host:port-specific entry\n";
  73$cred = run_credential(['-f', $netrc, 'get'],
  74                       { host => 'imap2:1099' });
  75
  76ok(scalar keys %$cred == 2, "Got 2 host:port-specific keys");
  77
  78is($cred->{password}, 'tzzknow', "Got correct host:port-specific password");
  79is($cred->{username}, 'tzz', "Got correct host:port-specific username");
  80
  81diag "Testing netrc file that 'host:port kills host' entry\n";
  82$cred = run_credential(['-f', $netrc, 'get'],
  83                       { host => 'imap2' });
  84
  85ok(scalar keys %$cred == 2, "Got 2 'host:port kills host' keys");
  86
  87is($cred->{password}, 'bobwillknow', "Got correct 'host:port kills host' password");
  88is($cred->{username}, 'bob', "Got correct 'host:port kills host' username");
  89
  90
  91sub run_credential
  92{
  93        my $args = shift @_;
  94        my $data = shift @_;
  95        my $pid = open2(my $chld_out, my $chld_in,
  96                        $gcNetrc, @global_credential_args,
  97                        @$args);
  98
  99        die "Couldn't open pipe to netrc credential helper: $!" unless $pid;
 100
 101        if (ref $data eq 'HASH')
 102        {
 103                print $chld_in "$_=$data->{$_}\n" foreach sort keys %$data;
 104        }
 105        else
 106        {
 107                print $chld_in "$data\n";
 108        }
 109
 110        close $chld_in;
 111        my %ret;
 112
 113        while (<$chld_out>)
 114        {
 115                chomp;
 116                next unless m/^([^=]+)=(.+)/;
 117
 118                $ret{$1} = $2;
 119        }
 120
 121        return \%ret;
 122}