This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move File::Path from ext/ to cpan/
[perl5.git] / ext / Getopt-Long / t / gol-linkage.t
1 #!./perl -w
2
3 no strict;
4
5 BEGIN {
6     if ($ENV{PERL_CORE}) {
7         @INC = '../lib';
8         chdir 't';
9     }
10 }
11
12 use Getopt::Long;
13
14 print "1..33\n";
15
16 @ARGV = qw(-Foo -baR --foo bar);
17 Getopt::Long::Configure ("no_ignore_case");
18 %lnk = ();
19 print "ok 1\n" if GetOptions (\%lnk, "foo", "Foo=s");
20 print ((defined $lnk{foo})   ? "" : "not ", "ok 2\n");
21 print (($lnk{foo} == 1)      ? "" : "not ", "ok 3\n");
22 print ((defined $lnk{Foo})   ? "" : "not ", "ok 4\n");
23 print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 5\n");
24 print ((@ARGV == 1)          ? "" : "not ", "ok 6\n");
25 print (($ARGV[0] eq "bar")   ? "" : "not ", "ok 7\n");
26 print (!(exists $lnk{baR})   ? "" : "not ", "ok 8\n");
27
28 @ARGV = qw(-Foo -baR --foo bar);
29 Getopt::Long::Configure ("default","no_ignore_case");
30 %lnk = ();
31 my $foo;
32 print "ok 9\n" if GetOptions (\%lnk, "foo" => \$foo, "Foo=s");
33 print ((defined $foo)        ? "" : "not ", "ok 10\n");
34 print (($foo == 1)           ? "" : "not ", "ok 11\n");
35 print ((defined $lnk{Foo})   ? "" : "not ", "ok 12\n");
36 print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 13\n");
37 print ((@ARGV == 1)          ? "" : "not ", "ok 14\n");
38 print (($ARGV[0] eq "bar")   ? "" : "not ", "ok 15\n");
39 print (!(exists $lnk{foo})   ? "" : "not ", "ok 16\n");
40 print (!(exists $lnk{baR})   ? "" : "not ", "ok 17\n");
41 print (!(exists $lnk{bar})   ? "" : "not ", "ok 18\n");
42
43 @ARGV = qw(/Foo=-baR --bar bar);
44 Getopt::Long::Configure ("default","prefix_pattern=--|/|-|\\+","long_prefix_pattern=--|/");
45 %lnk = ();
46 my $bar;
47 print "ok 19\n" if GetOptions (\%lnk, "bar" => \$bar, "Foo=s");
48 print ((defined $bar)        ? "" : "not ", "ok 20\n");
49 print (($bar == 1)           ? "" : "not ", "ok 21\n");
50 print ((defined $lnk{Foo})   ? "" : "not ", "ok 22\n");
51 print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 23\n");
52 print ((@ARGV == 1)          ? "" : "not ", "ok 24\n");
53 print (($ARGV[0] eq "bar")   ? "" : "not ", "ok 25\n");
54 print (!(exists $lnk{foo})   ? "" : "not ", "ok 26\n");
55 print (!(exists $lnk{baR})   ? "" : "not ", "ok 27\n");
56 print (!(exists $lnk{bar})   ? "" : "not ", "ok 28\n");
57 {
58     my $errors;
59     %lnk = ();
60     local $SIG{__WARN__}= sub { $errors.=join("\n",@_,'') };
61
62     @ARGV = qw(/Foo=-baR);
63     Getopt::Long::Configure ("default","bundling","ignore_case_always",
64                              "prefix_pattern=--|/|-|\\+","long_prefix_pattern=--");
65     %lnk = ();
66     undef $bar;
67     GetOptions (\%lnk, "bar" => \$bar, "Foo=s");
68     print (($errors=~/Unknown option:/) ? "" : "not ", "ok 29\n");
69     $errors="";
70     %lnk = ();
71     undef $bar;
72      @ARGV = qw(/Foo=-baR);
73     Getopt::Long::Configure ("default","bundling","ignore_case_always",
74                              "prefix_pattern=--|/|-|\\+","long_prefix_pattern=--|/");
75     GetOptions (\%lnk, "bar" => \$bar, "Foo=s");
76     print (($errors eq '') ? "" : "not ", "ok 30\n");
77     print ((defined $lnk{Foo})   ? "" : "not ", "ok 31\n");
78     print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 32\n");
79 }
80
81 {
82     # Allow hashes to overload "".
83     # This used to fail up to 2.34.
84     # Thanks to Yves Orton.
85     my $blessed = bless(\%lnk, "OverLoad::Test");
86
87     @ARGV = qw(--foo bar);
88     Getopt::Long::Configure("default");
89     print "not" unless GetOptions (\%lnk, "foo=s" => \$foo);
90     print "ok 33\n";
91     package Overload::Test;
92     use overload '""' => sub{ die "Bad mojo!" };
93 }