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