1#!./perl -w
2
3no strict;
4
5BEGIN {
6    if ($ENV{PERL_CORE}) {
7	@INC = '../lib';
8	chdir 't';
9    }
10}
11
12use Getopt::Long;
13
14print "1..33\n";
15
16@ARGV = qw(-Foo -baR --foo bar);
17Getopt::Long::Configure ("no_ignore_case");
18%lnk = ();
19print "ok 1\n" if GetOptions (\%lnk, "foo", "Foo=s");
20print ((defined $lnk{foo})   ? "" : "not ", "ok 2\n");
21print (($lnk{foo} == 1)      ? "" : "not ", "ok 3\n");
22print ((defined $lnk{Foo})   ? "" : "not ", "ok 4\n");
23print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 5\n");
24print ((@ARGV == 1)          ? "" : "not ", "ok 6\n");
25print (($ARGV[0] eq "bar")   ? "" : "not ", "ok 7\n");
26print (!(exists $lnk{baR})   ? "" : "not ", "ok 8\n");
27
28@ARGV = qw(-Foo -baR --foo bar);
29Getopt::Long::Configure ("default","no_ignore_case");
30%lnk = ();
31my $foo;
32print "ok 9\n" if GetOptions (\%lnk, "foo" => \$foo, "Foo=s");
33print ((defined $foo)        ? "" : "not ", "ok 10\n");
34print (($foo == 1)           ? "" : "not ", "ok 11\n");
35print ((defined $lnk{Foo})   ? "" : "not ", "ok 12\n");
36print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 13\n");
37print ((@ARGV == 1)          ? "" : "not ", "ok 14\n");
38print (($ARGV[0] eq "bar")   ? "" : "not ", "ok 15\n");
39print (!(exists $lnk{foo})   ? "" : "not ", "ok 16\n");
40print (!(exists $lnk{baR})   ? "" : "not ", "ok 17\n");
41print (!(exists $lnk{bar})   ? "" : "not ", "ok 18\n");
42
43@ARGV = qw(/Foo=-baR --bar bar);
44Getopt::Long::Configure ("default","prefix_pattern=--|/|-|\\+","long_prefix_pattern=--|/");
45%lnk = ();
46my $bar;
47print "ok 19\n" if GetOptions (\%lnk, "bar" => \$bar, "Foo=s");
48print ((defined $bar)        ? "" : "not ", "ok 20\n");
49print (($bar == 1)           ? "" : "not ", "ok 21\n");
50print ((defined $lnk{Foo})   ? "" : "not ", "ok 22\n");
51print (($lnk{Foo} eq "-baR") ? "" : "not ", "ok 23\n");
52print ((@ARGV == 1)          ? "" : "not ", "ok 24\n");
53print (($ARGV[0] eq "bar")   ? "" : "not ", "ok 25\n");
54print (!(exists $lnk{foo})   ? "" : "not ", "ok 26\n");
55print (!(exists $lnk{baR})   ? "" : "not ", "ok 27\n");
56print (!(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}
94