This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move Getopt::Long from ext/ to cpan/
[perl5.git] / cpan / Getopt-Long / t / gol-linkage.t
CommitLineData
1a505819
GS
1#!./perl -w
2
554627f6
RGS
3no strict;
4
36e6c0f5 5BEGIN {
10933be5
RGS
6 if ($ENV{PERL_CORE}) {
7 @INC = '../lib';
8 chdir 't';
9 }
36e6c0f5
JH
10}
11
1a505819
GS
12use Getopt::Long;
13
8de02997 14print "1..33\n";
1a505819
GS
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");
554627f6
RGS
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}
8de02997
RGS
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}