Commit | Line | Data |
c2b853aa |
1 | #!./perl -w |
57939c21 |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
5 | @INC = '../lib'; |
6 | } |
7 | |
8 | use vars qw( $required ); |
9 | use Test::More tests => 18; |
10 | |
11 | use_ok( 'ExtUtils::Mkbootstrap' ); |
12 | |
57939c21 |
13 | # Mkbootstrap makes a backup copy of "$_[0].bs" if it exists and is non-zero |
14 | my $file_is_ready; |
15 | local *OUT; |
16 | if (open(OUT, '>mkboot.bs')) { |
17 | $file_is_ready = 1; |
18 | print OUT 'meaningless text'; |
19 | close OUT; |
20 | } |
21 | |
22 | SKIP: { |
23 | skip("could not make dummy .bs file: $!", 2) unless $file_is_ready; |
24 | |
25 | Mkbootstrap('mkboot'); |
26 | ok( -s 'mkboot.bso', 'Mkbootstrap should backup the .bs file' ); |
27 | local *IN; |
28 | if (open(IN, 'mkboot.bso')) { |
29 | chomp ($file_is_ready = <IN>); |
30 | close IN; |
31 | } |
32 | |
33 | is( $file_is_ready, 'meaningless text', 'backup should be a perfect copy' ); |
34 | } |
35 | |
36 | |
37 | # if it doesn't exist or is zero bytes in size, it won't be backed up |
38 | Mkbootstrap('fakeboot'); |
39 | ok( !( -f 'fakeboot.bso' ), 'Mkbootstrap should not backup an empty file' ); |
40 | |
41 | |
42 | my $out = tie *STDOUT, 'TieOut'; |
43 | |
44 | # with $Verbose set, it should print status messages about libraries |
45 | $ExtUtils::Mkbootstrap::Verbose = 1; |
c2b853aa |
46 | Mkbootstrap(''); |
57939c21 |
47 | is( $out->read, "\tbsloadlibs=\n", 'should report libraries in Verbose mode' ); |
48 | |
49 | Mkbootstrap('', 'foo'); |
50 | like( $out->read, qr/bsloadlibs=foo/, 'should still report libraries' ); |
51 | |
52 | |
53 | # if ${_[0]}_BS exists, require it |
54 | $file_is_ready = open(OUT, '>boot_BS'); |
55 | |
56 | SKIP: { |
57 | skip("cannot open boot_BS for writing: $!", 1) unless $file_is_ready; |
58 | |
59 | print OUT '$main::required = 1'; |
60 | close OUT; |
61 | Mkbootstrap('boot'); |
62 | |
63 | ok( $required, 'baseext_BS file should be require()d' ); |
64 | } |
65 | |
66 | |
67 | # if there are any arguments, open a file named baseext.bs |
68 | $file_is_ready = open(OUT, '>dasboot.bs'); |
69 | |
70 | SKIP: { |
71 | skip("cannot make dasboot.bs: $!", 5) unless $file_is_ready; |
72 | |
73 | # if it can't be opened for writing, we want to prove that it'll die |
74 | close OUT; |
75 | chmod 0444, 'dasboot.bs'; |
76 | |
e1eb1c15 |
77 | SKIP: { |
78 | skip("can write readonly files", 1) if -w 'dasboot.bs'; |
79 | |
80 | eval{ Mkbootstrap('dasboot', 1) }; |
81 | like( $@, qr/Unable to open dasboot\.bs/, 'should die given bad filename' ); |
82 | } |
57939c21 |
83 | |
84 | # now put it back like it was |
85 | chmod 0777, 'dasboot.bs'; |
86 | eval{ Mkbootstrap('dasboot', 'myarg') }; |
87 | is( $@, '', 'should not die, given good filename' ); |
88 | |
89 | # red and reed (a visual pun makes tests worth reading) |
90 | my $read = $out->read(); |
91 | like( $read, qr/Writing dasboot.bs/, 'should print status' ); |
92 | like( $read, qr/containing: my/, 'should print verbose status on request' ); |
93 | |
94 | # now be tricky, and set the status for the next skip block |
95 | $file_is_ready = open(IN, 'dasboot.bs'); |
96 | ok( $file_is_ready, 'should have written a new .bs file' ); |
97 | } |
98 | |
99 | |
100 | SKIP: { |
101 | skip("cannot read .bs file: $!", 2) unless $file_is_ready; |
102 | |
103 | my $file = do { local $/ = <IN> }; |
104 | |
105 | # filename should be in header |
106 | like( $file, qr/# dasboot DynaLoader/, 'file should have boilerplate' ); |
107 | |
108 | # should print arguments within this array |
109 | like( $file, qr/qw\(myarg\);/, 'should have written array to file' ); |
110 | } |
111 | |
112 | |
113 | # overwrite this file (may whack portability, but the name's too good to waste) |
114 | $file_is_ready = open(OUT, '>dasboot.bs'); |
115 | |
116 | SKIP: { |
117 | skip("cannot make dasboot.bs again: $!", 1) unless $file_is_ready; |
118 | close OUT; |
119 | |
120 | # if $DynaLoader::bscode is set, write its contents to the file |
c2b853aa |
121 | # localize the variable to prevent "used only once" |
122 | local $DynaLoader::bscode; |
57939c21 |
123 | $DynaLoader::bscode = 'Wall'; |
124 | $ExtUtils::Mkbootstrap::Verbose = 0; |
125 | |
126 | # if arguments contain '-l' or '-L' or '-R' print dl_findfile message |
127 | eval{ Mkbootstrap('dasboot', '-Larry') }; |
128 | is( $@, '', 'should be able to open a file again'); |
129 | |
130 | $file_is_ready = open(IN, 'dasboot.bs'); |
131 | } |
132 | |
133 | SKIP: { |
134 | skip("cannot open dasboot.bs for reading: $!", 3) unless $file_is_ready; |
135 | |
136 | my $file = do { local $/ = <IN> }; |
137 | is( $out->read, "Writing dasboot.bs\n", 'should hush without Verbose set' ); |
138 | |
139 | # and find our hidden tribute to a fine example |
140 | like( $file, qr/dl_findfile.+Larry/s, 'should load libraries if needed' ); |
141 | like( $file, qr/Wall\n1;\n/ms, 'should write $DynaLoader::bscode if set' ); |
142 | } |
143 | |
9fb80172 |
144 | close IN; |
145 | close OUT; |
57939c21 |
146 | |
147 | END { |
148 | # clean things up, even on VMS |
149 | 1 while unlink(qw( mkboot.bso boot_BS dasboot.bs .bs )); |
150 | } |
151 | |
152 | package TieOut; |
153 | |
154 | sub TIEHANDLE { |
155 | bless( \(my $scalar), $_[0]); |
156 | } |
157 | |
158 | sub PRINT { |
159 | my $self = shift; |
160 | $$self .= join('', @_); |
161 | } |
162 | |
163 | sub read { |
164 | my $self = shift; |
165 | return substr($$self, 0, length($$self), ''); |
166 | } |