Codebase list libobject-container-perl / upstream/latest
Import original source of Object-Container 0.14 Marius Gavrilescu 10 years ago
45 changed file(s) with 8034 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+71
-0
Changes less more
0 Revision history for Perl extension Object::Container
1
2 0.14 2010-12-21T19:42:25+09:00
3 - added has_instance method for old version compatible (xaicron++)
4
5 0.13 2010-12-13T11:31:33+09:00
6 - added autoload future.
7 - autoload implementation is currently experimental phase so not documented yet.
8
9 0.12 2010-10-31T16:19:09+09:00
10 - moved require test for Exporter::AutoClean to compile time
11
12 0.11 2010-10-14T10:50:55+09:00
13 - do some workarounds for perl 5.8.x
14
15 0.10 2010-10-13T15:15:52+09:00
16 - fixed a test for environment where is not installed Exporter::AutoClean
17
18 0.09 2010-10-12T20:33:36+09:00
19 - added preload_* functions in subclass interface, and also added load_* methods.
20 - remove dependency on Class::Singleton, Data::Util, and Exporter::AutoClean. Exporter::AutoClean is in 'recommends' section (lestrrat++)
21 - added hashref interface for register method also supported preload option (xaicron++)
22
23 0.09_01 2010-10-05T00:18:21+09:00
24 - preload interface test #1
25
26 0.0802 2010-04-18T10:55:40+09:00
27 - add missing prereqs (no code change)
28
29 0.0801 2010-04-16T23:53:08+09:00
30 - fixed previous version bug that forgot to remove Any::Moose from testcase
31
32 0.08 2010-04-15T13:39:23+09:00
33 - no depends Mo(o|u)se, change to depends on Class::Accessor::Fast. (zigorou++)
34
35 0.07 2010-04-04T22:26:03+09:00
36 - don't unregister previously registered class automatically when newer register is called
37
38 0.06 2010-02-18T20:52:58+09:00
39 - add unregister and remove method
40
41 0.05001 2009-11-24T10:43:02+09:00
42 - fix pod (RT: #51859)
43
44 0.05 2009-09-04T11:39:11+09:00
45 - fix 0.04 doesn't die when getting unregister objects
46
47 0.04 2009-09-03T21:34:25+09:00
48 - use Carp
49 - return nothing if it comes getting unregistered object
50
51 0.03002 2009-07-29T12:23:30+09:00
52 - fixed a bug throwing wrong error message when getting unregistered classes
53
54 0.03001 2009-07-16T19:54:28+09:00
55 - pass $self to initializer
56
57 0.03 2009-07-16T16:05:25+09:00
58 - added subclass interface
59
60 0.02001 2009-07-09T19:07:45+09:00
61 - enable to get Object::Container via export function when it comes to no arguments.
62
63 0.02 2009-07-09T18:41:54+09:00
64 - added feature to export singleton interface
65
66 0.01001 2009-05-01T10:27:33+09:00
67 - fix japanese pod name section to avoid CPAN indexer
68
69 0.01 2009-04-30T16:52:37+09:00
70 - initial version
+381
-0
LICENSE less more
0 Terms of Perl itself
1
2 a) the GNU General Public License as published by the Free
3 Software Foundation; either version 1, or (at your option) any
4 later version, or
5 b) the "Artistic License"
6
7 ---------------------------------------------------------------------------
8
9 The General Public License (GPL)
10 Version 2, June 1991
11
12 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave,
13 Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute
14 verbatim copies of this license document, but changing it is not allowed.
15
16 Preamble
17
18 The licenses for most software are designed to take away your freedom to share
19 and change it. By contrast, the GNU General Public License is intended to
20 guarantee your freedom to share and change free software--to make sure the
21 software is free for all its users. This General Public License applies to most of
22 the Free Software Foundation's software and to any other program whose
23 authors commit to using it. (Some other Free Software Foundation software is
24 covered by the GNU Library General Public License instead.) You can apply it to
25 your programs, too.
26
27 When we speak of free software, we are referring to freedom, not price. Our
28 General Public Licenses are designed to make sure that you have the freedom
29 to distribute copies of free software (and charge for this service if you wish), that
30 you receive source code or can get it if you want it, that you can change the
31 software or use pieces of it in new free programs; and that you know you can do
32 these things.
33
34 To protect your rights, we need to make restrictions that forbid anyone to deny
35 you these rights or to ask you to surrender the rights. These restrictions
36 translate to certain responsibilities for you if you distribute copies of the
37 software, or if you modify it.
38
39 For example, if you distribute copies of such a program, whether gratis or for a
40 fee, you must give the recipients all the rights that you have. You must make
41 sure that they, too, receive or can get the source code. And you must show
42 them these terms so they know their rights.
43
44 We protect your rights with two steps: (1) copyright the software, and (2) offer
45 you this license which gives you legal permission to copy, distribute and/or
46 modify the software.
47
48 Also, for each author's protection and ours, we want to make certain that
49 everyone understands that there is no warranty for this free software. If the
50 software is modified by someone else and passed on, we want its recipients to
51 know that what they have is not the original, so that any problems introduced by
52 others will not reflect on the original authors' reputations.
53
54 Finally, any free program is threatened constantly by software patents. We wish
55 to avoid the danger that redistributors of a free program will individually obtain
56 patent licenses, in effect making the program proprietary. To prevent this, we
57 have made it clear that any patent must be licensed for everyone's free use or
58 not licensed at all.
59
60 The precise terms and conditions for copying, distribution and modification
61 follow.
62
63 GNU GENERAL PUBLIC LICENSE
64 TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND
65 MODIFICATION
66
67 0. This License applies to any program or other work which contains a notice
68 placed by the copyright holder saying it may be distributed under the terms of
69 this General Public License. The "Program", below, refers to any such program
70 or work, and a "work based on the Program" means either the Program or any
71 derivative work under copyright law: that is to say, a work containing the
72 Program or a portion of it, either verbatim or with modifications and/or translated
73 into another language. (Hereinafter, translation is included without limitation in
74 the term "modification".) Each licensee is addressed as "you".
75
76 Activities other than copying, distribution and modification are not covered by
77 this License; they are outside its scope. The act of running the Program is not
78 restricted, and the output from the Program is covered only if its contents
79 constitute a work based on the Program (independent of having been made by
80 running the Program). Whether that is true depends on what the Program does.
81
82 1. You may copy and distribute verbatim copies of the Program's source code as
83 you receive it, in any medium, provided that you conspicuously and appropriately
84 publish on each copy an appropriate copyright notice and disclaimer of warranty;
85 keep intact all the notices that refer to this License and to the absence of any
86 warranty; and give any other recipients of the Program a copy of this License
87 along with the Program.
88
89 You may charge a fee for the physical act of transferring a copy, and you may at
90 your option offer warranty protection in exchange for a fee.
91
92 2. You may modify your copy or copies of the Program or any portion of it, thus
93 forming a work based on the Program, and copy and distribute such
94 modifications or work under the terms of Section 1 above, provided that you also
95 meet all of these conditions:
96
97 a) You must cause the modified files to carry prominent notices stating that you
98 changed the files and the date of any change.
99
100 b) You must cause any work that you distribute or publish, that in whole or in
101 part contains or is derived from the Program or any part thereof, to be licensed
102 as a whole at no charge to all third parties under the terms of this License.
103
104 c) If the modified program normally reads commands interactively when run, you
105 must cause it, when started running for such interactive use in the most ordinary
106 way, to print or display an announcement including an appropriate copyright
107 notice and a notice that there is no warranty (or else, saying that you provide a
108 warranty) and that users may redistribute the program under these conditions,
109 and telling the user how to view a copy of this License. (Exception: if the
110 Program itself is interactive but does not normally print such an announcement,
111 your work based on the Program is not required to print an announcement.)
112
113 These requirements apply to the modified work as a whole. If identifiable
114 sections of that work are not derived from the Program, and can be reasonably
115 considered independent and separate works in themselves, then this License,
116 and its terms, do not apply to those sections when you distribute them as
117 separate works. But when you distribute the same sections as part of a whole
118 which is a work based on the Program, the distribution of the whole must be on
119 the terms of this License, whose permissions for other licensees extend to the
120 entire whole, and thus to each and every part regardless of who wrote it.
121
122 Thus, it is not the intent of this section to claim rights or contest your rights to
123 work written entirely by you; rather, the intent is to exercise the right to control
124 the distribution of derivative or collective works based on the Program.
125
126 In addition, mere aggregation of another work not based on the Program with the
127 Program (or with a work based on the Program) on a volume of a storage or
128 distribution medium does not bring the other work under the scope of this
129 License.
130
131 3. You may copy and distribute the Program (or a work based on it, under
132 Section 2) in object code or executable form under the terms of Sections 1 and 2
133 above provided that you also do one of the following:
134
135 a) Accompany it with the complete corresponding machine-readable source
136 code, which must be distributed under the terms of Sections 1 and 2 above on a
137 medium customarily used for software interchange; or,
138
139 b) Accompany it with a written offer, valid for at least three years, to give any
140 third party, for a charge no more than your cost of physically performing source
141 distribution, a complete machine-readable copy of the corresponding source
142 code, to be distributed under the terms of Sections 1 and 2 above on a medium
143 customarily used for software interchange; or,
144
145 c) Accompany it with the information you received as to the offer to distribute
146 corresponding source code. (This alternative is allowed only for noncommercial
147 distribution and only if you received the program in object code or executable
148 form with such an offer, in accord with Subsection b above.)
149
150 The source code for a work means the preferred form of the work for making
151 modifications to it. For an executable work, complete source code means all the
152 source code for all modules it contains, plus any associated interface definition
153 files, plus the scripts used to control compilation and installation of the
154 executable. However, as a special exception, the source code distributed need
155 not include anything that is normally distributed (in either source or binary form)
156 with the major components (compiler, kernel, and so on) of the operating system
157 on which the executable runs, unless that component itself accompanies the
158 executable.
159
160 If distribution of executable or object code is made by offering access to copy
161 from a designated place, then offering equivalent access to copy the source
162 code from the same place counts as distribution of the source code, even though
163 third parties are not compelled to copy the source along with the object code.
164
165 4. You may not copy, modify, sublicense, or distribute the Program except as
166 expressly provided under this License. Any attempt otherwise to copy, modify,
167 sublicense or distribute the Program is void, and will automatically terminate
168 your rights under this License. However, parties who have received copies, or
169 rights, from you under this License will not have their licenses terminated so long
170 as such parties remain in full compliance.
171
172 5. You are not required to accept this License, since you have not signed it.
173 However, nothing else grants you permission to modify or distribute the Program
174 or its derivative works. These actions are prohibited by law if you do not accept
175 this License. Therefore, by modifying or distributing the Program (or any work
176 based on the Program), you indicate your acceptance of this License to do so,
177 and all its terms and conditions for copying, distributing or modifying the
178 Program or works based on it.
179
180 6. Each time you redistribute the Program (or any work based on the Program),
181 the recipient automatically receives a license from the original licensor to copy,
182 distribute or modify the Program subject to these terms and conditions. You
183 may not impose any further restrictions on the recipients' exercise of the rights
184 granted herein. You are not responsible for enforcing compliance by third parties
185 to this License.
186
187 7. If, as a consequence of a court judgment or allegation of patent infringement
188 or for any other reason (not limited to patent issues), conditions are imposed on
189 you (whether by court order, agreement or otherwise) that contradict the
190 conditions of this License, they do not excuse you from the conditions of this
191 License. If you cannot distribute so as to satisfy simultaneously your obligations
192 under this License and any other pertinent obligations, then as a consequence
193 you may not distribute the Program at all. For example, if a patent license would
194 not permit royalty-free redistribution of the Program by all those who receive
195 copies directly or indirectly through you, then the only way you could satisfy
196 both it and this License would be to refrain entirely from distribution of the
197 Program.
198
199 If any portion of this section is held invalid or unenforceable under any particular
200 circumstance, the balance of the section is intended to apply and the section as
201 a whole is intended to apply in other circumstances.
202
203 It is not the purpose of this section to induce you to infringe any patents or other
204 property right claims or to contest validity of any such claims; this section has
205 the sole purpose of protecting the integrity of the free software distribution
206 system, which is implemented by public license practices. Many people have
207 made generous contributions to the wide range of software distributed through
208 that system in reliance on consistent application of that system; it is up to the
209 author/donor to decide if he or she is willing to distribute software through any
210 other system and a licensee cannot impose that choice.
211
212 This section is intended to make thoroughly clear what is believed to be a
213 consequence of the rest of this License.
214
215 8. If the distribution and/or use of the Program is restricted in certain countries
216 either by patents or by copyrighted interfaces, the original copyright holder who
217 places the Program under this License may add an explicit geographical
218 distribution limitation excluding those countries, so that distribution is permitted
219 only in or among countries not thus excluded. In such case, this License
220 incorporates the limitation as if written in the body of this License.
221
222 9. The Free Software Foundation may publish revised and/or new versions of the
223 General Public License from time to time. Such new versions will be similar in
224 spirit to the present version, but may differ in detail to address new problems or
225 concerns.
226
227 Each version is given a distinguishing version number. If the Program specifies a
228 version number of this License which applies to it and "any later version", you
229 have the option of following the terms and conditions either of that version or of
230 any later version published by the Free Software Foundation. If the Program does
231 not specify a version number of this License, you may choose any version ever
232 published by the Free Software Foundation.
233
234 10. If you wish to incorporate parts of the Program into other free programs
235 whose distribution conditions are different, write to the author to ask for
236 permission. For software which is copyrighted by the Free Software Foundation,
237 write to the Free Software Foundation; we sometimes make exceptions for this.
238 Our decision will be guided by the two goals of preserving the free status of all
239 derivatives of our free software and of promoting the sharing and reuse of
240 software generally.
241
242 NO WARRANTY
243
244 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS
245 NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
246 APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE
247 COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM
248 "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR
249 IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
250 MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
251 ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE
252 PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE,
253 YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR
254 CORRECTION.
255
256 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED
257 TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY
258 WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS
259 PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
260 GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES
261 ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM
262 (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
263 RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
264 PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY
265 OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS
266 BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
267
268 END OF TERMS AND CONDITIONS
269
270
271 ---------------------------------------------------------------------------
272
273 The Artistic License
274
275 Preamble
276
277 The intent of this document is to state the conditions under which a Package
278 may be copied, such that the Copyright Holder maintains some semblance of
279 artistic control over the development of the package, while giving the users of the
280 package the right to use and distribute the Package in a more-or-less customary
281 fashion, plus the right to make reasonable modifications.
282
283 Definitions:
284
285 - "Package" refers to the collection of files distributed by the Copyright
286 Holder, and derivatives of that collection of files created through textual
287 modification.
288 - "Standard Version" refers to such a Package if it has not been modified,
289 or has been modified in accordance with the wishes of the Copyright
290 Holder.
291 - "Copyright Holder" is whoever is named in the copyright or copyrights for
292 the package.
293 - "You" is you, if you're thinking about copying or distributing this Package.
294 - "Reasonable copying fee" is whatever you can justify on the basis of
295 media cost, duplication charges, time of people involved, and so on. (You
296 will not be required to justify it to the Copyright Holder, but only to the
297 computing community at large as a market that must bear the fee.)
298 - "Freely Available" means that no fee is charged for the item itself, though
299 there may be fees involved in handling the item. It also means that
300 recipients of the item may redistribute it under the same conditions they
301 received it.
302
303 1. You may make and give away verbatim copies of the source form of the
304 Standard Version of this Package without restriction, provided that you duplicate
305 all of the original copyright notices and associated disclaimers.
306
307 2. You may apply bug fixes, portability fixes and other modifications derived from
308 the Public Domain or from the Copyright Holder. A Package modified in such a
309 way shall still be considered the Standard Version.
310
311 3. You may otherwise modify your copy of this Package in any way, provided
312 that you insert a prominent notice in each changed file stating how and when
313 you changed that file, and provided that you do at least ONE of the following:
314
315 a) place your modifications in the Public Domain or otherwise
316 make them Freely Available, such as by posting said modifications
317 to Usenet or an equivalent medium, or placing the modifications on
318 a major archive site such as ftp.uu.net, or by allowing the
319 Copyright Holder to include your modifications in the Standard
320 Version of the Package.
321
322 b) use the modified Package only within your corporation or
323 organization.
324
325 c) rename any non-standard executables so the names do not
326 conflict with standard executables, which must also be provided,
327 and provide a separate manual page for each non-standard
328 executable that clearly documents how it differs from the Standard
329 Version.
330
331 d) make other distribution arrangements with the Copyright Holder.
332
333 4. You may distribute the programs of this Package in object code or executable
334 form, provided that you do at least ONE of the following:
335
336 a) distribute a Standard Version of the executables and library
337 files, together with instructions (in the manual page or equivalent)
338 on where to get the Standard Version.
339
340 b) accompany the distribution with the machine-readable source of
341 the Package with your modifications.
342
343 c) accompany any non-standard executables with their
344 corresponding Standard Version executables, giving the
345 non-standard executables non-standard names, and clearly
346 documenting the differences in manual pages (or equivalent),
347 together with instructions on where to get the Standard Version.
348
349 d) make other distribution arrangements with the Copyright Holder.
350
351 5. You may charge a reasonable copying fee for any distribution of this Package.
352 You may charge any fee you choose for support of this Package. You may not
353 charge a fee for this Package itself. However, you may distribute this Package in
354 aggregate with other (possibly commercial) programs as part of a larger
355 (possibly commercial) software distribution provided that you do not advertise
356 this Package as a product of your own.
357
358 6. The scripts and library files supplied as input to or produced as output from
359 the programs of this Package do not automatically fall under the copyright of this
360 Package, but belong to whomever generated them, and may be sold
361 commercially, and may be aggregated with this Package.
362
363 7. C or perl subroutines supplied by you and linked into this Package shall not
364 be considered part of this Package.
365
366 8. Aggregation of this Package with a commercial distribution is always permitted
367 provided that the use of this Package is embedded; that is, when no overt attempt
368 is made to make this Package's interfaces visible to the end user of the
369 commercial distribution. Such use shall not be construed as a distribution of
370 this Package.
371
372 9. The name of the Copyright Holder may not be used to endorse or promote
373 products derived from this software without specific prior written permission.
374
375 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
376 IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
377 WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
378 PURPOSE.
379
380 The End
+45
-0
MANIFEST less more
0 Changes
1 inc/Module/Install.pm
2 inc/Module/Install/AuthorTests.pm
3 inc/Module/Install/Base.pm
4 inc/Module/Install/Can.pm
5 inc/Module/Install/Fetch.pm
6 inc/Module/Install/Include.pm
7 inc/Module/Install/Makefile.pm
8 inc/Module/Install/Metadata.pm
9 inc/Module/Install/Repository.pm
10 inc/Module/Install/TestBase.pm
11 inc/Module/Install/Win32.pm
12 inc/Module/Install/WriteAll.pm
13 inc/Spiffy.pm
14 inc/Test/Base.pm
15 inc/Test/Base/Filter.pm
16 inc/Test/Builder.pm
17 inc/Test/Builder/Module.pm
18 inc/Test/More.pm
19 lib/Object/Container.pm
20 lib/Object/Container/ja.pod
21 LICENSE
22 Makefile.PL
23 MANIFEST This list of files
24 META.yml
25 README
26 t/00_compile.t
27 t/01_object.t
28 t/02_singleton.t
29 t/03_args_and_initializer.t
30 t/04_export.t
31 t/05_subclass.t
32 t/05_subclass_no_autoclean.t
33 t/06_remove.t
34 t/07_hashref.t
35 t/07_preload.t
36 t/08_preload_subclass.t
37 t/09_autoload.t
38 t/10_class_singleton_compatible.t
39 t/no_clean/Exporter/AutoClean.pm
40 t/subclass/Bar.pm
41 t/subclass/Foo.pm
42 xt/pod.t
43 xt/pod_coverage.t
44 xt/pod_spell.t
+32
-0
META.yml less more
0 ---
1 abstract: 'simple object container'
2 author:
3 - 'Daisuke Murase <typester@cpan.org>'
4 build_requires:
5 ExtUtils::MakeMaker: 6.42
6 Test::Requires: 0
7 configure_requires:
8 ExtUtils::MakeMaker: 6.42
9 distribution_type: module
10 generated_by: 'Module::Install version 1.00'
11 license: perl
12 meta-spec:
13 url: http://module-build.sourceforge.net/META-spec-v1.4.html
14 version: 1.4
15 name: Object-Container
16 no_index:
17 directory:
18 - inc
19 - t
20 - xt
21 recommends:
22 Exporter::AutoClean: 0
23 requires:
24 Carp: 0
25 Class::Accessor::Fast: 0
26 Filter::Util::Call: 0
27 parent: 0
28 resources:
29 license: http://dev.perl.org/licenses/
30 repository: git://github.com/typester/object-container-perl.git
31 version: 0.14
+17
-0
Makefile.PL less more
0 use inc::Module::Install;
1 name 'Object-Container';
2 all_from 'lib/Object/Container.pm';
3
4 requires 'Carp';
5 requires 'Class::Accessor::Fast';
6 requires 'parent';
7
8 recommends 'Exporter::AutoClean';
9 test_requires 'Test::More' => '0.88';
10 test_requires 'Test::Requires';
11 use_test_base;
12 author_tests 'xt';
13
14 auto_set_repository;
15
16 WriteAll;
+27
-0
README less more
0 This is Perl module Object::Container.
1
2 INSTALLATION
3
4 Object::Container installation is straightforward. If your CPAN shell is set up,
5 you should just be able to do
6
7 % cpan Object::Container
8
9 Download it, unpack it, then build it as per the usual:
10
11 % perl Makefile.PL
12 % make && make test
13
14 Then install it:
15
16 % make install
17
18 DOCUMENTATION
19
20 Object::Container documentation is available as in POD. So you can do:
21
22 % perldoc Object::Container
23
24 to read the documentation online with your favorite pager.
25
26 Daisuke Murase
+59
-0
inc/Module/Install/AuthorTests.pm less more
0 #line 1
1 package Module::Install::AuthorTests;
2
3 use 5.005;
4 use strict;
5 use Module::Install::Base;
6 use Carp ();
7
8 #line 16
9
10 use vars qw{$VERSION $ISCORE @ISA};
11 BEGIN {
12 $VERSION = '0.002';
13 $ISCORE = 1;
14 @ISA = qw{Module::Install::Base};
15 }
16
17 #line 42
18
19 sub author_tests {
20 my ($self, @dirs) = @_;
21 _add_author_tests($self, \@dirs, 0);
22 }
23
24 #line 56
25
26 sub recursive_author_tests {
27 my ($self, @dirs) = @_;
28 _add_author_tests($self, \@dirs, 1);
29 }
30
31 sub _wanted {
32 my $href = shift;
33 sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 }
34 }
35
36 sub _add_author_tests {
37 my ($self, $dirs, $recurse) = @_;
38 return unless $Module::Install::AUTHOR;
39
40 my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t';
41
42 # XXX: pick a default, later -- rjbs, 2008-02-24
43 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests";
44 @dirs = grep { -d } @dirs;
45
46 if ($recurse) {
47 require File::Find;
48 my %test_dir;
49 File::Find::find(_wanted(\%test_dir), @dirs);
50 $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir );
51 } else {
52 $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs );
53 }
54 }
55
56 #line 107
57
58 1;
+83
-0
inc/Module/Install/Base.pm less more
0 #line 1
1 package Module::Install::Base;
2
3 use strict 'vars';
4 use vars qw{$VERSION};
5 BEGIN {
6 $VERSION = '1.00';
7 }
8
9 # Suspend handler for "redefined" warnings
10 BEGIN {
11 my $w = $SIG{__WARN__};
12 $SIG{__WARN__} = sub { $w };
13 }
14
15 #line 42
16
17 sub new {
18 my $class = shift;
19 unless ( defined &{"${class}::call"} ) {
20 *{"${class}::call"} = sub { shift->_top->call(@_) };
21 }
22 unless ( defined &{"${class}::load"} ) {
23 *{"${class}::load"} = sub { shift->_top->load(@_) };
24 }
25 bless { @_ }, $class;
26 }
27
28 #line 61
29
30 sub AUTOLOAD {
31 local $@;
32 my $func = eval { shift->_top->autoload } or return;
33 goto &$func;
34 }
35
36 #line 75
37
38 sub _top {
39 $_[0]->{_top};
40 }
41
42 #line 90
43
44 sub admin {
45 $_[0]->_top->{admin}
46 or
47 Module::Install::Base::FakeAdmin->new;
48 }
49
50 #line 106
51
52 sub is_admin {
53 ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin');
54 }
55
56 sub DESTROY {}
57
58 package Module::Install::Base::FakeAdmin;
59
60 use vars qw{$VERSION};
61 BEGIN {
62 $VERSION = $Module::Install::Base::VERSION;
63 }
64
65 my $fake;
66
67 sub new {
68 $fake ||= bless(\@_, $_[0]);
69 }
70
71 sub AUTOLOAD {}
72
73 sub DESTROY {}
74
75 # Restore warning handler
76 BEGIN {
77 $SIG{__WARN__} = $SIG{__WARN__}->();
78 }
79
80 1;
81
82 #line 159
+81
-0
inc/Module/Install/Can.pm less more
0 #line 1
1 package Module::Install::Can;
2
3 use strict;
4 use Config ();
5 use File::Spec ();
6 use ExtUtils::MakeMaker ();
7 use Module::Install::Base ();
8
9 use vars qw{$VERSION @ISA $ISCORE};
10 BEGIN {
11 $VERSION = '1.00';
12 @ISA = 'Module::Install::Base';
13 $ISCORE = 1;
14 }
15
16 # check if we can load some module
17 ### Upgrade this to not have to load the module if possible
18 sub can_use {
19 my ($self, $mod, $ver) = @_;
20 $mod =~ s{::|\\}{/}g;
21 $mod .= '.pm' unless $mod =~ /\.pm$/i;
22
23 my $pkg = $mod;
24 $pkg =~ s{/}{::}g;
25 $pkg =~ s{\.pm$}{}i;
26
27 local $@;
28 eval { require $mod; $pkg->VERSION($ver || 0); 1 };
29 }
30
31 # check if we can run some command
32 sub can_run {
33 my ($self, $cmd) = @_;
34
35 my $_cmd = $cmd;
36 return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd));
37
38 for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') {
39 next if $dir eq '';
40 my $abs = File::Spec->catfile($dir, $_[1]);
41 return $abs if (-x $abs or $abs = MM->maybe_command($abs));
42 }
43
44 return;
45 }
46
47 # can we locate a (the) C compiler
48 sub can_cc {
49 my $self = shift;
50 my @chunks = split(/ /, $Config::Config{cc}) or return;
51
52 # $Config{cc} may contain args; try to find out the program part
53 while (@chunks) {
54 return $self->can_run("@chunks") || (pop(@chunks), next);
55 }
56
57 return;
58 }
59
60 # Fix Cygwin bug on maybe_command();
61 if ( $^O eq 'cygwin' ) {
62 require ExtUtils::MM_Cygwin;
63 require ExtUtils::MM_Win32;
64 if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) {
65 *ExtUtils::MM_Cygwin::maybe_command = sub {
66 my ($self, $file) = @_;
67 if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) {
68 ExtUtils::MM_Win32->maybe_command($file);
69 } else {
70 ExtUtils::MM_Unix->maybe_command($file);
71 }
72 }
73 }
74 }
75
76 1;
77
78 __END__
79
80 #line 156
+93
-0
inc/Module/Install/Fetch.pm less more
0 #line 1
1 package Module::Install::Fetch;
2
3 use strict;
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.00';
9 @ISA = 'Module::Install::Base';
10 $ISCORE = 1;
11 }
12
13 sub get_file {
14 my ($self, %args) = @_;
15 my ($scheme, $host, $path, $file) =
16 $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
17
18 if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) {
19 $args{url} = $args{ftp_url}
20 or (warn("LWP support unavailable!\n"), return);
21 ($scheme, $host, $path, $file) =
22 $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return;
23 }
24
25 $|++;
26 print "Fetching '$file' from $host... ";
27
28 unless (eval { require Socket; Socket::inet_aton($host) }) {
29 warn "'$host' resolve failed!\n";
30 return;
31 }
32
33 return unless $scheme eq 'ftp' or $scheme eq 'http';
34
35 require Cwd;
36 my $dir = Cwd::getcwd();
37 chdir $args{local_dir} or return if exists $args{local_dir};
38
39 if (eval { require LWP::Simple; 1 }) {
40 LWP::Simple::mirror($args{url}, $file);
41 }
42 elsif (eval { require Net::FTP; 1 }) { eval {
43 # use Net::FTP to get past firewall
44 my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600);
45 $ftp->login("anonymous", 'anonymous@example.com');
46 $ftp->cwd($path);
47 $ftp->binary;
48 $ftp->get($file) or (warn("$!\n"), return);
49 $ftp->quit;
50 } }
51 elsif (my $ftp = $self->can_run('ftp')) { eval {
52 # no Net::FTP, fallback to ftp.exe
53 require FileHandle;
54 my $fh = FileHandle->new;
55
56 local $SIG{CHLD} = 'IGNORE';
57 unless ($fh->open("|$ftp -n")) {
58 warn "Couldn't open ftp: $!\n";
59 chdir $dir; return;
60 }
61
62 my @dialog = split(/\n/, <<"END_FTP");
63 open $host
64 user anonymous anonymous\@example.com
65 cd $path
66 binary
67 get $file $file
68 quit
69 END_FTP
70 foreach (@dialog) { $fh->print("$_\n") }
71 $fh->close;
72 } }
73 else {
74 warn "No working 'ftp' program available!\n";
75 chdir $dir; return;
76 }
77
78 unless (-f $file) {
79 warn "Fetching failed: $@\n";
80 chdir $dir; return;
81 }
82
83 return if exists $args{size} and -s $file != $args{size};
84 system($args{run}) if exists $args{run};
85 unlink($file) if $args{remove};
86
87 print(((!exists $args{check_for} or -e $args{check_for})
88 ? "done!" : "failed! ($!)"), "\n");
89 chdir $dir; return !$?;
90 }
91
92 1;
+34
-0
inc/Module/Install/Include.pm less more
0 #line 1
1 package Module::Install::Include;
2
3 use strict;
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.00';
9 @ISA = 'Module::Install::Base';
10 $ISCORE = 1;
11 }
12
13 sub include {
14 shift()->admin->include(@_);
15 }
16
17 sub include_deps {
18 shift()->admin->include_deps(@_);
19 }
20
21 sub auto_include {
22 shift()->admin->auto_include(@_);
23 }
24
25 sub auto_include_deps {
26 shift()->admin->auto_include_deps(@_);
27 }
28
29 sub auto_include_dependent_dists {
30 shift()->admin->auto_include_dependent_dists(@_);
31 }
32
33 1;
+415
-0
inc/Module/Install/Makefile.pm less more
0 #line 1
1 package Module::Install::Makefile;
2
3 use strict 'vars';
4 use ExtUtils::MakeMaker ();
5 use Module::Install::Base ();
6 use Fcntl qw/:flock :seek/;
7
8 use vars qw{$VERSION @ISA $ISCORE};
9 BEGIN {
10 $VERSION = '1.00';
11 @ISA = 'Module::Install::Base';
12 $ISCORE = 1;
13 }
14
15 sub Makefile { $_[0] }
16
17 my %seen = ();
18
19 sub prompt {
20 shift;
21
22 # Infinite loop protection
23 my @c = caller();
24 if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) {
25 die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])";
26 }
27
28 # In automated testing or non-interactive session, always use defaults
29 if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) {
30 local $ENV{PERL_MM_USE_DEFAULT} = 1;
31 goto &ExtUtils::MakeMaker::prompt;
32 } else {
33 goto &ExtUtils::MakeMaker::prompt;
34 }
35 }
36
37 # Store a cleaned up version of the MakeMaker version,
38 # since we need to behave differently in a variety of
39 # ways based on the MM version.
40 my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
41
42 # If we are passed a param, do a "newer than" comparison.
43 # Otherwise, just return the MakeMaker version.
44 sub makemaker {
45 ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
46 }
47
48 # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified
49 # as we only need to know here whether the attribute is an array
50 # or a hash or something else (which may or may not be appendable).
51 my %makemaker_argtype = (
52 C => 'ARRAY',
53 CONFIG => 'ARRAY',
54 # CONFIGURE => 'CODE', # ignore
55 DIR => 'ARRAY',
56 DL_FUNCS => 'HASH',
57 DL_VARS => 'ARRAY',
58 EXCLUDE_EXT => 'ARRAY',
59 EXE_FILES => 'ARRAY',
60 FUNCLIST => 'ARRAY',
61 H => 'ARRAY',
62 IMPORTS => 'HASH',
63 INCLUDE_EXT => 'ARRAY',
64 LIBS => 'ARRAY', # ignore ''
65 MAN1PODS => 'HASH',
66 MAN3PODS => 'HASH',
67 META_ADD => 'HASH',
68 META_MERGE => 'HASH',
69 PL_FILES => 'HASH',
70 PM => 'HASH',
71 PMLIBDIRS => 'ARRAY',
72 PMLIBPARENTDIRS => 'ARRAY',
73 PREREQ_PM => 'HASH',
74 CONFIGURE_REQUIRES => 'HASH',
75 SKIP => 'ARRAY',
76 TYPEMAPS => 'ARRAY',
77 XS => 'HASH',
78 # VERSION => ['version',''], # ignore
79 # _KEEP_AFTER_FLUSH => '',
80
81 clean => 'HASH',
82 depend => 'HASH',
83 dist => 'HASH',
84 dynamic_lib=> 'HASH',
85 linkext => 'HASH',
86 macro => 'HASH',
87 postamble => 'HASH',
88 realclean => 'HASH',
89 test => 'HASH',
90 tool_autosplit => 'HASH',
91
92 # special cases where you can use makemaker_append
93 CCFLAGS => 'APPENDABLE',
94 DEFINE => 'APPENDABLE',
95 INC => 'APPENDABLE',
96 LDDLFLAGS => 'APPENDABLE',
97 LDFROM => 'APPENDABLE',
98 );
99
100 sub makemaker_args {
101 my ($self, %new_args) = @_;
102 my $args = ( $self->{makemaker_args} ||= {} );
103 foreach my $key (keys %new_args) {
104 if ($makemaker_argtype{$key}) {
105 if ($makemaker_argtype{$key} eq 'ARRAY') {
106 $args->{$key} = [] unless defined $args->{$key};
107 unless (ref $args->{$key} eq 'ARRAY') {
108 $args->{$key} = [$args->{$key}]
109 }
110 push @{$args->{$key}},
111 ref $new_args{$key} eq 'ARRAY'
112 ? @{$new_args{$key}}
113 : $new_args{$key};
114 }
115 elsif ($makemaker_argtype{$key} eq 'HASH') {
116 $args->{$key} = {} unless defined $args->{$key};
117 foreach my $skey (keys %{ $new_args{$key} }) {
118 $args->{$key}{$skey} = $new_args{$key}{$skey};
119 }
120 }
121 elsif ($makemaker_argtype{$key} eq 'APPENDABLE') {
122 $self->makemaker_append($key => $new_args{$key});
123 }
124 }
125 else {
126 if (defined $args->{$key}) {
127 warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n};
128 }
129 $args->{$key} = $new_args{$key};
130 }
131 }
132 return $args;
133 }
134
135 # For mm args that take multiple space-seperated args,
136 # append an argument to the current list.
137 sub makemaker_append {
138 my $self = shift;
139 my $name = shift;
140 my $args = $self->makemaker_args;
141 $args->{$name} = defined $args->{$name}
142 ? join( ' ', $args->{$name}, @_ )
143 : join( ' ', @_ );
144 }
145
146 sub build_subdirs {
147 my $self = shift;
148 my $subdirs = $self->makemaker_args->{DIR} ||= [];
149 for my $subdir (@_) {
150 push @$subdirs, $subdir;
151 }
152 }
153
154 sub clean_files {
155 my $self = shift;
156 my $clean = $self->makemaker_args->{clean} ||= {};
157 %$clean = (
158 %$clean,
159 FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_),
160 );
161 }
162
163 sub realclean_files {
164 my $self = shift;
165 my $realclean = $self->makemaker_args->{realclean} ||= {};
166 %$realclean = (
167 %$realclean,
168 FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_),
169 );
170 }
171
172 sub libs {
173 my $self = shift;
174 my $libs = ref $_[0] ? shift : [ shift ];
175 $self->makemaker_args( LIBS => $libs );
176 }
177
178 sub inc {
179 my $self = shift;
180 $self->makemaker_args( INC => shift );
181 }
182
183 sub _wanted_t {
184 }
185
186 sub tests_recursive {
187 my $self = shift;
188 my $dir = shift || 't';
189 unless ( -d $dir ) {
190 die "tests_recursive dir '$dir' does not exist";
191 }
192 my %tests = map { $_ => 1 } split / /, ($self->tests || '');
193 require File::Find;
194 File::Find::find(
195 sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 },
196 $dir
197 );
198 $self->tests( join ' ', sort keys %tests );
199 }
200
201 sub write {
202 my $self = shift;
203 die "&Makefile->write() takes no arguments\n" if @_;
204
205 # Check the current Perl version
206 my $perl_version = $self->perl_version;
207 if ( $perl_version ) {
208 eval "use $perl_version; 1"
209 or die "ERROR: perl: Version $] is installed, "
210 . "but we need version >= $perl_version";
211 }
212
213 # Make sure we have a new enough MakeMaker
214 require ExtUtils::MakeMaker;
215
216 if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) {
217 # MakeMaker can complain about module versions that include
218 # an underscore, even though its own version may contain one!
219 # Hence the funny regexp to get rid of it. See RT #35800
220 # for details.
221 my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
222 $self->build_requires( 'ExtUtils::MakeMaker' => $v );
223 $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
224 } else {
225 # Allow legacy-compatibility with 5.005 by depending on the
226 # most recent EU:MM that supported 5.005.
227 $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
228 $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
229 }
230
231 # Generate the MakeMaker params
232 my $args = $self->makemaker_args;
233 $args->{DISTNAME} = $self->name;
234 $args->{NAME} = $self->module_name || $self->name;
235 $args->{NAME} =~ s/-/::/g;
236 $args->{VERSION} = $self->version or die <<'EOT';
237 ERROR: Can't determine distribution version. Please specify it
238 explicitly via 'version' in Makefile.PL, or set a valid $VERSION
239 in a module, and provide its file path via 'version_from' (or
240 'all_from' if you prefer) in Makefile.PL.
241 EOT
242
243 $DB::single = 1;
244 if ( $self->tests ) {
245 my @tests = split ' ', $self->tests;
246 my %seen;
247 $args->{test} = {
248 TESTS => (join ' ', grep {!$seen{$_}++} @tests),
249 };
250 } elsif ( $Module::Install::ExtraTests::use_extratests ) {
251 # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness.
252 # So, just ignore our xt tests here.
253 } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) {
254 $args->{test} = {
255 TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ),
256 };
257 }
258 if ( $] >= 5.005 ) {
259 $args->{ABSTRACT} = $self->abstract;
260 $args->{AUTHOR} = join ', ', @{$self->author || []};
261 }
262 if ( $self->makemaker(6.10) ) {
263 $args->{NO_META} = 1;
264 #$args->{NO_MYMETA} = 1;
265 }
266 if ( $self->makemaker(6.17) and $self->sign ) {
267 $args->{SIGN} = 1;
268 }
269 unless ( $self->is_admin ) {
270 delete $args->{SIGN};
271 }
272 if ( $self->makemaker(6.31) and $self->license ) {
273 $args->{LICENSE} = $self->license;
274 }
275
276 my $prereq = ($args->{PREREQ_PM} ||= {});
277 %$prereq = ( %$prereq,
278 map { @$_ } # flatten [module => version]
279 map { @$_ }
280 grep $_,
281 ($self->requires)
282 );
283
284 # Remove any reference to perl, PREREQ_PM doesn't support it
285 delete $args->{PREREQ_PM}->{perl};
286
287 # Merge both kinds of requires into BUILD_REQUIRES
288 my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
289 %$build_prereq = ( %$build_prereq,
290 map { @$_ } # flatten [module => version]
291 map { @$_ }
292 grep $_,
293 ($self->configure_requires, $self->build_requires)
294 );
295
296 # Remove any reference to perl, BUILD_REQUIRES doesn't support it
297 delete $args->{BUILD_REQUIRES}->{perl};
298
299 # Delete bundled dists from prereq_pm, add it to Makefile DIR
300 my $subdirs = ($args->{DIR} || []);
301 if ($self->bundles) {
302 my %processed;
303 foreach my $bundle (@{ $self->bundles }) {
304 my ($mod_name, $dist_dir) = @$bundle;
305 delete $prereq->{$mod_name};
306 $dist_dir = File::Basename::basename($dist_dir); # dir for building this module
307 if (not exists $processed{$dist_dir}) {
308 if (-d $dist_dir) {
309 # List as sub-directory to be processed by make
310 push @$subdirs, $dist_dir;
311 }
312 # Else do nothing: the module is already present on the system
313 $processed{$dist_dir} = undef;
314 }
315 }
316 }
317
318 unless ( $self->makemaker('6.55_03') ) {
319 %$prereq = (%$prereq,%$build_prereq);
320 delete $args->{BUILD_REQUIRES};
321 }
322
323 if ( my $perl_version = $self->perl_version ) {
324 eval "use $perl_version; 1"
325 or die "ERROR: perl: Version $] is installed, "
326 . "but we need version >= $perl_version";
327
328 if ( $self->makemaker(6.48) ) {
329 $args->{MIN_PERL_VERSION} = $perl_version;
330 }
331 }
332
333 if ($self->installdirs) {
334 warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS};
335 $args->{INSTALLDIRS} = $self->installdirs;
336 }
337
338 my %args = map {
339 ( $_ => $args->{$_} ) } grep {defined($args->{$_} )
340 } keys %$args;
341
342 my $user_preop = delete $args{dist}->{PREOP};
343 if ( my $preop = $self->admin->preop($user_preop) ) {
344 foreach my $key ( keys %$preop ) {
345 $args{dist}->{$key} = $preop->{$key};
346 }
347 }
348
349 my $mm = ExtUtils::MakeMaker::WriteMakefile(%args);
350 $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile');
351 }
352
353 sub fix_up_makefile {
354 my $self = shift;
355 my $makefile_name = shift;
356 my $top_class = ref($self->_top) || '';
357 my $top_version = $self->_top->VERSION || '';
358
359 my $preamble = $self->preamble
360 ? "# Preamble by $top_class $top_version\n"
361 . $self->preamble
362 : '';
363 my $postamble = "# Postamble by $top_class $top_version\n"
364 . ($self->postamble || '');
365
366 local *MAKEFILE;
367 open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!";
368 eval { flock MAKEFILE, LOCK_EX };
369 my $makefile = do { local $/; <MAKEFILE> };
370
371 $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /;
372 $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g;
373 $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g;
374 $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m;
375 $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m;
376
377 # Module::Install will never be used to build the Core Perl
378 # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks
379 # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist
380 $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m;
381 #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m;
382
383 # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well.
384 $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g;
385
386 # XXX - This is currently unused; not sure if it breaks other MM-users
387 # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg;
388
389 seek MAKEFILE, 0, SEEK_SET;
390 truncate MAKEFILE, 0;
391 print MAKEFILE "$preamble$makefile$postamble" or die $!;
392 close MAKEFILE or die $!;
393
394 1;
395 }
396
397 sub preamble {
398 my ($self, $text) = @_;
399 $self->{preamble} = $text . $self->{preamble} if defined $text;
400 $self->{preamble};
401 }
402
403 sub postamble {
404 my ($self, $text) = @_;
405 $self->{postamble} ||= $self->admin->postamble;
406 $self->{postamble} .= $text if defined $text;
407 $self->{postamble}
408 }
409
410 1;
411
412 __END__
413
414 #line 541
+715
-0
inc/Module/Install/Metadata.pm less more
0 #line 1
1 package Module::Install::Metadata;
2
3 use strict 'vars';
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.00';
9 @ISA = 'Module::Install::Base';
10 $ISCORE = 1;
11 }
12
13 my @boolean_keys = qw{
14 sign
15 };
16
17 my @scalar_keys = qw{
18 name
19 module_name
20 abstract
21 version
22 distribution_type
23 tests
24 installdirs
25 };
26
27 my @tuple_keys = qw{
28 configure_requires
29 build_requires
30 requires
31 recommends
32 bundles
33 resources
34 };
35
36 my @resource_keys = qw{
37 homepage
38 bugtracker
39 repository
40 };
41
42 my @array_keys = qw{
43 keywords
44 author
45 };
46
47 *authors = \&author;
48
49 sub Meta { shift }
50 sub Meta_BooleanKeys { @boolean_keys }
51 sub Meta_ScalarKeys { @scalar_keys }
52 sub Meta_TupleKeys { @tuple_keys }
53 sub Meta_ResourceKeys { @resource_keys }
54 sub Meta_ArrayKeys { @array_keys }
55
56 foreach my $key ( @boolean_keys ) {
57 *$key = sub {
58 my $self = shift;
59 if ( defined wantarray and not @_ ) {
60 return $self->{values}->{$key};
61 }
62 $self->{values}->{$key} = ( @_ ? $_[0] : 1 );
63 return $self;
64 };
65 }
66
67 foreach my $key ( @scalar_keys ) {
68 *$key = sub {
69 my $self = shift;
70 return $self->{values}->{$key} if defined wantarray and !@_;
71 $self->{values}->{$key} = shift;
72 return $self;
73 };
74 }
75
76 foreach my $key ( @array_keys ) {
77 *$key = sub {
78 my $self = shift;
79 return $self->{values}->{$key} if defined wantarray and !@_;
80 $self->{values}->{$key} ||= [];
81 push @{$self->{values}->{$key}}, @_;
82 return $self;
83 };
84 }
85
86 foreach my $key ( @resource_keys ) {
87 *$key = sub {
88 my $self = shift;
89 unless ( @_ ) {
90 return () unless $self->{values}->{resources};
91 return map { $_->[1] }
92 grep { $_->[0] eq $key }
93 @{ $self->{values}->{resources} };
94 }
95 return $self->{values}->{resources}->{$key} unless @_;
96 my $uri = shift or die(
97 "Did not provide a value to $key()"
98 );
99 $self->resources( $key => $uri );
100 return 1;
101 };
102 }
103
104 foreach my $key ( grep { $_ ne "resources" } @tuple_keys) {
105 *$key = sub {
106 my $self = shift;
107 return $self->{values}->{$key} unless @_;
108 my @added;
109 while ( @_ ) {
110 my $module = shift or last;
111 my $version = shift || 0;
112 push @added, [ $module, $version ];
113 }
114 push @{ $self->{values}->{$key} }, @added;
115 return map {@$_} @added;
116 };
117 }
118
119 # Resource handling
120 my %lc_resource = map { $_ => 1 } qw{
121 homepage
122 license
123 bugtracker
124 repository
125 };
126
127 sub resources {
128 my $self = shift;
129 while ( @_ ) {
130 my $name = shift or last;
131 my $value = shift or next;
132 if ( $name eq lc $name and ! $lc_resource{$name} ) {
133 die("Unsupported reserved lowercase resource '$name'");
134 }
135 $self->{values}->{resources} ||= [];
136 push @{ $self->{values}->{resources} }, [ $name, $value ];
137 }
138 $self->{values}->{resources};
139 }
140
141 # Aliases for build_requires that will have alternative
142 # meanings in some future version of META.yml.
143 sub test_requires { shift->build_requires(@_) }
144 sub install_requires { shift->build_requires(@_) }
145
146 # Aliases for installdirs options
147 sub install_as_core { $_[0]->installdirs('perl') }
148 sub install_as_cpan { $_[0]->installdirs('site') }
149 sub install_as_site { $_[0]->installdirs('site') }
150 sub install_as_vendor { $_[0]->installdirs('vendor') }
151
152 sub dynamic_config {
153 my $self = shift;
154 unless ( @_ ) {
155 warn "You MUST provide an explicit true/false value to dynamic_config\n";
156 return $self;
157 }
158 $self->{values}->{dynamic_config} = $_[0] ? 1 : 0;
159 return 1;
160 }
161
162 sub perl_version {
163 my $self = shift;
164 return $self->{values}->{perl_version} unless @_;
165 my $version = shift or die(
166 "Did not provide a value to perl_version()"
167 );
168
169 # Normalize the version
170 $version = $self->_perl_version($version);
171
172 # We don't support the reall old versions
173 unless ( $version >= 5.005 ) {
174 die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n";
175 }
176
177 $self->{values}->{perl_version} = $version;
178 }
179
180 sub all_from {
181 my ( $self, $file ) = @_;
182
183 unless ( defined($file) ) {
184 my $name = $self->name or die(
185 "all_from called with no args without setting name() first"
186 );
187 $file = join('/', 'lib', split(/-/, $name)) . '.pm';
188 $file =~ s{.*/}{} unless -e $file;
189 unless ( -e $file ) {
190 die("all_from cannot find $file from $name");
191 }
192 }
193 unless ( -f $file ) {
194 die("The path '$file' does not exist, or is not a file");
195 }
196
197 $self->{values}{all_from} = $file;
198
199 # Some methods pull from POD instead of code.
200 # If there is a matching .pod, use that instead
201 my $pod = $file;
202 $pod =~ s/\.pm$/.pod/i;
203 $pod = $file unless -e $pod;
204
205 # Pull the different values
206 $self->name_from($file) unless $self->name;
207 $self->version_from($file) unless $self->version;
208 $self->perl_version_from($file) unless $self->perl_version;
209 $self->author_from($pod) unless @{$self->author || []};
210 $self->license_from($pod) unless $self->license;
211 $self->abstract_from($pod) unless $self->abstract;
212
213 return 1;
214 }
215
216 sub provides {
217 my $self = shift;
218 my $provides = ( $self->{values}->{provides} ||= {} );
219 %$provides = (%$provides, @_) if @_;
220 return $provides;
221 }
222
223 sub auto_provides {
224 my $self = shift;
225 return $self unless $self->is_admin;
226 unless (-e 'MANIFEST') {
227 warn "Cannot deduce auto_provides without a MANIFEST, skipping\n";
228 return $self;
229 }
230 # Avoid spurious warnings as we are not checking manifest here.
231 local $SIG{__WARN__} = sub {1};
232 require ExtUtils::Manifest;
233 local *ExtUtils::Manifest::manicheck = sub { return };
234
235 require Module::Build;
236 my $build = Module::Build->new(
237 dist_name => $self->name,
238 dist_version => $self->version,
239 license => $self->license,
240 );
241 $self->provides( %{ $build->find_dist_packages || {} } );
242 }
243
244 sub feature {
245 my $self = shift;
246 my $name = shift;
247 my $features = ( $self->{values}->{features} ||= [] );
248 my $mods;
249
250 if ( @_ == 1 and ref( $_[0] ) ) {
251 # The user used ->feature like ->features by passing in the second
252 # argument as a reference. Accomodate for that.
253 $mods = $_[0];
254 } else {
255 $mods = \@_;
256 }
257
258 my $count = 0;
259 push @$features, (
260 $name => [
261 map {
262 ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_
263 } @$mods
264 ]
265 );
266
267 return @$features;
268 }
269
270 sub features {
271 my $self = shift;
272 while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) {
273 $self->feature( $name, @$mods );
274 }
275 return $self->{values}->{features}
276 ? @{ $self->{values}->{features} }
277 : ();
278 }
279
280 sub no_index {
281 my $self = shift;
282 my $type = shift;
283 push @{ $self->{values}->{no_index}->{$type} }, @_ if $type;
284 return $self->{values}->{no_index};
285 }
286
287 sub read {
288 my $self = shift;
289 $self->include_deps( 'YAML::Tiny', 0 );
290
291 require YAML::Tiny;
292 my $data = YAML::Tiny::LoadFile('META.yml');
293
294 # Call methods explicitly in case user has already set some values.
295 while ( my ( $key, $value ) = each %$data ) {
296 next unless $self->can($key);
297 if ( ref $value eq 'HASH' ) {
298 while ( my ( $module, $version ) = each %$value ) {
299 $self->can($key)->($self, $module => $version );
300 }
301 } else {
302 $self->can($key)->($self, $value);
303 }
304 }
305 return $self;
306 }
307
308 sub write {
309 my $self = shift;
310 return $self unless $self->is_admin;
311 $self->admin->write_meta;
312 return $self;
313 }
314
315 sub version_from {
316 require ExtUtils::MM_Unix;
317 my ( $self, $file ) = @_;
318 $self->version( ExtUtils::MM_Unix->parse_version($file) );
319
320 # for version integrity check
321 $self->makemaker_args( VERSION_FROM => $file );
322 }
323
324 sub abstract_from {
325 require ExtUtils::MM_Unix;
326 my ( $self, $file ) = @_;
327 $self->abstract(
328 bless(
329 { DISTNAME => $self->name },
330 'ExtUtils::MM_Unix'
331 )->parse_abstract($file)
332 );
333 }
334
335 # Add both distribution and module name
336 sub name_from {
337 my ($self, $file) = @_;
338 if (
339 Module::Install::_read($file) =~ m/
340 ^ \s*
341 package \s*
342 ([\w:]+)
343 \s* ;
344 /ixms
345 ) {
346 my ($name, $module_name) = ($1, $1);
347 $name =~ s{::}{-}g;
348 $self->name($name);
349 unless ( $self->module_name ) {
350 $self->module_name($module_name);
351 }
352 } else {
353 die("Cannot determine name from $file\n");
354 }
355 }
356
357 sub _extract_perl_version {
358 if (
359 $_[0] =~ m/
360 ^\s*
361 (?:use|require) \s*
362 v?
363 ([\d_\.]+)
364 \s* ;
365 /ixms
366 ) {
367 my $perl_version = $1;
368 $perl_version =~ s{_}{}g;
369 return $perl_version;
370 } else {
371 return;
372 }
373 }
374
375 sub perl_version_from {
376 my $self = shift;
377 my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
378 if ($perl_version) {
379 $self->perl_version($perl_version);
380 } else {
381 warn "Cannot determine perl version info from $_[0]\n";
382 return;
383 }
384 }
385
386 sub author_from {
387 my $self = shift;
388 my $content = Module::Install::_read($_[0]);
389 if ($content =~ m/
390 =head \d \s+ (?:authors?)\b \s*
391 ([^\n]*)
392 |
393 =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s*
394 .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s*
395 ([^\n]*)
396 /ixms) {
397 my $author = $1 || $2;
398
399 # XXX: ugly but should work anyway...
400 if (eval "require Pod::Escapes; 1") {
401 # Pod::Escapes has a mapping table.
402 # It's in core of perl >= 5.9.3, and should be installed
403 # as one of the Pod::Simple's prereqs, which is a prereq
404 # of Pod::Text 3.x (see also below).
405 $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
406 {
407 defined $2
408 ? chr($2)
409 : defined $Pod::Escapes::Name2character_number{$1}
410 ? chr($Pod::Escapes::Name2character_number{$1})
411 : do {
412 warn "Unknown escape: E<$1>";
413 "E<$1>";
414 };
415 }gex;
416 }
417 elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) {
418 # Pod::Text < 3.0 has yet another mapping table,
419 # though the table name of 2.x and 1.x are different.
420 # (1.x is in core of Perl < 5.6, 2.x is in core of
421 # Perl < 5.9.3)
422 my $mapping = ($Pod::Text::VERSION < 2)
423 ? \%Pod::Text::HTML_Escapes
424 : \%Pod::Text::ESCAPES;
425 $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> }
426 {
427 defined $2
428 ? chr($2)
429 : defined $mapping->{$1}
430 ? $mapping->{$1}
431 : do {
432 warn "Unknown escape: E<$1>";
433 "E<$1>";
434 };
435 }gex;
436 }
437 else {
438 $author =~ s{E<lt>}{<}g;
439 $author =~ s{E<gt>}{>}g;
440 }
441 $self->author($author);
442 } else {
443 warn "Cannot determine author info from $_[0]\n";
444 }
445 }
446
447 #Stolen from M::B
448 my %license_urls = (
449 perl => 'http://dev.perl.org/licenses/',
450 apache => 'http://apache.org/licenses/LICENSE-2.0',
451 apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1',
452 artistic => 'http://opensource.org/licenses/artistic-license.php',
453 artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php',
454 lgpl => 'http://opensource.org/licenses/lgpl-license.php',
455 lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php',
456 lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html',
457 bsd => 'http://opensource.org/licenses/bsd-license.php',
458 gpl => 'http://opensource.org/licenses/gpl-license.php',
459 gpl2 => 'http://opensource.org/licenses/gpl-2.0.php',
460 gpl3 => 'http://opensource.org/licenses/gpl-3.0.html',
461 mit => 'http://opensource.org/licenses/mit-license.php',
462 mozilla => 'http://opensource.org/licenses/mozilla1.1.php',
463 open_source => undef,
464 unrestricted => undef,
465 restrictive => undef,
466 unknown => undef,
467 );
468
469 sub license {
470 my $self = shift;
471 return $self->{values}->{license} unless @_;
472 my $license = shift or die(
473 'Did not provide a value to license()'
474 );
475 $license = __extract_license($license) || lc $license;
476 $self->{values}->{license} = $license;
477
478 # Automatically fill in license URLs
479 if ( $license_urls{$license} ) {
480 $self->resources( license => $license_urls{$license} );
481 }
482
483 return 1;
484 }
485
486 sub _extract_license {
487 my $pod = shift;
488 my $matched;
489 return __extract_license(
490 ($matched) = $pod =~ m/
491 (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?)
492 (=head \d.*|=cut.*|)\z
493 /xms
494 ) || __extract_license(
495 ($matched) = $pod =~ m/
496 (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?)
497 (=head \d.*|=cut.*|)\z
498 /xms
499 );
500 }
501
502 sub __extract_license {
503 my $license_text = shift or return;
504 my @phrases = (
505 '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1,
506 '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
507 'Artistic and GPL' => 'perl', 1,
508 'GNU general public license' => 'gpl', 1,
509 'GNU public license' => 'gpl', 1,
510 'GNU lesser general public license' => 'lgpl', 1,
511 'GNU lesser public license' => 'lgpl', 1,
512 'GNU library general public license' => 'lgpl', 1,
513 'GNU library public license' => 'lgpl', 1,
514 'GNU Free Documentation license' => 'unrestricted', 1,
515 'GNU Affero General Public License' => 'open_source', 1,
516 '(?:Free)?BSD license' => 'bsd', 1,
517 'Artistic license' => 'artistic', 1,
518 'Apache (?:Software )?license' => 'apache', 1,
519 'GPL' => 'gpl', 1,
520 'LGPL' => 'lgpl', 1,
521 'BSD' => 'bsd', 1,
522 'Artistic' => 'artistic', 1,
523 'MIT' => 'mit', 1,
524 'Mozilla Public License' => 'mozilla', 1,
525 'Q Public License' => 'open_source', 1,
526 'OpenSSL License' => 'unrestricted', 1,
527 'SSLeay License' => 'unrestricted', 1,
528 'zlib License' => 'open_source', 1,
529 'proprietary' => 'proprietary', 0,
530 );
531 while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
532 $pattern =~ s#\s+#\\s+#gs;
533 if ( $license_text =~ /\b$pattern\b/i ) {
534 return $license;
535 }
536 }
537 return '';
538 }
539
540 sub license_from {
541 my $self = shift;
542 if (my $license=_extract_license(Module::Install::_read($_[0]))) {
543 $self->license($license);
544 } else {
545 warn "Cannot determine license info from $_[0]\n";
546 return 'unknown';
547 }
548 }
549
550 sub _extract_bugtracker {
551 my @links = $_[0] =~ m#L<(
552 \Qhttp://rt.cpan.org/\E[^>]+|
553 \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
554 \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
555 )>#gx;
556 my %links;
557 @links{@links}=();
558 @links=keys %links;
559 return @links;
560 }
561
562 sub bugtracker_from {
563 my $self = shift;
564 my $content = Module::Install::_read($_[0]);
565 my @links = _extract_bugtracker($content);
566 unless ( @links ) {
567 warn "Cannot determine bugtracker info from $_[0]\n";
568 return 0;
569 }
570 if ( @links > 1 ) {
571 warn "Found more than one bugtracker link in $_[0]\n";
572 return 0;
573 }
574
575 # Set the bugtracker
576 bugtracker( $links[0] );
577 return 1;
578 }
579
580 sub requires_from {
581 my $self = shift;
582 my $content = Module::Install::_readperl($_[0]);
583 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
584 while ( @requires ) {
585 my $module = shift @requires;
586 my $version = shift @requires;
587 $self->requires( $module => $version );
588 }
589 }
590
591 sub test_requires_from {
592 my $self = shift;
593 my $content = Module::Install::_readperl($_[0]);
594 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
595 while ( @requires ) {
596 my $module = shift @requires;
597 my $version = shift @requires;
598 $self->test_requires( $module => $version );
599 }
600 }
601
602 # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
603 # numbers (eg, 5.006001 or 5.008009).
604 # Also, convert double-part versions (eg, 5.8)
605 sub _perl_version {
606 my $v = $_[-1];
607 $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
608 $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
609 $v =~ s/(\.\d\d\d)000$/$1/;
610 $v =~ s/_.+$//;
611 if ( ref($v) ) {
612 # Numify
613 $v = $v + 0;
614 }
615 return $v;
616 }
617
618 sub add_metadata {
619 my $self = shift;
620 my %hash = @_;
621 for my $key (keys %hash) {
622 warn "add_metadata: $key is not prefixed with 'x_'.\n" .
623 "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
624 $self->{values}->{$key} = $hash{$key};
625 }
626 }
627
628
629 ######################################################################
630 # MYMETA Support
631
632 sub WriteMyMeta {
633 die "WriteMyMeta has been deprecated";
634 }
635
636 sub write_mymeta_yaml {
637 my $self = shift;
638
639 # We need YAML::Tiny to write the MYMETA.yml file
640 unless ( eval { require YAML::Tiny; 1; } ) {
641 return 1;
642 }
643
644 # Generate the data
645 my $meta = $self->_write_mymeta_data or return 1;
646
647 # Save as the MYMETA.yml file
648 print "Writing MYMETA.yml\n";
649 YAML::Tiny::DumpFile('MYMETA.yml', $meta);
650 }
651
652 sub write_mymeta_json {
653 my $self = shift;
654
655 # We need JSON to write the MYMETA.json file
656 unless ( eval { require JSON; 1; } ) {
657 return 1;
658 }
659
660 # Generate the data
661 my $meta = $self->_write_mymeta_data or return 1;
662
663 # Save as the MYMETA.yml file
664 print "Writing MYMETA.json\n";
665 Module::Install::_write(
666 'MYMETA.json',
667 JSON->new->pretty(1)->canonical->encode($meta),
668 );
669 }
670
671 sub _write_mymeta_data {
672 my $self = shift;
673
674 # If there's no existing META.yml there is nothing we can do
675 return undef unless -f 'META.yml';
676
677 # We need Parse::CPAN::Meta to load the file
678 unless ( eval { require Parse::CPAN::Meta; 1; } ) {
679 return undef;
680 }
681
682 # Merge the perl version into the dependencies
683 my $val = $self->Meta->{values};
684 my $perl = delete $val->{perl_version};
685 if ( $perl ) {
686 $val->{requires} ||= [];
687 my $requires = $val->{requires};
688
689 # Canonize to three-dot version after Perl 5.6
690 if ( $perl >= 5.006 ) {
691 $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
692 }
693 unshift @$requires, [ perl => $perl ];
694 }
695
696 # Load the advisory META.yml file
697 my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
698 my $meta = $yaml[0];
699
700 # Overwrite the non-configure dependency hashs
701 delete $meta->{requires};
702 delete $meta->{build_requires};
703 delete $meta->{recommends};
704 if ( exists $val->{requires} ) {
705 $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
706 }
707 if ( exists $val->{build_requires} ) {
708 $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
709 }
710
711 return $meta;
712 }
713
714 1;
+88
-0
inc/Module/Install/Repository.pm less more
0 #line 1
1 package Module::Install::Repository;
2
3 use strict;
4 use 5.005;
5 use vars qw($VERSION);
6 $VERSION = '0.06';
7
8 use base qw(Module::Install::Base);
9
10 sub _execute {
11 my ($command) = @_;
12 `$command`;
13 }
14
15 sub auto_set_repository {
16 my $self = shift;
17
18 return unless $Module::Install::AUTHOR;
19
20 my $repo = _find_repo(\&_execute);
21 if ($repo) {
22 $self->repository($repo);
23 } else {
24 warn "Cannot determine repository URL\n";
25 }
26 }
27
28 sub _find_repo {
29 my ($execute) = @_;
30
31 if (-e ".git") {
32 # TODO support remote besides 'origin'?
33 if ($execute->('git remote show -n origin') =~ /URL: (.*)$/m) {
34 # XXX Make it public clone URL, but this only works with github
35 my $git_url = $1;
36 $git_url =~ s![\w\-]+\@([^:]+):!git://$1/!;
37 return $git_url;
38 } elsif ($execute->('git svn info') =~ /URL: (.*)$/m) {
39 return $1;
40 }
41 } elsif (-e ".svn") {
42 if (`svn info` =~ /URL: (.*)$/m) {
43 return $1;
44 }
45 } elsif (-e "_darcs") {
46 # defaultrepo is better, but that is more likely to be ssh, not http
47 if (my $query_repo = `darcs query repo`) {
48 if ($query_repo =~ m!Default Remote: (http://.+)!) {
49 return $1;
50 }
51 }
52
53 open my $handle, '<', '_darcs/prefs/repos' or return;
54 while (<$handle>) {
55 chomp;
56 return $_ if m!^http://!;
57 }
58 } elsif (-e ".hg") {
59 if ($execute->('hg paths') =~ /default = (.*)$/m) {
60 my $mercurial_url = $1;
61 $mercurial_url =~ s!^ssh://hg\@(bitbucket\.org/)!https://$1!;
62 return $mercurial_url;
63 }
64 } elsif (-e "$ENV{HOME}/.svk") {
65 # Is there an explicit way to check if it's an svk checkout?
66 my $svk_info = `svk info` or return;
67 SVK_INFO: {
68 if ($svk_info =~ /Mirrored From: (.*), Rev\./) {
69 return $1;
70 }
71
72 if ($svk_info =~ m!Merged From: (/mirror/.*), Rev\.!) {
73 $svk_info = `svk info /$1` or return;
74 redo SVK_INFO;
75 }
76 }
77
78 return;
79 }
80 }
81
82 1;
83 __END__
84
85 =encoding utf-8
86
87 #line 128
+29
-0
inc/Module/Install/TestBase.pm less more
0 #line 1
1 package Module::Install::TestBase;
2 use strict;
3 use warnings;
4
5 use Module::Install::Base;
6
7 use vars qw($VERSION @ISA);
8 BEGIN {
9 $VERSION = '0.11';
10 @ISA = 'Module::Install::Base';
11 }
12
13 sub use_test_base {
14 my $self = shift;
15 $self->include('Test::Base');
16 $self->include('Test::Base::Filter');
17 $self->include('Spiffy');
18 $self->include('Test::More');
19 $self->include('Test::Builder');
20 $self->include('Test::Builder::Module');
21 $self->requires('Filter::Util::Call');
22 }
23
24 1;
25
26 =encoding utf8
27
28 #line 70
+64
-0
inc/Module/Install/Win32.pm less more
0 #line 1
1 package Module::Install::Win32;
2
3 use strict;
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.00';
9 @ISA = 'Module::Install::Base';
10 $ISCORE = 1;
11 }
12
13 # determine if the user needs nmake, and download it if needed
14 sub check_nmake {
15 my $self = shift;
16 $self->load('can_run');
17 $self->load('get_file');
18
19 require Config;
20 return unless (
21 $^O eq 'MSWin32' and
22 $Config::Config{make} and
23 $Config::Config{make} =~ /^nmake\b/i and
24 ! $self->can_run('nmake')
25 );
26
27 print "The required 'nmake' executable not found, fetching it...\n";
28
29 require File::Basename;
30 my $rv = $self->get_file(
31 url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe',
32 ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe',
33 local_dir => File::Basename::dirname($^X),
34 size => 51928,
35 run => 'Nmake15.exe /o > nul',
36 check_for => 'Nmake.exe',
37 remove => 1,
38 );
39
40 die <<'END_MESSAGE' unless $rv;
41
42 -------------------------------------------------------------------------------
43
44 Since you are using Microsoft Windows, you will need the 'nmake' utility
45 before installation. It's available at:
46
47 http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe
48 or
49 ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe
50
51 Please download the file manually, save it to a directory in %PATH% (e.g.
52 C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to
53 that directory, and run "Nmake15.exe" from there; that will create the
54 'nmake.exe' file needed by this module.
55
56 You may then resume the installation process described in README.
57
58 -------------------------------------------------------------------------------
59 END_MESSAGE
60
61 }
62
63 1;
+63
-0
inc/Module/Install/WriteAll.pm less more
0 #line 1
1 package Module::Install::WriteAll;
2
3 use strict;
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.00';
9 @ISA = qw{Module::Install::Base};
10 $ISCORE = 1;
11 }
12
13 sub WriteAll {
14 my $self = shift;
15 my %args = (
16 meta => 1,
17 sign => 0,
18 inline => 0,
19 check_nmake => 1,
20 @_,
21 );
22
23 $self->sign(1) if $args{sign};
24 $self->admin->WriteAll(%args) if $self->is_admin;
25
26 $self->check_nmake if $args{check_nmake};
27 unless ( $self->makemaker_args->{PL_FILES} ) {
28 # XXX: This still may be a bit over-defensive...
29 unless ($self->makemaker(6.25)) {
30 $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL';
31 }
32 }
33
34 # Until ExtUtils::MakeMaker support MYMETA.yml, make sure
35 # we clean it up properly ourself.
36 $self->realclean_files('MYMETA.yml');
37
38 if ( $args{inline} ) {
39 $self->Inline->write;
40 } else {
41 $self->Makefile->write;
42 }
43
44 # The Makefile write process adds a couple of dependencies,
45 # so write the META.yml files after the Makefile.
46 if ( $args{meta} ) {
47 $self->Meta->write;
48 }
49
50 # Experimental support for MYMETA
51 if ( $ENV{X_MYMETA} ) {
52 if ( $ENV{X_MYMETA} eq 'JSON' ) {
53 $self->Meta->write_mymeta_json;
54 } else {
55 $self->Meta->write_mymeta_yaml;
56 }
57 }
58
59 return 1;
60 }
61
62 1;
+470
-0
inc/Module/Install.pm less more
0 #line 1
1 package Module::Install;
2
3 # For any maintainers:
4 # The load order for Module::Install is a bit magic.
5 # It goes something like this...
6 #
7 # IF ( host has Module::Install installed, creating author mode ) {
8 # 1. Makefile.PL calls "use inc::Module::Install"
9 # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
10 # 3. The installed version of inc::Module::Install loads
11 # 4. inc::Module::Install calls "require Module::Install"
12 # 5. The ./inc/ version of Module::Install loads
13 # } ELSE {
14 # 1. Makefile.PL calls "use inc::Module::Install"
15 # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
16 # 3. The ./inc/ version of Module::Install loads
17 # }
18
19 use 5.005;
20 use strict 'vars';
21 use Cwd ();
22 use File::Find ();
23 use File::Path ();
24
25 use vars qw{$VERSION $MAIN};
26 BEGIN {
27 # All Module::Install core packages now require synchronised versions.
28 # This will be used to ensure we don't accidentally load old or
29 # different versions of modules.
30 # This is not enforced yet, but will be some time in the next few
31 # releases once we can make sure it won't clash with custom
32 # Module::Install extensions.
33 $VERSION = '1.00';
34
35 # Storage for the pseudo-singleton
36 $MAIN = undef;
37
38 *inc::Module::Install::VERSION = *VERSION;
39 @inc::Module::Install::ISA = __PACKAGE__;
40
41 }
42
43 sub import {
44 my $class = shift;
45 my $self = $class->new(@_);
46 my $who = $self->_caller;
47
48 #-------------------------------------------------------------
49 # all of the following checks should be included in import(),
50 # to allow "eval 'require Module::Install; 1' to test
51 # installation of Module::Install. (RT #51267)
52 #-------------------------------------------------------------
53
54 # Whether or not inc::Module::Install is actually loaded, the
55 # $INC{inc/Module/Install.pm} is what will still get set as long as
56 # the caller loaded module this in the documented manner.
57 # If not set, the caller may NOT have loaded the bundled version, and thus
58 # they may not have a MI version that works with the Makefile.PL. This would
59 # result in false errors or unexpected behaviour. And we don't want that.
60 my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm';
61 unless ( $INC{$file} ) { die <<"END_DIE" }
62
63 Please invoke ${\__PACKAGE__} with:
64
65 use inc::${\__PACKAGE__};
66
67 not:
68
69 use ${\__PACKAGE__};
70
71 END_DIE
72
73 # This reportedly fixes a rare Win32 UTC file time issue, but
74 # as this is a non-cross-platform XS module not in the core,
75 # we shouldn't really depend on it. See RT #24194 for detail.
76 # (Also, this module only supports Perl 5.6 and above).
77 eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006;
78
79 # If the script that is loading Module::Install is from the future,
80 # then make will detect this and cause it to re-run over and over
81 # again. This is bad. Rather than taking action to touch it (which
82 # is unreliable on some platforms and requires write permissions)
83 # for now we should catch this and refuse to run.
84 if ( -f $0 ) {
85 my $s = (stat($0))[9];
86
87 # If the modification time is only slightly in the future,
88 # sleep briefly to remove the problem.
89 my $a = $s - time;
90 if ( $a > 0 and $a < 5 ) { sleep 5 }
91
92 # Too far in the future, throw an error.
93 my $t = time;
94 if ( $s > $t ) { die <<"END_DIE" }
95
96 Your installer $0 has a modification time in the future ($s > $t).
97
98 This is known to create infinite loops in make.
99
100 Please correct this, then run $0 again.
101
102 END_DIE
103 }
104
105
106 # Build.PL was formerly supported, but no longer is due to excessive
107 # difficulty in implementing every single feature twice.
108 if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" }
109
110 Module::Install no longer supports Build.PL.
111
112 It was impossible to maintain duel backends, and has been deprecated.
113
114 Please remove all Build.PL files and only use the Makefile.PL installer.
115
116 END_DIE
117
118 #-------------------------------------------------------------
119
120 # To save some more typing in Module::Install installers, every...
121 # use inc::Module::Install
122 # ...also acts as an implicit use strict.
123 $^H |= strict::bits(qw(refs subs vars));
124
125 #-------------------------------------------------------------
126
127 unless ( -f $self->{file} ) {
128 foreach my $key (keys %INC) {
129 delete $INC{$key} if $key =~ /Module\/Install/;
130 }
131
132 local $^W;
133 require "$self->{path}/$self->{dispatch}.pm";
134 File::Path::mkpath("$self->{prefix}/$self->{author}");
135 $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self );
136 $self->{admin}->init;
137 @_ = ($class, _self => $self);
138 goto &{"$self->{name}::import"};
139 }
140
141 local $^W;
142 *{"${who}::AUTOLOAD"} = $self->autoload;
143 $self->preload;
144
145 # Unregister loader and worker packages so subdirs can use them again
146 delete $INC{'inc/Module/Install.pm'};
147 delete $INC{'Module/Install.pm'};
148
149 # Save to the singleton
150 $MAIN = $self;
151
152 return 1;
153 }
154
155 sub autoload {
156 my $self = shift;
157 my $who = $self->_caller;
158 my $cwd = Cwd::cwd();
159 my $sym = "${who}::AUTOLOAD";
160 $sym->{$cwd} = sub {
161 my $pwd = Cwd::cwd();
162 if ( my $code = $sym->{$pwd} ) {
163 # Delegate back to parent dirs
164 goto &$code unless $cwd eq $pwd;
165 }
166 unless ($$sym =~ s/([^:]+)$//) {
167 # XXX: it looks like we can't retrieve the missing function
168 # via $$sym (usually $main::AUTOLOAD) in this case.
169 # I'm still wondering if we should slurp Makefile.PL to
170 # get some context or not ...
171 my ($package, $file, $line) = caller;
172 die <<"EOT";
173 Unknown function is found at $file line $line.
174 Execution of $file aborted due to runtime errors.
175
176 If you're a contributor to a project, you may need to install
177 some Module::Install extensions from CPAN (or other repository).
178 If you're a user of a module, please contact the author.
179 EOT
180 }
181 my $method = $1;
182 if ( uc($method) eq $method ) {
183 # Do nothing
184 return;
185 } elsif ( $method =~ /^_/ and $self->can($method) ) {
186 # Dispatch to the root M:I class
187 return $self->$method(@_);
188 }
189
190 # Dispatch to the appropriate plugin
191 unshift @_, ( $self, $1 );
192 goto &{$self->can('call')};
193 };
194 }
195
196 sub preload {
197 my $self = shift;
198 unless ( $self->{extensions} ) {
199 $self->load_extensions(
200 "$self->{prefix}/$self->{path}", $self
201 );
202 }
203
204 my @exts = @{$self->{extensions}};
205 unless ( @exts ) {
206 @exts = $self->{admin}->load_all_extensions;
207 }
208
209 my %seen;
210 foreach my $obj ( @exts ) {
211 while (my ($method, $glob) = each %{ref($obj) . '::'}) {
212 next unless $obj->can($method);
213 next if $method =~ /^_/;
214 next if $method eq uc($method);
215 $seen{$method}++;
216 }
217 }
218
219 my $who = $self->_caller;
220 foreach my $name ( sort keys %seen ) {
221 local $^W;
222 *{"${who}::$name"} = sub {
223 ${"${who}::AUTOLOAD"} = "${who}::$name";
224 goto &{"${who}::AUTOLOAD"};
225 };
226 }
227 }
228
229 sub new {
230 my ($class, %args) = @_;
231
232 delete $INC{'FindBin.pm'};
233 {
234 # to suppress the redefine warning
235 local $SIG{__WARN__} = sub {};
236 require FindBin;
237 }
238
239 # ignore the prefix on extension modules built from top level.
240 my $base_path = Cwd::abs_path($FindBin::Bin);
241 unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
242 delete $args{prefix};
243 }
244 return $args{_self} if $args{_self};
245
246 $args{dispatch} ||= 'Admin';
247 $args{prefix} ||= 'inc';
248 $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author');
249 $args{bundle} ||= 'inc/BUNDLES';
250 $args{base} ||= $base_path;
251 $class =~ s/^\Q$args{prefix}\E:://;
252 $args{name} ||= $class;
253 $args{version} ||= $class->VERSION;
254 unless ( $args{path} ) {
255 $args{path} = $args{name};
256 $args{path} =~ s!::!/!g;
257 }
258 $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm";
259 $args{wrote} = 0;
260
261 bless( \%args, $class );
262 }
263
264 sub call {
265 my ($self, $method) = @_;
266 my $obj = $self->load($method) or return;
267 splice(@_, 0, 2, $obj);
268 goto &{$obj->can($method)};
269 }
270
271 sub load {
272 my ($self, $method) = @_;
273
274 $self->load_extensions(
275 "$self->{prefix}/$self->{path}", $self
276 ) unless $self->{extensions};
277
278 foreach my $obj (@{$self->{extensions}}) {
279 return $obj if $obj->can($method);
280 }
281
282 my $admin = $self->{admin} or die <<"END_DIE";
283 The '$method' method does not exist in the '$self->{prefix}' path!
284 Please remove the '$self->{prefix}' directory and run $0 again to load it.
285 END_DIE
286
287 my $obj = $admin->load($method, 1);
288 push @{$self->{extensions}}, $obj;
289
290 $obj;
291 }
292
293 sub load_extensions {
294 my ($self, $path, $top) = @_;
295
296 my $should_reload = 0;
297 unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
298 unshift @INC, $self->{prefix};
299 $should_reload = 1;
300 }
301
302 foreach my $rv ( $self->find_extensions($path) ) {
303 my ($file, $pkg) = @{$rv};
304 next if $self->{pathnames}{$pkg};
305
306 local $@;
307 my $new = eval { local $^W; require $file; $pkg->can('new') };
308 unless ( $new ) {
309 warn $@ if $@;
310 next;
311 }
312 $self->{pathnames}{$pkg} =
313 $should_reload ? delete $INC{$file} : $INC{$file};
314 push @{$self->{extensions}}, &{$new}($pkg, _top => $top );
315 }
316
317 $self->{extensions} ||= [];
318 }
319
320 sub find_extensions {
321 my ($self, $path) = @_;
322
323 my @found;
324 File::Find::find( sub {
325 my $file = $File::Find::name;
326 return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
327 my $subpath = $1;
328 return if lc($subpath) eq lc($self->{dispatch});
329
330 $file = "$self->{path}/$subpath.pm";
331 my $pkg = "$self->{name}::$subpath";
332 $pkg =~ s!/!::!g;
333
334 # If we have a mixed-case package name, assume case has been preserved
335 # correctly. Otherwise, root through the file to locate the case-preserved
336 # version of the package name.
337 if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) {
338 my $content = Module::Install::_read($subpath . '.pm');
339 my $in_pod = 0;
340 foreach ( split //, $content ) {
341 $in_pod = 1 if /^=\w/;
342 $in_pod = 0 if /^=cut/;
343 next if ($in_pod || /^=cut/); # skip pod text
344 next if /^\s*#/; # and comments
345 if ( m/^\s*package\s+($pkg)\s*;/i ) {
346 $pkg = $1;
347 last;
348 }
349 }
350 }
351
352 push @found, [ $file, $pkg ];
353 }, $path ) if -d $path;
354
355 @found;
356 }
357
358
359
360
361
362 #####################################################################
363 # Common Utility Functions
364
365 sub _caller {
366 my $depth = 0;
367 my $call = caller($depth);
368 while ( $call eq __PACKAGE__ ) {
369 $depth++;
370 $call = caller($depth);
371 }
372 return $call;
373 }
374
375 # Done in evals to avoid confusing Perl::MinimumVersion
376 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
377 sub _read {
378 local *FH;
379 open( FH, '<', $_[0] ) or die "open($_[0]): $!";
380 my $string = do { local $/; <FH> };
381 close FH or die "close($_[0]): $!";
382 return $string;
383 }
384 END_NEW
385 sub _read {
386 local *FH;
387 open( FH, "< $_[0]" ) or die "open($_[0]): $!";
388 my $string = do { local $/; <FH> };
389 close FH or die "close($_[0]): $!";
390 return $string;
391 }
392 END_OLD
393
394 sub _readperl {
395 my $string = Module::Install::_read($_[0]);
396 $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
397 $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
398 $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
399 return $string;
400 }
401
402 sub _readpod {
403 my $string = Module::Install::_read($_[0]);
404 $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
405 return $string if $_[0] =~ /\.pod\z/;
406 $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
407 $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
408 $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg;
409 $string =~ s/^\n+//s;
410 return $string;
411 }
412
413 # Done in evals to avoid confusing Perl::MinimumVersion
414 eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
415 sub _write {
416 local *FH;
417 open( FH, '>', $_[0] ) or die "open($_[0]): $!";
418 foreach ( 1 .. $#_ ) {
419 print FH $_[$_] or die "print($_[0]): $!";
420 }
421 close FH or die "close($_[0]): $!";
422 }
423 END_NEW
424 sub _write {
425 local *FH;
426 open( FH, "> $_[0]" ) or die "open($_[0]): $!";
427 foreach ( 1 .. $#_ ) {
428 print FH $_[$_] or die "print($_[0]): $!";
429 }
430 close FH or die "close($_[0]): $!";
431 }
432 END_OLD
433
434 # _version is for processing module versions (eg, 1.03_05) not
435 # Perl versions (eg, 5.8.1).
436 sub _version ($) {
437 my $s = shift || 0;
438 my $d =()= $s =~ /(\.)/g;
439 if ( $d >= 2 ) {
440 # Normalise multipart versions
441 $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
442 }
443 $s =~ s/^(\d+)\.?//;
444 my $l = $1 || 0;
445 my @v = map {
446 $_ . '0' x (3 - length $_)
447 } $s =~ /(\d{1,3})\D?/g;
448 $l = $l . '.' . join '', @v if @v;
449 return $l + 0;
450 }
451
452 sub _cmp ($$) {
453 _version($_[0]) <=> _version($_[1]);
454 }
455
456 # Cloned from Params::Util::_CLASS
457 sub _CLASS ($) {
458 (
459 defined $_[0]
460 and
461 ! ref $_[0]
462 and
463 $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s
464 ) ? $_[0] : undef;
465 }
466
467 1;
468
469 # Copyright 2008 - 2010 Adam Kennedy.
+539
-0
inc/Spiffy.pm less more
0 #line 1
1 package Spiffy;
2 use strict;
3 use 5.006001;
4 use warnings;
5 use Carp;
6 require Exporter;
7 our $VERSION = '0.30';
8 our @EXPORT = ();
9 our @EXPORT_BASE = qw(field const stub super);
10 our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
11 our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
12
13 my $stack_frame = 0;
14 my $dump = 'yaml';
15 my $bases_map = {};
16
17 sub WWW; sub XXX; sub YYY; sub ZZZ;
18
19 # This line is here to convince "autouse" into believing we are autousable.
20 sub can {
21 ($_[1] eq 'import' and caller()->isa('autouse'))
22 ? \&Exporter::import # pacify autouse's equality test
23 : $_[0]->SUPER::can($_[1]) # normal case
24 }
25
26 # TODO
27 #
28 # Exported functions like field and super should be hidden so as not to
29 # be confused with methods that can be inherited.
30 #
31
32 sub new {
33 my $class = shift;
34 $class = ref($class) || $class;
35 my $self = bless {}, $class;
36 while (@_) {
37 my $method = shift;
38 $self->$method(shift);
39 }
40 return $self;
41 }
42
43 my $filtered_files = {};
44 my $filter_dump = 0;
45 my $filter_save = 0;
46 our $filter_result = '';
47 sub import {
48 no strict 'refs';
49 no warnings;
50 my $self_package = shift;
51
52 # XXX Using parse_arguments here might cause confusion, because the
53 # subclass's boolean_arguments and paired_arguments can conflict, causing
54 # difficult debugging. Consider using something truly local.
55 my ($args, @export_list) = do {
56 local *boolean_arguments = sub {
57 qw(
58 -base -Base -mixin -selfless
59 -XXX -dumper -yaml
60 -filter_dump -filter_save
61 )
62 };
63 local *paired_arguments = sub { qw(-package) };
64 $self_package->parse_arguments(@_);
65 };
66 return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list)
67 if $args->{-mixin};
68
69 $filter_dump = 1 if $args->{-filter_dump};
70 $filter_save = 1 if $args->{-filter_save};
71 $dump = 'yaml' if $args->{-yaml};
72 $dump = 'dumper' if $args->{-dumper};
73
74 local @EXPORT_BASE = @EXPORT_BASE;
75
76 if ($args->{-XXX}) {
77 push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}}
78 unless grep /^XXX$/, @EXPORT_BASE;
79 }
80
81 spiffy_filter()
82 if ($args->{-selfless} or $args->{-Base}) and
83 not $filtered_files->{(caller($stack_frame))[1]}++;
84
85 my $caller_package = $args->{-package} || caller($stack_frame);
86 push @{"$caller_package\::ISA"}, $self_package
87 if $args->{-Base} or $args->{-base};
88
89 for my $class (@{all_my_bases($self_package)}) {
90 next unless $class->isa('Spiffy');
91 my @export = grep {
92 not defined &{"$caller_package\::$_"};
93 } ( @{"$class\::EXPORT"},
94 ($args->{-Base} or $args->{-base})
95 ? @{"$class\::EXPORT_BASE"} : (),
96 );
97 my @export_ok = grep {
98 not defined &{"$caller_package\::$_"};
99 } @{"$class\::EXPORT_OK"};
100
101 # Avoid calling the expensive Exporter::export
102 # if there is nothing to do (optimization)
103 my %exportable = map { ($_, 1) } @export, @export_ok;
104 next unless keys %exportable;
105
106 my @export_save = @{"$class\::EXPORT"};
107 my @export_ok_save = @{"$class\::EXPORT_OK"};
108 @{"$class\::EXPORT"} = @export;
109 @{"$class\::EXPORT_OK"} = @export_ok;
110 my @list = grep {
111 (my $v = $_) =~ s/^[\!\:]//;
112 $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v};
113 } @export_list;
114 Exporter::export($class, $caller_package, @list);
115 @{"$class\::EXPORT"} = @export_save;
116 @{"$class\::EXPORT_OK"} = @export_ok_save;
117 }
118 }
119
120 sub spiffy_filter {
121 require Filter::Util::Call;
122 my $done = 0;
123 Filter::Util::Call::filter_add(
124 sub {
125 return 0 if $done;
126 my ($data, $end) = ('', '');
127 while (my $status = Filter::Util::Call::filter_read()) {
128 return $status if $status < 0;
129 if (/^__(?:END|DATA)__\r?$/) {
130 $end = $_;
131 last;
132 }
133 $data .= $_;
134 $_ = '';
135 }
136 $_ = $data;
137 my @my_subs;
138 s[^(sub\s+\w+\s+\{)(.*\n)]
139 [${1}my \$self = shift;$2]gm;
140 s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)]
141 [${1}${2}]gm;
142 s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n]
143 [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem;
144 my $preclare = '';
145 if (@my_subs) {
146 $preclare = join ',', map "\$$_", @my_subs;
147 $preclare = "my($preclare);";
148 }
149 $_ = "use strict;use warnings;$preclare${_};1;\n$end";
150 if ($filter_dump) { print; exit }
151 if ($filter_save) { $filter_result = $_; $_ = $filter_result; }
152 $done = 1;
153 }
154 );
155 }
156
157 sub base {
158 push @_, -base;
159 goto &import;
160 }
161
162 sub all_my_bases {
163 my $class = shift;
164
165 return $bases_map->{$class}
166 if defined $bases_map->{$class};
167
168 my @bases = ($class);
169 no strict 'refs';
170 for my $base_class (@{"${class}::ISA"}) {
171 push @bases, @{all_my_bases($base_class)};
172 }
173 my $used = {};
174 $bases_map->{$class} = [grep {not $used->{$_}++} @bases];
175 }
176
177 my %code = (
178 sub_start =>
179 "sub {\n",
180 set_default =>
181 " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
182 init =>
183 " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
184 " unless \$#_ > 0 or defined \$_[0]->{%s};\n",
185 weak_init =>
186 " return do {\n" .
187 " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" .
188 " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
189 " \$_[0]->{%s};\n" .
190 " } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
191 return_if_get =>
192 " return \$_[0]->{%s} unless \$#_ > 0;\n",
193 set =>
194 " \$_[0]->{%s} = \$_[1];\n",
195 weaken =>
196 " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
197 sub_end =>
198 " return \$_[0]->{%s};\n}\n",
199 );
200
201 sub field {
202 my $package = caller;
203 my ($args, @values) = do {
204 no warnings;
205 local *boolean_arguments = sub { (qw(-weak)) };
206 local *paired_arguments = sub { (qw(-package -init)) };
207 Spiffy->parse_arguments(@_);
208 };
209 my ($field, $default) = @values;
210 $package = $args->{-package} if defined $args->{-package};
211 die "Cannot have a default for a weakened field ($field)"
212 if defined $default && $args->{-weak};
213 return if defined &{"${package}::$field"};
214 require Scalar::Util if $args->{-weak};
215 my $default_string =
216 ( ref($default) eq 'ARRAY' and not @$default )
217 ? '[]'
218 : (ref($default) eq 'HASH' and not keys %$default )
219 ? '{}'
220 : default_as_code($default);
221
222 my $code = $code{sub_start};
223 if ($args->{-init}) {
224 my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
225 $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
226 }
227 $code .= sprintf $code{set_default}, $field, $default_string, $field
228 if defined $default;
229 $code .= sprintf $code{return_if_get}, $field;
230 $code .= sprintf $code{set}, $field;
231 $code .= sprintf $code{weaken}, $field, $field
232 if $args->{-weak};
233 $code .= sprintf $code{sub_end}, $field;
234
235 my $sub = eval $code;
236 die $@ if $@;
237 no strict 'refs';
238 *{"${package}::$field"} = $sub;
239 return $code if defined wantarray;
240 }
241
242 sub default_as_code {
243 require Data::Dumper;
244 local $Data::Dumper::Sortkeys = 1;
245 my $code = Data::Dumper::Dumper(shift);
246 $code =~ s/^\$VAR1 = //;
247 $code =~ s/;$//;
248 return $code;
249 }
250
251 sub const {
252 my $package = caller;
253 my ($args, @values) = do {
254 no warnings;
255 local *paired_arguments = sub { (qw(-package)) };
256 Spiffy->parse_arguments(@_);
257 };
258 my ($field, $default) = @values;
259 $package = $args->{-package} if defined $args->{-package};
260 no strict 'refs';
261 return if defined &{"${package}::$field"};
262 *{"${package}::$field"} = sub { $default }
263 }
264
265 sub stub {
266 my $package = caller;
267 my ($args, @values) = do {
268 no warnings;
269 local *paired_arguments = sub { (qw(-package)) };
270 Spiffy->parse_arguments(@_);
271 };
272 my ($field, $default) = @values;
273 $package = $args->{-package} if defined $args->{-package};
274 no strict 'refs';
275 return if defined &{"${package}::$field"};
276 *{"${package}::$field"} =
277 sub {
278 require Carp;
279 Carp::confess
280 "Method $field in package $package must be subclassed";
281 }
282 }
283
284 sub parse_arguments {
285 my $class = shift;
286 my ($args, @values) = ({}, ());
287 my %booleans = map { ($_, 1) } $class->boolean_arguments;
288 my %pairs = map { ($_, 1) } $class->paired_arguments;
289 while (@_) {
290 my $elem = shift;
291 if (defined $elem and defined $booleans{$elem}) {
292 $args->{$elem} = (@_ and $_[0] =~ /^[01]$/)
293 ? shift
294 : 1;
295 }
296 elsif (defined $elem and defined $pairs{$elem} and @_) {
297 $args->{$elem} = shift;
298 }
299 else {
300 push @values, $elem;
301 }
302 }
303 return wantarray ? ($args, @values) : $args;
304 }
305
306 sub boolean_arguments { () }
307 sub paired_arguments { () }
308
309 # get a unique id for any node
310 sub id {
311 if (not ref $_[0]) {
312 return 'undef' if not defined $_[0];
313 \$_[0] =~ /\((\w+)\)$/o or die;
314 return "$1-S";
315 }
316 require overload;
317 overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die;
318 return $1;
319 }
320
321 #===============================================================================
322 # It's super, man.
323 #===============================================================================
324 package DB;
325 {
326 no warnings 'redefine';
327 sub super_args {
328 my @dummy = caller(@_ ? $_[0] : 2);
329 return @DB::args;
330 }
331 }
332
333 package Spiffy;
334 sub super {
335 my $method;
336 my $frame = 1;
337 while ($method = (caller($frame++))[3]) {
338 $method =~ s/.*::// and last;
339 }
340 my @args = DB::super_args($frame);
341 @_ = @_ ? ($args[0], @_) : @args;
342 my $class = ref $_[0] ? ref $_[0] : $_[0];
343 my $caller_class = caller;
344 my $seen = 0;
345 my @super_classes = reverse grep {
346 ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1;
347 } reverse @{all_my_bases($class)};
348 for my $super_class (@super_classes) {
349 no strict 'refs';
350 next if $super_class eq $class;
351 if (defined &{"${super_class}::$method"}) {
352 ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"}
353 if $method eq 'AUTOLOAD';
354 return &{"${super_class}::$method"};
355 }
356 }
357 return;
358 }
359
360 #===============================================================================
361 # This code deserves a spanking, because it is being very naughty.
362 # It is exchanging base.pm's import() for its own, so that people
363 # can use base.pm with Spiffy modules, without being the wiser.
364 #===============================================================================
365 my $real_base_import;
366 my $real_mixin_import;
367
368 BEGIN {
369 require base unless defined $INC{'base.pm'};
370 $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm';
371 $real_base_import = \&base::import;
372 $real_mixin_import = \&mixin::import;
373 no warnings;
374 *base::import = \&spiffy_base_import;
375 *mixin::import = \&spiffy_mixin_import;
376 }
377
378 # my $i = 0;
379 # while (my $caller = caller($i++)) {
380 # next unless $caller eq 'base' or $caller eq 'mixin';
381 # croak <<END;
382 # Spiffy.pm must be loaded before calling 'use base' or 'use mixin' with a
383 # Spiffy module. See the documentation of Spiffy.pm for details.
384 # END
385 # }
386
387 sub spiffy_base_import {
388 my @base_classes = @_;
389 shift @base_classes;
390 no strict 'refs';
391 goto &$real_base_import
392 unless grep {
393 eval "require $_" unless %{"$_\::"};
394 $_->isa('Spiffy');
395 } @base_classes;
396 my $inheritor = caller(0);
397 for my $base_class (@base_classes) {
398 next if $inheritor->isa($base_class);
399 croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
400 "See the documentation of Spiffy.pm for details\n "
401 unless $base_class->isa('Spiffy');
402 $stack_frame = 1; # tell import to use different caller
403 import($base_class, '-base');
404 $stack_frame = 0;
405 }
406 }
407
408 sub mixin {
409 my $self = shift;
410 my $target_class = ref($self);
411 spiffy_mixin_import($target_class, @_)
412 }
413
414 sub spiffy_mixin_import {
415 my $target_class = shift;
416 $target_class = caller(0)
417 if $target_class eq 'mixin';
418 my $mixin_class = shift
419 or die "Nothing to mixin";
420 eval "require $mixin_class";
421 my @roles = @_;
422 my $pseudo_class = join '-', $target_class, $mixin_class, @roles;
423 my %methods = spiffy_mixin_methods($mixin_class, @roles);
424 no strict 'refs';
425 no warnings;
426 @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"};
427 @{"$target_class\::ISA"} = ($pseudo_class);
428 for (keys %methods) {
429 *{"$pseudo_class\::$_"} = $methods{$_};
430 }
431 }
432
433 sub spiffy_mixin_methods {
434 my $mixin_class = shift;
435 no strict 'refs';
436 my %methods = spiffy_all_methods($mixin_class);
437 map {
438 $methods{$_}
439 ? ($_, \ &{"$methods{$_}\::$_"})
440 : ($_, \ &{"$mixin_class\::$_"})
441 } @_
442 ? (get_roles($mixin_class, @_))
443 : (keys %methods);
444 }
445
446 sub get_roles {
447 my $mixin_class = shift;
448 my @roles = @_;
449 while (grep /^!*:/, @roles) {
450 @roles = map {
451 s/!!//g;
452 /^!:(.*)/ ? do {
453 my $m = "_role_$1";
454 map("!$_", $mixin_class->$m);
455 } :
456 /^:(.*)/ ? do {
457 my $m = "_role_$1";
458 ($mixin_class->$m);
459 } :
460 ($_)
461 } @roles;
462 }
463 if (@roles and $roles[0] =~ /^!/) {
464 my %methods = spiffy_all_methods($mixin_class);
465 unshift @roles, keys(%methods);
466 }
467 my %roles;
468 for (@roles) {
469 s/!!//g;
470 delete $roles{$1}, next
471 if /^!(.*)/;
472 $roles{$_} = 1;
473 }
474 keys %roles;
475 }
476
477 sub spiffy_all_methods {
478 no strict 'refs';
479 my $class = shift;
480 return if $class eq 'Spiffy';
481 my %methods = map {
482 ($_, $class)
483 } grep {
484 defined &{"$class\::$_"} and not /^_/
485 } keys %{"$class\::"};
486 my %super_methods;
487 %super_methods = spiffy_all_methods(${"$class\::ISA"}[0])
488 if @{"$class\::ISA"};
489 %{{%super_methods, %methods}};
490 }
491
492
493 # END of naughty code.
494 #===============================================================================
495 # Debugging support
496 #===============================================================================
497 sub spiffy_dump {
498 no warnings;
499 if ($dump eq 'dumper') {
500 require Data::Dumper;
501 $Data::Dumper::Sortkeys = 1;
502 $Data::Dumper::Indent = 1;
503 return Data::Dumper::Dumper(@_);
504 }
505 require YAML;
506 $YAML::UseVersion = 0;
507 return YAML::Dump(@_) . "...\n";
508 }
509
510 sub at_line_number {
511 my ($file_path, $line_number) = (caller(1))[1,2];
512 " at $file_path line $line_number\n";
513 }
514
515 sub WWW {
516 warn spiffy_dump(@_) . at_line_number;
517 return wantarray ? @_ : $_[0];
518 }
519
520 sub XXX {
521 die spiffy_dump(@_) . at_line_number;
522 }
523
524 sub YYY {
525 print spiffy_dump(@_) . at_line_number;
526 return wantarray ? @_ : $_[0];
527 }
528
529 sub ZZZ {
530 require Carp;
531 Carp::confess spiffy_dump(@_);
532 }
533
534 1;
535
536 __END__
537
538 #line 1066
+344
-0
inc/Test/Base/Filter.pm less more
0 #line 1
1 #. TODO:
2 #.
3
4 #===============================================================================
5 # This is the default class for handling Test::Base data filtering.
6 #===============================================================================
7 package Test::Base::Filter;
8 use Spiffy -Base;
9 use Spiffy ':XXX';
10
11 field 'current_block';
12
13 our $arguments;
14 sub current_arguments {
15 return undef unless defined $arguments;
16 my $args = $arguments;
17 $args =~ s/(\\s)/ /g;
18 $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee;
19 return $args;
20 }
21
22 sub assert_scalar {
23 return if @_ == 1;
24 require Carp;
25 my $filter = (caller(1))[3];
26 $filter =~ s/.*:://;
27 Carp::croak "Input to the '$filter' filter must be a scalar, not a list";
28 }
29
30 sub _apply_deepest {
31 my $method = shift;
32 return () unless @_;
33 if (ref $_[0] eq 'ARRAY') {
34 for my $aref (@_) {
35 @$aref = $self->_apply_deepest($method, @$aref);
36 }
37 return @_;
38 }
39 $self->$method(@_);
40 }
41
42 sub _split_array {
43 map {
44 [$self->split($_)];
45 } @_;
46 }
47
48 sub _peel_deepest {
49 return () unless @_;
50 if (ref $_[0] eq 'ARRAY') {
51 if (ref $_[0]->[0] eq 'ARRAY') {
52 for my $aref (@_) {
53 @$aref = $self->_peel_deepest(@$aref);
54 }
55 return @_;
56 }
57 return map { $_->[0] } @_;
58 }
59 return @_;
60 }
61
62 #===============================================================================
63 # these filters work on the leaves of nested arrays
64 #===============================================================================
65 sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
66 sub Reverse { $self->_apply_deepest(reverse => @_) }
67 sub Split { $self->_apply_deepest(_split_array => @_) }
68 sub Sort { $self->_apply_deepest(sort => @_) }
69
70
71 sub append {
72 my $suffix = $self->current_arguments;
73 map { $_ . $suffix } @_;
74 }
75
76 sub array {
77 return [@_];
78 }
79
80 sub base64_decode {
81 $self->assert_scalar(@_);
82 require MIME::Base64;
83 MIME::Base64::decode_base64(shift);
84 }
85
86 sub base64_encode {
87 $self->assert_scalar(@_);
88 require MIME::Base64;
89 MIME::Base64::encode_base64(shift);
90 }
91
92 sub chomp {
93 map { CORE::chomp; $_ } @_;
94 }
95
96 sub chop {
97 map { CORE::chop; $_ } @_;
98 }
99
100 sub dumper {
101 no warnings 'once';
102 require Data::Dumper;
103 local $Data::Dumper::Sortkeys = 1;
104 local $Data::Dumper::Indent = 1;
105 local $Data::Dumper::Terse = 1;
106 Data::Dumper::Dumper(@_);
107 }
108
109 sub escape {
110 $self->assert_scalar(@_);
111 my $text = shift;
112 $text =~ s/(\\.)/eval "qq{$1}"/ge;
113 return $text;
114 }
115
116 sub eval {
117 $self->assert_scalar(@_);
118 my @return = CORE::eval(shift);
119 return $@ if $@;
120 return @return;
121 }
122
123 sub eval_all {
124 $self->assert_scalar(@_);
125 my $out = '';
126 my $err = '';
127 Test::Base::tie_output(*STDOUT, $out);
128 Test::Base::tie_output(*STDERR, $err);
129 my $return = CORE::eval(shift);
130 no warnings;
131 untie *STDOUT;
132 untie *STDERR;
133 return $return, $@, $out, $err;
134 }
135
136 sub eval_stderr {
137 $self->assert_scalar(@_);
138 my $output = '';
139 Test::Base::tie_output(*STDERR, $output);
140 CORE::eval(shift);
141 no warnings;
142 untie *STDERR;
143 return $output;
144 }
145
146 sub eval_stdout {
147 $self->assert_scalar(@_);
148 my $output = '';
149 Test::Base::tie_output(*STDOUT, $output);
150 CORE::eval(shift);
151 no warnings;
152 untie *STDOUT;
153 return $output;
154 }
155
156 sub exec_perl_stdout {
157 my $tmpfile = "/tmp/test-blocks-$$";
158 $self->_write_to($tmpfile, @_);
159 open my $execution, "$^X $tmpfile 2>&1 |"
160 or die "Couldn't open subprocess: $!\n";
161 local $/;
162 my $output = <$execution>;
163 close $execution;
164 unlink($tmpfile)
165 or die "Couldn't unlink $tmpfile: $!\n";
166 return $output;
167 }
168
169 sub flatten {
170 $self->assert_scalar(@_);
171 my $ref = shift;
172 if (ref($ref) eq 'HASH') {
173 return map {
174 ($_, $ref->{$_});
175 } sort keys %$ref;
176 }
177 if (ref($ref) eq 'ARRAY') {
178 return @$ref;
179 }
180 die "Can only flatten a hash or array ref";
181 }
182
183 sub get_url {
184 $self->assert_scalar(@_);
185 my $url = shift;
186 CORE::chomp($url);
187 require LWP::Simple;
188 LWP::Simple::get($url);
189 }
190
191 sub hash {
192 return +{ @_ };
193 }
194
195 sub head {
196 my $size = $self->current_arguments || 1;
197 return splice(@_, 0, $size);
198 }
199
200 sub join {
201 my $string = $self->current_arguments;
202 $string = '' unless defined $string;
203 CORE::join $string, @_;
204 }
205
206 sub lines {
207 $self->assert_scalar(@_);
208 my $text = shift;
209 return () unless length $text;
210 my @lines = ($text =~ /^(.*\n?)/gm);
211 return @lines;
212 }
213
214 sub norm {
215 $self->assert_scalar(@_);
216 my $text = shift;
217 $text = '' unless defined $text;
218 $text =~ s/\015\012/\n/g;
219 $text =~ s/\r/\n/g;
220 return $text;
221 }
222
223 sub prepend {
224 my $prefix = $self->current_arguments;
225 map { $prefix . $_ } @_;
226 }
227
228 sub read_file {
229 $self->assert_scalar(@_);
230 my $file = shift;
231 CORE::chomp $file;
232 open my $fh, $file
233 or die "Can't open '$file' for input:\n$!";
234 CORE::join '', <$fh>;
235 }
236
237 sub regexp {
238 $self->assert_scalar(@_);
239 my $text = shift;
240 my $flags = $self->current_arguments;
241 if ($text =~ /\n.*?\n/s) {
242 $flags = 'xism'
243 unless defined $flags;
244 }
245 else {
246 CORE::chomp($text);
247 }
248 $flags ||= '';
249 my $regexp = eval "qr{$text}$flags";
250 die $@ if $@;
251 return $regexp;
252 }
253
254 sub reverse {
255 CORE::reverse(@_);
256 }
257
258 sub slice {
259 die "Invalid args for slice"
260 unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
261 my ($x, $y) = ($1, $2);
262 $y = $x if not defined $y;
263 die "Invalid args for slice"
264 if $x > $y;
265 return splice(@_, $x, 1 + $y - $x);
266 }
267
268 sub sort {
269 CORE::sort(@_);
270 }
271
272 sub split {
273 $self->assert_scalar(@_);
274 my $separator = $self->current_arguments;
275 if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
276 my $regexp = $1;
277 $separator = qr{$regexp};
278 }
279 $separator = qr/\s+/ unless $separator;
280 CORE::split $separator, shift;
281 }
282
283 sub strict {
284 $self->assert_scalar(@_);
285 <<'...' . shift;
286 use strict;
287 use warnings;
288 ...
289 }
290
291 sub tail {
292 my $size = $self->current_arguments || 1;
293 return splice(@_, @_ - $size, $size);
294 }
295
296 sub trim {
297 map {
298 s/\A([ \t]*\n)+//;
299 s/(?<=\n)\s*\z//g;
300 $_;
301 } @_;
302 }
303
304 sub unchomp {
305 map { $_ . "\n" } @_;
306 }
307
308 sub write_file {
309 my $file = $self->current_arguments
310 or die "No file specified for write_file filter";
311 if ($file =~ /(.*)[\\\/]/) {
312 my $dir = $1;
313 if (not -e $dir) {
314 require File::Path;
315 File::Path::mkpath($dir)
316 or die "Can't create $dir";
317 }
318 }
319 open my $fh, ">$file"
320 or die "Can't open '$file' for output\n:$!";
321 print $fh @_;
322 close $fh;
323 return $file;
324 }
325
326 sub yaml {
327 $self->assert_scalar(@_);
328 require YAML;
329 return YAML::Load(shift);
330 }
331
332 sub _write_to {
333 my $filename = shift;
334 open my $script, ">$filename"
335 or die "Couldn't open $filename: $!\n";
336 print $script @_;
337 close $script
338 or die "Couldn't close $filename: $!\n";
339 }
340
341 __DATA__
342
343 #line 639
+684
-0
inc/Test/Base.pm less more
0 #line 1
1 # TODO:
2 #
3 package Test::Base;
4 use 5.006001;
5 use Spiffy 0.30 -Base;
6 use Spiffy ':XXX';
7 our $VERSION = '0.59';
8
9 my @test_more_exports;
10 BEGIN {
11 @test_more_exports = qw(
12 ok isnt like unlike is_deeply cmp_ok
13 skip todo_skip pass fail
14 eq_array eq_hash eq_set
15 plan can_ok isa_ok diag
16 use_ok
17 $TODO
18 );
19 }
20
21 use Test::More import => \@test_more_exports;
22 use Carp;
23
24 our @EXPORT = (@test_more_exports, qw(
25 is no_diff
26
27 blocks next_block first_block
28 delimiters spec_file spec_string
29 filters filters_delay filter_arguments
30 run run_compare run_is run_is_deeply run_like run_unlike
31 skip_all_unless_require is_deep run_is_deep
32 WWW XXX YYY ZZZ
33 tie_output no_diag_on_only
34
35 find_my_self default_object
36
37 croak carp cluck confess
38 ));
39
40 field '_spec_file';
41 field '_spec_string';
42 field _filters => [qw(norm trim)];
43 field _filters_map => {};
44 field spec =>
45 -init => '$self->_spec_init';
46 field block_list =>
47 -init => '$self->_block_list_init';
48 field _next_list => [];
49 field block_delim =>
50 -init => '$self->block_delim_default';
51 field data_delim =>
52 -init => '$self->data_delim_default';
53 field _filters_delay => 0;
54 field _no_diag_on_only => 0;
55
56 field block_delim_default => '===';
57 field data_delim_default => '---';
58
59 my $default_class;
60 my $default_object;
61 my $reserved_section_names = {};
62
63 sub default_object {
64 $default_object ||= $default_class->new;
65 return $default_object;
66 }
67
68 my $import_called = 0;
69 sub import() {
70 $import_called = 1;
71 my $class = (grep /^-base$/i, @_)
72 ? scalar(caller)
73 : $_[0];
74 if (not defined $default_class) {
75 $default_class = $class;
76 }
77 # else {
78 # croak "Can't use $class after using $default_class"
79 # unless $default_class->isa($class);
80 # }
81
82 unless (grep /^-base$/i, @_) {
83 my @args;
84 for (my $ii = 1; $ii <= $#_; ++$ii) {
85 if ($_[$ii] eq '-package') {
86 ++$ii;
87 } else {
88 push @args, $_[$ii];
89 }
90 }
91 Test::More->import(import => \@test_more_exports, @args)
92 if @args;
93 }
94
95 _strict_warnings();
96 goto &Spiffy::import;
97 }
98
99 # Wrap Test::Builder::plan
100 my $plan_code = \&Test::Builder::plan;
101 my $Have_Plan = 0;
102 {
103 no warnings 'redefine';
104 *Test::Builder::plan = sub {
105 $Have_Plan = 1;
106 goto &$plan_code;
107 };
108 }
109
110 my $DIED = 0;
111 $SIG{__DIE__} = sub { $DIED = 1; die @_ };
112
113 sub block_class { $self->find_class('Block') }
114 sub filter_class { $self->find_class('Filter') }
115
116 sub find_class {
117 my $suffix = shift;
118 my $class = ref($self) . "::$suffix";
119 return $class if $class->can('new');
120 $class = __PACKAGE__ . "::$suffix";
121 return $class if $class->can('new');
122 eval "require $class";
123 return $class if $class->can('new');
124 die "Can't find a class for $suffix";
125 }
126
127 sub check_late {
128 if ($self->{block_list}) {
129 my $caller = (caller(1))[3];
130 $caller =~ s/.*:://;
131 croak "Too late to call $caller()"
132 }
133 }
134
135 sub find_my_self() {
136 my $self = ref($_[0]) eq $default_class
137 ? splice(@_, 0, 1)
138 : default_object();
139 return $self, @_;
140 }
141
142 sub blocks() {
143 (my ($self), @_) = find_my_self(@_);
144
145 croak "Invalid arguments passed to 'blocks'"
146 if @_ > 1;
147 croak sprintf("'%s' is invalid argument to blocks()", shift(@_))
148 if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
149
150 my $blocks = $self->block_list;
151
152 my $section_name = shift || '';
153 my @blocks = $section_name
154 ? (grep { exists $_->{$section_name} } @$blocks)
155 : (@$blocks);
156
157 return scalar(@blocks) unless wantarray;
158
159 return (@blocks) if $self->_filters_delay;
160
161 for my $block (@blocks) {
162 $block->run_filters
163 unless $block->is_filtered;
164 }
165
166 return (@blocks);
167 }
168
169 sub next_block() {
170 (my ($self), @_) = find_my_self(@_);
171 my $list = $self->_next_list;
172 if (@$list == 0) {
173 $list = [@{$self->block_list}, undef];
174 $self->_next_list($list);
175 }
176 my $block = shift @$list;
177 if (defined $block and not $block->is_filtered) {
178 $block->run_filters;
179 }
180 return $block;
181 }
182
183 sub first_block() {
184 (my ($self), @_) = find_my_self(@_);
185 $self->_next_list([]);
186 $self->next_block;
187 }
188
189 sub filters_delay() {
190 (my ($self), @_) = find_my_self(@_);
191 $self->_filters_delay(defined $_[0] ? shift : 1);
192 }
193
194 sub no_diag_on_only() {
195 (my ($self), @_) = find_my_self(@_);
196 $self->_no_diag_on_only(defined $_[0] ? shift : 1);
197 }
198
199 sub delimiters() {
200 (my ($self), @_) = find_my_self(@_);
201 $self->check_late;
202 my ($block_delimiter, $data_delimiter) = @_;
203 $block_delimiter ||= $self->block_delim_default;
204 $data_delimiter ||= $self->data_delim_default;
205 $self->block_delim($block_delimiter);
206 $self->data_delim($data_delimiter);
207 return $self;
208 }
209
210 sub spec_file() {
211 (my ($self), @_) = find_my_self(@_);
212 $self->check_late;
213 $self->_spec_file(shift);
214 return $self;
215 }
216
217 sub spec_string() {
218 (my ($self), @_) = find_my_self(@_);
219 $self->check_late;
220 $self->_spec_string(shift);
221 return $self;
222 }
223
224 sub filters() {
225 (my ($self), @_) = find_my_self(@_);
226 if (ref($_[0]) eq 'HASH') {
227 $self->_filters_map(shift);
228 }
229 else {
230 my $filters = $self->_filters;
231 push @$filters, @_;
232 }
233 return $self;
234 }
235
236 sub filter_arguments() {
237 $Test::Base::Filter::arguments;
238 }
239
240 sub have_text_diff {
241 eval { require Text::Diff; 1 } &&
242 $Text::Diff::VERSION >= 0.35 &&
243 $Algorithm::Diff::VERSION >= 1.15;
244 }
245
246 sub is($$;$) {
247 (my ($self), @_) = find_my_self(@_);
248 my ($actual, $expected, $name) = @_;
249 local $Test::Builder::Level = $Test::Builder::Level + 1;
250 if ($ENV{TEST_SHOW_NO_DIFFS} or
251 not defined $actual or
252 not defined $expected or
253 $actual eq $expected or
254 not($self->have_text_diff) or
255 $expected !~ /\n./s
256 ) {
257 Test::More::is($actual, $expected, $name);
258 }
259 else {
260 $name = '' unless defined $name;
261 ok $actual eq $expected,
262 $name . "\n" . Text::Diff::diff(\$expected, \$actual);
263 }
264 }
265
266 sub run(&;$) {
267 (my ($self), @_) = find_my_self(@_);
268 my $callback = shift;
269 for my $block (@{$self->block_list}) {
270 $block->run_filters unless $block->is_filtered;
271 &{$callback}($block);
272 }
273 }
274
275 my $name_error = "Can't determine section names";
276 sub _section_names {
277 return @_ if @_ == 2;
278 my $block = $self->first_block
279 or croak $name_error;
280 my @names = grep {
281 $_ !~ /^(ONLY|LAST|SKIP)$/;
282 } @{$block->{_section_order}[0] || []};
283 croak "$name_error. Need two sections in first block"
284 unless @names == 2;
285 return @names;
286 }
287
288 sub _assert_plan {
289 plan('no_plan') unless $Have_Plan;
290 }
291
292 sub END {
293 run_compare() unless $Have_Plan or $DIED or not $import_called;
294 }
295
296 sub run_compare() {
297 (my ($self), @_) = find_my_self(@_);
298 $self->_assert_plan;
299 my ($x, $y) = $self->_section_names(@_);
300 local $Test::Builder::Level = $Test::Builder::Level + 1;
301 for my $block (@{$self->block_list}) {
302 next unless exists($block->{$x}) and exists($block->{$y});
303 $block->run_filters unless $block->is_filtered;
304 if (ref $block->$x) {
305 is_deeply($block->$x, $block->$y,
306 $block->name ? $block->name : ());
307 }
308 elsif (ref $block->$y eq 'Regexp') {
309 my $regexp = ref $y ? $y : $block->$y;
310 like($block->$x, $regexp, $block->name ? $block->name : ());
311 }
312 else {
313 is($block->$x, $block->$y, $block->name ? $block->name : ());
314 }
315 }
316 }
317
318 sub run_is() {
319 (my ($self), @_) = find_my_self(@_);
320 $self->_assert_plan;
321 my ($x, $y) = $self->_section_names(@_);
322 local $Test::Builder::Level = $Test::Builder::Level + 1;
323 for my $block (@{$self->block_list}) {
324 next unless exists($block->{$x}) and exists($block->{$y});
325 $block->run_filters unless $block->is_filtered;
326 is($block->$x, $block->$y,
327 $block->name ? $block->name : ()
328 );
329 }
330 }
331
332 sub run_is_deeply() {
333 (my ($self), @_) = find_my_self(@_);
334 $self->_assert_plan;
335 my ($x, $y) = $self->_section_names(@_);
336 for my $block (@{$self->block_list}) {
337 next unless exists($block->{$x}) and exists($block->{$y});
338 $block->run_filters unless $block->is_filtered;
339 is_deeply($block->$x, $block->$y,
340 $block->name ? $block->name : ()
341 );
342 }
343 }
344
345 sub run_like() {
346 (my ($self), @_) = find_my_self(@_);
347 $self->_assert_plan;
348 my ($x, $y) = $self->_section_names(@_);
349 for my $block (@{$self->block_list}) {
350 next unless exists($block->{$x}) and defined($y);
351 $block->run_filters unless $block->is_filtered;
352 my $regexp = ref $y ? $y : $block->$y;
353 like($block->$x, $regexp,
354 $block->name ? $block->name : ()
355 );
356 }
357 }
358
359 sub run_unlike() {
360 (my ($self), @_) = find_my_self(@_);
361 $self->_assert_plan;
362 my ($x, $y) = $self->_section_names(@_);
363 for my $block (@{$self->block_list}) {
364 next unless exists($block->{$x}) and defined($y);
365 $block->run_filters unless $block->is_filtered;
366 my $regexp = ref $y ? $y : $block->$y;
367 unlike($block->$x, $regexp,
368 $block->name ? $block->name : ()
369 );
370 }
371 }
372
373 sub skip_all_unless_require() {
374 (my ($self), @_) = find_my_self(@_);
375 my $module = shift;
376 eval "require $module; 1"
377 or Test::More::plan(
378 skip_all => "$module failed to load"
379 );
380 }
381
382 sub is_deep() {
383 (my ($self), @_) = find_my_self(@_);
384 require Test::Deep;
385 Test::Deep::cmp_deeply(@_);
386 }
387
388 sub run_is_deep() {
389 (my ($self), @_) = find_my_self(@_);
390 $self->_assert_plan;
391 my ($x, $y) = $self->_section_names(@_);
392 for my $block (@{$self->block_list}) {
393 next unless exists($block->{$x}) and exists($block->{$y});
394 $block->run_filters unless $block->is_filtered;
395 is_deep($block->$x, $block->$y,
396 $block->name ? $block->name : ()
397 );
398 }
399 }
400
401 sub _pre_eval {
402 my $spec = shift;
403 return $spec unless $spec =~
404 s/\A\s*<<<(.*?)>>>\s*$//sm;
405 my $eval_code = $1;
406 eval "package main; $eval_code";
407 croak $@ if $@;
408 return $spec;
409 }
410
411 sub _block_list_init {
412 my $spec = $self->spec;
413 $spec = $self->_pre_eval($spec);
414 my $cd = $self->block_delim;
415 my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg);
416 my $blocks = $self->_choose_blocks(@hunks);
417 $self->block_list($blocks); # Need to set early for possible filter use
418 my $seq = 1;
419 for my $block (@$blocks) {
420 $block->blocks_object($self);
421 $block->seq_num($seq++);
422 }
423 return $blocks;
424 }
425
426 sub _choose_blocks {
427 my $blocks = [];
428 for my $hunk (@_) {
429 my $block = $self->_make_block($hunk);
430 if (exists $block->{ONLY}) {
431 diag "I found ONLY: maybe you're debugging?"
432 unless $self->_no_diag_on_only;
433 return [$block];
434 }
435 next if exists $block->{SKIP};
436 push @$blocks, $block;
437 if (exists $block->{LAST}) {
438 return $blocks;
439 }
440 }
441 return $blocks;
442 }
443
444 sub _check_reserved {
445 my $id = shift;
446 croak "'$id' is a reserved name. Use something else.\n"
447 if $reserved_section_names->{$id} or
448 $id =~ /^_/;
449 }
450
451 sub _make_block {
452 my $hunk = shift;
453 my $cd = $self->block_delim;
454 my $dd = $self->data_delim;
455 my $block = $self->block_class->new;
456 $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die;
457 my $name = $1;
458 my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk;
459 my $description = shift @parts;
460 $description ||= '';
461 unless ($description =~ /\S/) {
462 $description = $name;
463 }
464 $description =~ s/\s*\z//;
465 $block->set_value(description => $description);
466
467 my $section_map = {};
468 my $section_order = [];
469 while (@parts) {
470 my ($type, $filters, $value) = splice(@parts, 0, 3);
471 $self->_check_reserved($type);
472 $value = '' unless defined $value;
473 $filters = '' unless defined $filters;
474 if ($filters =~ /:(\s|\z)/) {
475 croak "Extra lines not allowed in '$type' section"
476 if $value =~ /\S/;
477 ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2;
478 $value = '' unless defined $value;
479 $value =~ s/^\s*(.*?)\s*$/$1/;
480 }
481 $section_map->{$type} = {
482 filters => $filters,
483 };
484 push @$section_order, $type;
485 $block->set_value($type, $value);
486 }
487 $block->set_value(name => $name);
488 $block->set_value(_section_map => $section_map);
489 $block->set_value(_section_order => $section_order);
490 return $block;
491 }
492
493 sub _spec_init {
494 return $self->_spec_string
495 if $self->_spec_string;
496 local $/;
497 my $spec;
498 if (my $spec_file = $self->_spec_file) {
499 open FILE, $spec_file or die $!;
500 $spec = <FILE>;
501 close FILE;
502 }
503 else {
504 $spec = do {
505 package main;
506 no warnings 'once';
507 <DATA>;
508 };
509 }
510 return $spec;
511 }
512
513 sub _strict_warnings() {
514 require Filter::Util::Call;
515 my $done = 0;
516 Filter::Util::Call::filter_add(
517 sub {
518 return 0 if $done;
519 my ($data, $end) = ('', '');
520 while (my $status = Filter::Util::Call::filter_read()) {
521 return $status if $status < 0;
522 if (/^__(?:END|DATA)__\r?$/) {
523 $end = $_;
524 last;
525 }
526 $data .= $_;
527 $_ = '';
528 }
529 $_ = "use strict;use warnings;$data$end";
530 $done = 1;
531 }
532 );
533 }
534
535 sub tie_output() {
536 my $handle = shift;
537 die "No buffer to tie" unless @_;
538 tie $handle, 'Test::Base::Handle', $_[0];
539 }
540
541 sub no_diff {
542 $ENV{TEST_SHOW_NO_DIFFS} = 1;
543 }
544
545 package Test::Base::Handle;
546
547 sub TIEHANDLE() {
548 my $class = shift;
549 bless \ $_[0], $class;
550 }
551
552 sub PRINT {
553 $$self .= $_ for @_;
554 }
555
556 #===============================================================================
557 # Test::Base::Block
558 #
559 # This is the default class for accessing a Test::Base block object.
560 #===============================================================================
561 package Test::Base::Block;
562 our @ISA = qw(Spiffy);
563
564 our @EXPORT = qw(block_accessor);
565
566 sub AUTOLOAD {
567 return;
568 }
569
570 sub block_accessor() {
571 my $accessor = shift;
572 no strict 'refs';
573 return if defined &$accessor;
574 *$accessor = sub {
575 my $self = shift;
576 if (@_) {
577 Carp::croak "Not allowed to set values for '$accessor'";
578 }
579 my @list = @{$self->{$accessor} || []};
580 return wantarray
581 ? (@list)
582 : $list[0];
583 };
584 }
585
586 block_accessor 'name';
587 block_accessor 'description';
588 Spiffy::field 'seq_num';
589 Spiffy::field 'is_filtered';
590 Spiffy::field 'blocks_object';
591 Spiffy::field 'original_values' => {};
592
593 sub set_value {
594 no strict 'refs';
595 my $accessor = shift;
596 block_accessor $accessor
597 unless defined &$accessor;
598 $self->{$accessor} = [@_];
599 }
600
601 sub run_filters {
602 my $map = $self->_section_map;
603 my $order = $self->_section_order;
604 Carp::croak "Attempt to filter a block twice"
605 if $self->is_filtered;
606 for my $type (@$order) {
607 my $filters = $map->{$type}{filters};
608 my @value = $self->$type;
609 $self->original_values->{$type} = $value[0];
610 for my $filter ($self->_get_filters($type, $filters)) {
611 $Test::Base::Filter::arguments =
612 $filter =~ s/=(.*)$// ? $1 : undef;
613 my $function = "main::$filter";
614 no strict 'refs';
615 if (defined &$function) {
616 local $_ =
617 (@value == 1 and not defined($value[0])) ? undef :
618 join '', @value;
619 my $old = $_;
620 @value = &$function(@value);
621 if (not(@value) or
622 @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/
623 ) {
624 if ($value[0] && $_ eq $old) {
625 Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't.");
626 }
627 @value = ($_);
628 }
629 }
630 else {
631 my $filter_object = $self->blocks_object->filter_class->new;
632 die "Can't find a function or method for '$filter' filter\n"
633 unless $filter_object->can($filter);
634 $filter_object->current_block($self);
635 @value = $filter_object->$filter(@value);
636 }
637 # Set the value after each filter since other filters may be
638 # introspecting.
639 $self->set_value($type, @value);
640 }
641 }
642 $self->is_filtered(1);
643 }
644
645 sub _get_filters {
646 my $type = shift;
647 my $string = shift || '';
648 $string =~ s/\s*(.*?)\s*/$1/;
649 my @filters = ();
650 my $map_filters = $self->blocks_object->_filters_map->{$type} || [];
651 $map_filters = [ $map_filters ] unless ref $map_filters;
652 my @append = ();
653 for (
654 @{$self->blocks_object->_filters},
655 @$map_filters,
656 split(/\s+/, $string),
657 ) {
658 my $filter = $_;
659 last unless length $filter;
660 if ($filter =~ s/^-//) {
661 @filters = grep { $_ ne $filter } @filters;
662 }
663 elsif ($filter =~ s/^\+//) {
664 push @append, $filter;
665 }
666 else {
667 push @filters, $filter;
668 }
669 }
670 return @filters, @append;
671 }
672
673 {
674 %$reserved_section_names = map {
675 ($_, 1);
676 } keys(%Test::Base::Block::), qw( new DESTROY );
677 }
678
679 __DATA__
680
681 =encoding utf8
682
683 #line 1376
+73
-0
inc/Test/Builder/Module.pm less more
0 #line 1
1 package Test::Builder::Module;
2
3 use strict;
4
5 use Test::Builder;
6
7 require Exporter;
8 our @ISA = qw(Exporter);
9
10 our $VERSION = '0.96';
11 $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
12
13
14 #line 74
15
16 sub import {
17 my($class) = shift;
18
19 # Don't run all this when loading ourself.
20 return 1 if $class eq 'Test::Builder::Module';
21
22 my $test = $class->builder;
23
24 my $caller = caller;
25
26 $test->exported_to($caller);
27
28 $class->import_extra( \@_ );
29 my(@imports) = $class->_strip_imports( \@_ );
30
31 $test->plan(@_);
32
33 $class->export_to_level( 1, $class, @imports );
34 }
35
36 sub _strip_imports {
37 my $class = shift;
38 my $list = shift;
39
40 my @imports = ();
41 my @other = ();
42 my $idx = 0;
43 while( $idx <= $#{$list} ) {
44 my $item = $list->[$idx];
45
46 if( defined $item and $item eq 'import' ) {
47 push @imports, @{ $list->[ $idx + 1 ] };
48 $idx++;
49 }
50 else {
51 push @other, $item;
52 }
53
54 $idx++;
55 }
56
57 @$list = @other;
58
59 return @imports;
60 }
61
62 #line 137
63
64 sub import_extra { }
65
66 #line 167
67
68 sub builder {
69 return Test::Builder->new;
70 }
71
72 1;
+1623
-0
inc/Test/Builder.pm less more
0 #line 1
1 package Test::Builder;
2
3 use 5.006;
4 use strict;
5 use warnings;
6
7 our $VERSION = '0.96';
8 $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
9
10 BEGIN {
11 if( $] < 5.008 ) {
12 require Test::Builder::IO::Scalar;
13 }
14 }
15
16
17 # Make Test::Builder thread-safe for ithreads.
18 BEGIN {
19 use Config;
20 # Load threads::shared when threads are turned on.
21 # 5.8.0's threads are so busted we no longer support them.
22 if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
23 require threads::shared;
24
25 # Hack around YET ANOTHER threads::shared bug. It would
26 # occasionally forget the contents of the variable when sharing it.
27 # So we first copy the data, then share, then put our copy back.
28 *share = sub (\[$@%]) {
29 my $type = ref $_[0];
30 my $data;
31
32 if( $type eq 'HASH' ) {
33 %$data = %{ $_[0] };
34 }
35 elsif( $type eq 'ARRAY' ) {
36 @$data = @{ $_[0] };
37 }
38 elsif( $type eq 'SCALAR' ) {
39 $$data = ${ $_[0] };
40 }
41 else {
42 die( "Unknown type: " . $type );
43 }
44
45 $_[0] = &threads::shared::share( $_[0] );
46
47 if( $type eq 'HASH' ) {
48 %{ $_[0] } = %$data;
49 }
50 elsif( $type eq 'ARRAY' ) {
51 @{ $_[0] } = @$data;
52 }
53 elsif( $type eq 'SCALAR' ) {
54 ${ $_[0] } = $$data;
55 }
56 else {
57 die( "Unknown type: " . $type );
58 }
59
60 return $_[0];
61 };
62 }
63 # 5.8.0's threads::shared is busted when threads are off
64 # and earlier Perls just don't have that module at all.
65 else {
66 *share = sub { return $_[0] };
67 *lock = sub { 0 };
68 }
69 }
70
71 #line 117
72
73 our $Test = Test::Builder->new;
74
75 sub new {
76 my($class) = shift;
77 $Test ||= $class->create;
78 return $Test;
79 }
80
81 #line 139
82
83 sub create {
84 my $class = shift;
85
86 my $self = bless {}, $class;
87 $self->reset;
88
89 return $self;
90 }
91
92 #line 168
93
94 sub child {
95 my( $self, $name ) = @_;
96
97 if( $self->{Child_Name} ) {
98 $self->croak("You already have a child named ($self->{Child_Name}) running");
99 }
100
101 my $parent_in_todo = $self->in_todo;
102
103 # Clear $TODO for the child.
104 my $orig_TODO = $self->find_TODO(undef, 1, undef);
105
106 my $child = bless {}, ref $self;
107 $child->reset;
108
109 # Add to our indentation
110 $child->_indent( $self->_indent . ' ' );
111
112 $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
113 if ($parent_in_todo) {
114 $child->{Fail_FH} = $self->{Todo_FH};
115 }
116
117 # This will be reset in finalize. We do this here lest one child failure
118 # cause all children to fail.
119 $child->{Child_Error} = $?;
120 $? = 0;
121 $child->{Parent} = $self;
122 $child->{Parent_TODO} = $orig_TODO;
123 $child->{Name} = $name || "Child of " . $self->name;
124 $self->{Child_Name} = $child->name;
125 return $child;
126 }
127
128
129 #line 211
130
131 sub subtest {
132 my $self = shift;
133 my($name, $subtests) = @_;
134
135 if ('CODE' ne ref $subtests) {
136 $self->croak("subtest()'s second argument must be a code ref");
137 }
138
139 # Turn the child into the parent so anyone who has stored a copy of
140 # the Test::Builder singleton will get the child.
141 my($error, $child, %parent);
142 {
143 # child() calls reset() which sets $Level to 1, so we localize
144 # $Level first to limit the scope of the reset to the subtest.
145 local $Test::Builder::Level = $Test::Builder::Level + 1;
146
147 $child = $self->child($name);
148 %parent = %$self;
149 %$self = %$child;
150
151 my $run_the_subtests = sub {
152 $subtests->();
153 $self->done_testing unless $self->_plan_handled;
154 1;
155 };
156
157 if( !eval { $run_the_subtests->() } ) {
158 $error = $@;
159 }
160 }
161
162 # Restore the parent and the copied child.
163 %$child = %$self;
164 %$self = %parent;
165
166 # Restore the parent's $TODO
167 $self->find_TODO(undef, 1, $child->{Parent_TODO});
168
169 # Die *after* we restore the parent.
170 die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
171
172 local $Test::Builder::Level = $Test::Builder::Level + 1;
173 return $child->finalize;
174 }
175
176 #line 281
177
178 sub _plan_handled {
179 my $self = shift;
180 return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
181 }
182
183
184 #line 306
185
186 sub finalize {
187 my $self = shift;
188
189 return unless $self->parent;
190 if( $self->{Child_Name} ) {
191 $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
192 }
193 $self->_ending;
194
195 # XXX This will only be necessary for TAP envelopes (we think)
196 #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
197
198 local $Test::Builder::Level = $Test::Builder::Level + 1;
199 my $ok = 1;
200 $self->parent->{Child_Name} = undef;
201 if ( $self->{Skip_All} ) {
202 $self->parent->skip($self->{Skip_All});
203 }
204 elsif ( not @{ $self->{Test_Results} } ) {
205 $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
206 }
207 else {
208 $self->parent->ok( $self->is_passing, $self->name );
209 }
210 $? = $self->{Child_Error};
211 delete $self->{Parent};
212
213 return $self->is_passing;
214 }
215
216 sub _indent {
217 my $self = shift;
218
219 if( @_ ) {
220 $self->{Indent} = shift;
221 }
222
223 return $self->{Indent};
224 }
225
226 #line 357
227
228 sub parent { shift->{Parent} }
229
230 #line 369
231
232 sub name { shift->{Name} }
233
234 sub DESTROY {
235 my $self = shift;
236 if ( $self->parent and $$ == $self->{Original_Pid} ) {
237 my $name = $self->name;
238 $self->diag(<<"FAIL");
239 Child ($name) exited without calling finalize()
240 FAIL
241 $self->parent->{In_Destroy} = 1;
242 $self->parent->ok(0, $name);
243 }
244 }
245
246 #line 393
247
248 our $Level;
249
250 sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
251 my($self) = @_;
252
253 # We leave this a global because it has to be localized and localizing
254 # hash keys is just asking for pain. Also, it was documented.
255 $Level = 1;
256
257 $self->{Name} = $0;
258 $self->is_passing(1);
259 $self->{Ending} = 0;
260 $self->{Have_Plan} = 0;
261 $self->{No_Plan} = 0;
262 $self->{Have_Output_Plan} = 0;
263 $self->{Done_Testing} = 0;
264
265 $self->{Original_Pid} = $$;
266 $self->{Child_Name} = undef;
267 $self->{Indent} ||= '';
268
269 share( $self->{Curr_Test} );
270 $self->{Curr_Test} = 0;
271 $self->{Test_Results} = &share( [] );
272
273 $self->{Exported_To} = undef;
274 $self->{Expected_Tests} = 0;
275
276 $self->{Skip_All} = 0;
277
278 $self->{Use_Nums} = 1;
279
280 $self->{No_Header} = 0;
281 $self->{No_Ending} = 0;
282
283 $self->{Todo} = undef;
284 $self->{Todo_Stack} = [];
285 $self->{Start_Todo} = 0;
286 $self->{Opened_Testhandles} = 0;
287
288 $self->_dup_stdhandles;
289
290 return;
291 }
292
293 #line 472
294
295 my %plan_cmds = (
296 no_plan => \&no_plan,
297 skip_all => \&skip_all,
298 tests => \&_plan_tests,
299 );
300
301 sub plan {
302 my( $self, $cmd, $arg ) = @_;
303
304 return unless $cmd;
305
306 local $Level = $Level + 1;
307
308 $self->croak("You tried to plan twice") if $self->{Have_Plan};
309
310 if( my $method = $plan_cmds{$cmd} ) {
311 local $Level = $Level + 1;
312 $self->$method($arg);
313 }
314 else {
315 my @args = grep { defined } ( $cmd, $arg );
316 $self->croak("plan() doesn't understand @args");
317 }
318
319 return 1;
320 }
321
322
323 sub _plan_tests {
324 my($self, $arg) = @_;
325
326 if($arg) {
327 local $Level = $Level + 1;
328 return $self->expected_tests($arg);
329 }
330 elsif( !defined $arg ) {
331 $self->croak("Got an undefined number of tests");
332 }
333 else {
334 $self->croak("You said to run 0 tests");
335 }
336
337 return;
338 }
339
340 #line 527
341
342 sub expected_tests {
343 my $self = shift;
344 my($max) = @_;
345
346 if(@_) {
347 $self->croak("Number of tests must be a positive integer. You gave it '$max'")
348 unless $max =~ /^\+?\d+$/;
349
350 $self->{Expected_Tests} = $max;
351 $self->{Have_Plan} = 1;
352
353 $self->_output_plan($max) unless $self->no_header;
354 }
355 return $self->{Expected_Tests};
356 }
357
358 #line 551
359
360 sub no_plan {
361 my($self, $arg) = @_;
362
363 $self->carp("no_plan takes no arguments") if $arg;
364
365 $self->{No_Plan} = 1;
366 $self->{Have_Plan} = 1;
367
368 return 1;
369 }
370
371 #line 584
372
373 sub _output_plan {
374 my($self, $max, $directive, $reason) = @_;
375
376 $self->carp("The plan was already output") if $self->{Have_Output_Plan};
377
378 my $plan = "1..$max";
379 $plan .= " # $directive" if defined $directive;
380 $plan .= " $reason" if defined $reason;
381
382 $self->_print("$plan\n");
383
384 $self->{Have_Output_Plan} = 1;
385
386 return;
387 }
388
389
390 #line 636
391
392 sub done_testing {
393 my($self, $num_tests) = @_;
394
395 # If done_testing() specified the number of tests, shut off no_plan.
396 if( defined $num_tests ) {
397 $self->{No_Plan} = 0;
398 }
399 else {
400 $num_tests = $self->current_test;
401 }
402
403 if( $self->{Done_Testing} ) {
404 my($file, $line) = @{$self->{Done_Testing}}[1,2];
405 $self->ok(0, "done_testing() was already called at $file line $line");
406 return;
407 }
408
409 $self->{Done_Testing} = [caller];
410
411 if( $self->expected_tests && $num_tests != $self->expected_tests ) {
412 $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
413 "but done_testing() expects $num_tests");
414 }
415 else {
416 $self->{Expected_Tests} = $num_tests;
417 }
418
419 $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
420
421 $self->{Have_Plan} = 1;
422
423 # The wrong number of tests were run
424 $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
425
426 # No tests were run
427 $self->is_passing(0) if $self->{Curr_Test} == 0;
428
429 return 1;
430 }
431
432
433 #line 687
434
435 sub has_plan {
436 my $self = shift;
437
438 return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
439 return('no_plan') if $self->{No_Plan};
440 return(undef);
441 }
442
443 #line 704
444
445 sub skip_all {
446 my( $self, $reason ) = @_;
447
448 $self->{Skip_All} = $self->parent ? $reason : 1;
449
450 $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
451 if ( $self->parent ) {
452 die bless {} => 'Test::Builder::Exception';
453 }
454 exit(0);
455 }
456
457 #line 729
458
459 sub exported_to {
460 my( $self, $pack ) = @_;
461
462 if( defined $pack ) {
463 $self->{Exported_To} = $pack;
464 }
465 return $self->{Exported_To};
466 }
467
468 #line 759
469
470 sub ok {
471 my( $self, $test, $name ) = @_;
472
473 if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
474 $name = 'unnamed test' unless defined $name;
475 $self->is_passing(0);
476 $self->croak("Cannot run test ($name) with active children");
477 }
478 # $test might contain an object which we don't want to accidentally
479 # store, so we turn it into a boolean.
480 $test = $test ? 1 : 0;
481
482 lock $self->{Curr_Test};
483 $self->{Curr_Test}++;
484
485 # In case $name is a string overloaded object, force it to stringify.
486 $self->_unoverload_str( \$name );
487
488 $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
489 You named your test '$name'. You shouldn't use numbers for your test names.
490 Very confusing.
491 ERR
492
493 # Capture the value of $TODO for the rest of this ok() call
494 # so it can more easily be found by other routines.
495 my $todo = $self->todo();
496 my $in_todo = $self->in_todo;
497 local $self->{Todo} = $todo if $in_todo;
498
499 $self->_unoverload_str( \$todo );
500
501 my $out;
502 my $result = &share( {} );
503
504 unless($test) {
505 $out .= "not ";
506 @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
507 }
508 else {
509 @$result{ 'ok', 'actual_ok' } = ( 1, $test );
510 }
511
512 $out .= "ok";
513 $out .= " $self->{Curr_Test}" if $self->use_numbers;
514
515 if( defined $name ) {
516 $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
517 $out .= " - $name";
518 $result->{name} = $name;
519 }
520 else {
521 $result->{name} = '';
522 }
523
524 if( $self->in_todo ) {
525 $out .= " # TODO $todo";
526 $result->{reason} = $todo;
527 $result->{type} = 'todo';
528 }
529 else {
530 $result->{reason} = '';
531 $result->{type} = '';
532 }
533
534 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
535 $out .= "\n";
536
537 $self->_print($out);
538
539 unless($test) {
540 my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
541 $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
542
543 my( undef, $file, $line ) = $self->caller;
544 if( defined $name ) {
545 $self->diag(qq[ $msg test '$name'\n]);
546 $self->diag(qq[ at $file line $line.\n]);
547 }
548 else {
549 $self->diag(qq[ $msg test at $file line $line.\n]);
550 }
551 }
552
553 $self->is_passing(0) unless $test || $self->in_todo;
554
555 # Check that we haven't violated the plan
556 $self->_check_is_passing_plan();
557
558 return $test ? 1 : 0;
559 }
560
561
562 # Check that we haven't yet violated the plan and set
563 # is_passing() accordingly
564 sub _check_is_passing_plan {
565 my $self = shift;
566
567 my $plan = $self->has_plan;
568 return unless defined $plan; # no plan yet defined
569 return unless $plan !~ /\D/; # no numeric plan
570 $self->is_passing(0) if $plan < $self->{Curr_Test};
571 }
572
573
574 sub _unoverload {
575 my $self = shift;
576 my $type = shift;
577
578 $self->_try(sub { require overload; }, die_on_fail => 1);
579
580 foreach my $thing (@_) {
581 if( $self->_is_object($$thing) ) {
582 if( my $string_meth = overload::Method( $$thing, $type ) ) {
583 $$thing = $$thing->$string_meth();
584 }
585 }
586 }
587
588 return;
589 }
590
591 sub _is_object {
592 my( $self, $thing ) = @_;
593
594 return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
595 }
596
597 sub _unoverload_str {
598 my $self = shift;
599
600 return $self->_unoverload( q[""], @_ );
601 }
602
603 sub _unoverload_num {
604 my $self = shift;
605
606 $self->_unoverload( '0+', @_ );
607
608 for my $val (@_) {
609 next unless $self->_is_dualvar($$val);
610 $$val = $$val + 0;
611 }
612
613 return;
614 }
615
616 # This is a hack to detect a dualvar such as $!
617 sub _is_dualvar {
618 my( $self, $val ) = @_;
619
620 # Objects are not dualvars.
621 return 0 if ref $val;
622
623 no warnings 'numeric';
624 my $numval = $val + 0;
625 return $numval != 0 and $numval ne $val ? 1 : 0;
626 }
627
628 #line 933
629
630 sub is_eq {
631 my( $self, $got, $expect, $name ) = @_;
632 local $Level = $Level + 1;
633
634 if( !defined $got || !defined $expect ) {
635 # undef only matches undef and nothing else
636 my $test = !defined $got && !defined $expect;
637
638 $self->ok( $test, $name );
639 $self->_is_diag( $got, 'eq', $expect ) unless $test;
640 return $test;
641 }
642
643 return $self->cmp_ok( $got, 'eq', $expect, $name );
644 }
645
646 sub is_num {
647 my( $self, $got, $expect, $name ) = @_;
648 local $Level = $Level + 1;
649
650 if( !defined $got || !defined $expect ) {
651 # undef only matches undef and nothing else
652 my $test = !defined $got && !defined $expect;
653
654 $self->ok( $test, $name );
655 $self->_is_diag( $got, '==', $expect ) unless $test;
656 return $test;
657 }
658
659 return $self->cmp_ok( $got, '==', $expect, $name );
660 }
661
662 sub _diag_fmt {
663 my( $self, $type, $val ) = @_;
664
665 if( defined $$val ) {
666 if( $type eq 'eq' or $type eq 'ne' ) {
667 # quote and force string context
668 $$val = "'$$val'";
669 }
670 else {
671 # force numeric context
672 $self->_unoverload_num($val);
673 }
674 }
675 else {
676 $$val = 'undef';
677 }
678
679 return;
680 }
681
682 sub _is_diag {
683 my( $self, $got, $type, $expect ) = @_;
684
685 $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
686
687 local $Level = $Level + 1;
688 return $self->diag(<<"DIAGNOSTIC");
689 got: $got
690 expected: $expect
691 DIAGNOSTIC
692
693 }
694
695 sub _isnt_diag {
696 my( $self, $got, $type ) = @_;
697
698 $self->_diag_fmt( $type, \$got );
699
700 local $Level = $Level + 1;
701 return $self->diag(<<"DIAGNOSTIC");
702 got: $got
703 expected: anything else
704 DIAGNOSTIC
705 }
706
707 #line 1026
708
709 sub isnt_eq {
710 my( $self, $got, $dont_expect, $name ) = @_;
711 local $Level = $Level + 1;
712
713 if( !defined $got || !defined $dont_expect ) {
714 # undef only matches undef and nothing else
715 my $test = defined $got || defined $dont_expect;
716
717 $self->ok( $test, $name );
718 $self->_isnt_diag( $got, 'ne' ) unless $test;
719 return $test;
720 }
721
722 return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
723 }
724
725 sub isnt_num {
726 my( $self, $got, $dont_expect, $name ) = @_;
727 local $Level = $Level + 1;
728
729 if( !defined $got || !defined $dont_expect ) {
730 # undef only matches undef and nothing else
731 my $test = defined $got || defined $dont_expect;
732
733 $self->ok( $test, $name );
734 $self->_isnt_diag( $got, '!=' ) unless $test;
735 return $test;
736 }
737
738 return $self->cmp_ok( $got, '!=', $dont_expect, $name );
739 }
740
741 #line 1075
742
743 sub like {
744 my( $self, $this, $regex, $name ) = @_;
745
746 local $Level = $Level + 1;
747 return $self->_regex_ok( $this, $regex, '=~', $name );
748 }
749
750 sub unlike {
751 my( $self, $this, $regex, $name ) = @_;
752
753 local $Level = $Level + 1;
754 return $self->_regex_ok( $this, $regex, '!~', $name );
755 }
756
757 #line 1099
758
759 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
760
761 sub cmp_ok {
762 my( $self, $got, $type, $expect, $name ) = @_;
763
764 my $test;
765 my $error;
766 {
767 ## no critic (BuiltinFunctions::ProhibitStringyEval)
768
769 local( $@, $!, $SIG{__DIE__} ); # isolate eval
770
771 my($pack, $file, $line) = $self->caller();
772
773 # This is so that warnings come out at the caller's level
774 $test = eval qq[
775 #line $line "(eval in cmp_ok) $file"
776 \$got $type \$expect;
777 ];
778 $error = $@;
779 }
780 local $Level = $Level + 1;
781 my $ok = $self->ok( $test, $name );
782
783 # Treat overloaded objects as numbers if we're asked to do a
784 # numeric comparison.
785 my $unoverload
786 = $numeric_cmps{$type}
787 ? '_unoverload_num'
788 : '_unoverload_str';
789
790 $self->diag(<<"END") if $error;
791 An error occurred while using $type:
792 ------------------------------------
793 $error
794 ------------------------------------
795 END
796
797 unless($ok) {
798 $self->$unoverload( \$got, \$expect );
799
800 if( $type =~ /^(eq|==)$/ ) {
801 $self->_is_diag( $got, $type, $expect );
802 }
803 elsif( $type =~ /^(ne|!=)$/ ) {
804 $self->_isnt_diag( $got, $type );
805 }
806 else {
807 $self->_cmp_diag( $got, $type, $expect );
808 }
809 }
810 return $ok;
811 }
812
813 sub _cmp_diag {
814 my( $self, $got, $type, $expect ) = @_;
815
816 $got = defined $got ? "'$got'" : 'undef';
817 $expect = defined $expect ? "'$expect'" : 'undef';
818
819 local $Level = $Level + 1;
820 return $self->diag(<<"DIAGNOSTIC");
821 $got
822 $type
823 $expect
824 DIAGNOSTIC
825 }
826
827 sub _caller_context {
828 my $self = shift;
829
830 my( $pack, $file, $line ) = $self->caller(1);
831
832 my $code = '';
833 $code .= "#line $line $file\n" if defined $file and defined $line;
834
835 return $code;
836 }
837
838 #line 1199
839
840 sub BAIL_OUT {
841 my( $self, $reason ) = @_;
842
843 $self->{Bailed_Out} = 1;
844 $self->_print("Bail out! $reason");
845 exit 255;
846 }
847
848 #line 1212
849
850 {
851 no warnings 'once';
852 *BAILOUT = \&BAIL_OUT;
853 }
854
855 #line 1226
856
857 sub skip {
858 my( $self, $why ) = @_;
859 $why ||= '';
860 $self->_unoverload_str( \$why );
861
862 lock( $self->{Curr_Test} );
863 $self->{Curr_Test}++;
864
865 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
866 {
867 'ok' => 1,
868 actual_ok => 1,
869 name => '',
870 type => 'skip',
871 reason => $why,
872 }
873 );
874
875 my $out = "ok";
876 $out .= " $self->{Curr_Test}" if $self->use_numbers;
877 $out .= " # skip";
878 $out .= " $why" if length $why;
879 $out .= "\n";
880
881 $self->_print($out);
882
883 return 1;
884 }
885
886 #line 1267
887
888 sub todo_skip {
889 my( $self, $why ) = @_;
890 $why ||= '';
891
892 lock( $self->{Curr_Test} );
893 $self->{Curr_Test}++;
894
895 $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
896 {
897 'ok' => 1,
898 actual_ok => 0,
899 name => '',
900 type => 'todo_skip',
901 reason => $why,
902 }
903 );
904
905 my $out = "not ok";
906 $out .= " $self->{Curr_Test}" if $self->use_numbers;
907 $out .= " # TODO & SKIP $why\n";
908
909 $self->_print($out);
910
911 return 1;
912 }
913
914 #line 1347
915
916 sub maybe_regex {
917 my( $self, $regex ) = @_;
918 my $usable_regex = undef;
919
920 return $usable_regex unless defined $regex;
921
922 my( $re, $opts );
923
924 # Check for qr/foo/
925 if( _is_qr($regex) ) {
926 $usable_regex = $regex;
927 }
928 # Check for '/foo/' or 'm,foo,'
929 elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
930 ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
931 )
932 {
933 $usable_regex = length $opts ? "(?$opts)$re" : $re;
934 }
935
936 return $usable_regex;
937 }
938
939 sub _is_qr {
940 my $regex = shift;
941
942 # is_regexp() checks for regexes in a robust manner, say if they're
943 # blessed.
944 return re::is_regexp($regex) if defined &re::is_regexp;
945 return ref $regex eq 'Regexp';
946 }
947
948 sub _regex_ok {
949 my( $self, $this, $regex, $cmp, $name ) = @_;
950
951 my $ok = 0;
952 my $usable_regex = $self->maybe_regex($regex);
953 unless( defined $usable_regex ) {
954 local $Level = $Level + 1;
955 $ok = $self->ok( 0, $name );
956 $self->diag(" '$regex' doesn't look much like a regex to me.");
957 return $ok;
958 }
959
960 {
961 ## no critic (BuiltinFunctions::ProhibitStringyEval)
962
963 my $test;
964 my $context = $self->_caller_context;
965
966 local( $@, $!, $SIG{__DIE__} ); # isolate eval
967
968 $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
969
970 $test = !$test if $cmp eq '!~';
971
972 local $Level = $Level + 1;
973 $ok = $self->ok( $test, $name );
974 }
975
976 unless($ok) {
977 $this = defined $this ? "'$this'" : 'undef';
978 my $match = $cmp eq '=~' ? "doesn't match" : "matches";
979
980 local $Level = $Level + 1;
981 $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
982 %s
983 %13s '%s'
984 DIAGNOSTIC
985
986 }
987
988 return $ok;
989 }
990
991 # I'm not ready to publish this. It doesn't deal with array return
992 # values from the code or context.
993
994 #line 1443
995
996 sub _try {
997 my( $self, $code, %opts ) = @_;
998
999 my $error;
1000 my $return;
1001 {
1002 local $!; # eval can mess up $!
1003 local $@; # don't set $@ in the test
1004 local $SIG{__DIE__}; # don't trip an outside DIE handler.
1005 $return = eval { $code->() };
1006 $error = $@;
1007 }
1008
1009 die $error if $error and $opts{die_on_fail};
1010
1011 return wantarray ? ( $return, $error ) : $return;
1012 }
1013
1014 #line 1472
1015
1016 sub is_fh {
1017 my $self = shift;
1018 my $maybe_fh = shift;
1019 return 0 unless defined $maybe_fh;
1020
1021 return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
1022 return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1023
1024 return eval { $maybe_fh->isa("IO::Handle") } ||
1025 eval { tied($maybe_fh)->can('TIEHANDLE') };
1026 }
1027
1028 #line 1515
1029
1030 sub level {
1031 my( $self, $level ) = @_;
1032
1033 if( defined $level ) {
1034 $Level = $level;
1035 }
1036 return $Level;
1037 }
1038
1039 #line 1547
1040
1041 sub use_numbers {
1042 my( $self, $use_nums ) = @_;
1043
1044 if( defined $use_nums ) {
1045 $self->{Use_Nums} = $use_nums;
1046 }
1047 return $self->{Use_Nums};
1048 }
1049
1050 #line 1580
1051
1052 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1053 my $method = lc $attribute;
1054
1055 my $code = sub {
1056 my( $self, $no ) = @_;
1057
1058 if( defined $no ) {
1059 $self->{$attribute} = $no;
1060 }
1061 return $self->{$attribute};
1062 };
1063
1064 no strict 'refs'; ## no critic
1065 *{ __PACKAGE__ . '::' . $method } = $code;
1066 }
1067
1068 #line 1633
1069
1070 sub diag {
1071 my $self = shift;
1072
1073 $self->_print_comment( $self->_diag_fh, @_ );
1074 }
1075
1076 #line 1648
1077
1078 sub note {
1079 my $self = shift;
1080
1081 $self->_print_comment( $self->output, @_ );
1082 }
1083
1084 sub _diag_fh {
1085 my $self = shift;
1086
1087 local $Level = $Level + 1;
1088 return $self->in_todo ? $self->todo_output : $self->failure_output;
1089 }
1090
1091 sub _print_comment {
1092 my( $self, $fh, @msgs ) = @_;
1093
1094 return if $self->no_diag;
1095 return unless @msgs;
1096
1097 # Prevent printing headers when compiling (i.e. -c)
1098 return if $^C;
1099
1100 # Smash args together like print does.
1101 # Convert undef to 'undef' so its readable.
1102 my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1103
1104 # Escape the beginning, _print will take care of the rest.
1105 $msg =~ s/^/# /;
1106
1107 local $Level = $Level + 1;
1108 $self->_print_to_fh( $fh, $msg );
1109
1110 return 0;
1111 }
1112
1113 #line 1698
1114
1115 sub explain {
1116 my $self = shift;
1117
1118 return map {
1119 ref $_
1120 ? do {
1121 $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1122
1123 my $dumper = Data::Dumper->new( [$_] );
1124 $dumper->Indent(1)->Terse(1);
1125 $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1126 $dumper->Dump;
1127 }
1128 : $_
1129 } @_;
1130 }
1131
1132 #line 1727
1133
1134 sub _print {
1135 my $self = shift;
1136 return $self->_print_to_fh( $self->output, @_ );
1137 }
1138
1139 sub _print_to_fh {
1140 my( $self, $fh, @msgs ) = @_;
1141
1142 # Prevent printing headers when only compiling. Mostly for when
1143 # tests are deparsed with B::Deparse
1144 return if $^C;
1145
1146 my $msg = join '', @msgs;
1147 my $indent = $self->_indent;
1148
1149 local( $\, $", $, ) = ( undef, ' ', '' );
1150
1151 # Escape each line after the first with a # so we don't
1152 # confuse Test::Harness.
1153 $msg =~ s{\n(?!\z)}{\n$indent# }sg;
1154
1155 # Stick a newline on the end if it needs it.
1156 $msg .= "\n" unless $msg =~ /\n\z/;
1157
1158 return print $fh $indent, $msg;
1159 }
1160
1161 #line 1787
1162
1163 sub output {
1164 my( $self, $fh ) = @_;
1165
1166 if( defined $fh ) {
1167 $self->{Out_FH} = $self->_new_fh($fh);
1168 }
1169 return $self->{Out_FH};
1170 }
1171
1172 sub failure_output {
1173 my( $self, $fh ) = @_;
1174
1175 if( defined $fh ) {
1176 $self->{Fail_FH} = $self->_new_fh($fh);
1177 }
1178 return $self->{Fail_FH};
1179 }
1180
1181 sub todo_output {
1182 my( $self, $fh ) = @_;
1183
1184 if( defined $fh ) {
1185 $self->{Todo_FH} = $self->_new_fh($fh);
1186 }
1187 return $self->{Todo_FH};
1188 }
1189
1190 sub _new_fh {
1191 my $self = shift;
1192 my($file_or_fh) = shift;
1193
1194 my $fh;
1195 if( $self->is_fh($file_or_fh) ) {
1196 $fh = $file_or_fh;
1197 }
1198 elsif( ref $file_or_fh eq 'SCALAR' ) {
1199 # Scalar refs as filehandles was added in 5.8.
1200 if( $] >= 5.008 ) {
1201 open $fh, ">>", $file_or_fh
1202 or $self->croak("Can't open scalar ref $file_or_fh: $!");
1203 }
1204 # Emulate scalar ref filehandles with a tie.
1205 else {
1206 $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1207 or $self->croak("Can't tie scalar ref $file_or_fh");
1208 }
1209 }
1210 else {
1211 open $fh, ">", $file_or_fh
1212 or $self->croak("Can't open test output log $file_or_fh: $!");
1213 _autoflush($fh);
1214 }
1215
1216 return $fh;
1217 }
1218
1219 sub _autoflush {
1220 my($fh) = shift;
1221 my $old_fh = select $fh;
1222 $| = 1;
1223 select $old_fh;
1224
1225 return;
1226 }
1227
1228 my( $Testout, $Testerr );
1229
1230 sub _dup_stdhandles {
1231 my $self = shift;
1232
1233 $self->_open_testhandles;
1234
1235 # Set everything to unbuffered else plain prints to STDOUT will
1236 # come out in the wrong order from our own prints.
1237 _autoflush($Testout);
1238 _autoflush( \*STDOUT );
1239 _autoflush($Testerr);
1240 _autoflush( \*STDERR );
1241
1242 $self->reset_outputs;
1243
1244 return;
1245 }
1246
1247 sub _open_testhandles {
1248 my $self = shift;
1249
1250 return if $self->{Opened_Testhandles};
1251
1252 # We dup STDOUT and STDERR so people can change them in their
1253 # test suites while still getting normal test output.
1254 open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
1255 open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
1256
1257 # $self->_copy_io_layers( \*STDOUT, $Testout );
1258 # $self->_copy_io_layers( \*STDERR, $Testerr );
1259
1260 $self->{Opened_Testhandles} = 1;
1261
1262 return;
1263 }
1264
1265 sub _copy_io_layers {
1266 my( $self, $src, $dst ) = @_;
1267
1268 $self->_try(
1269 sub {
1270 require PerlIO;
1271 my @src_layers = PerlIO::get_layers($src);
1272
1273 binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
1274 }
1275 );
1276
1277 return;
1278 }
1279
1280 #line 1912
1281
1282 sub reset_outputs {
1283 my $self = shift;
1284
1285 $self->output ($Testout);
1286 $self->failure_output($Testerr);
1287 $self->todo_output ($Testout);
1288
1289 return;
1290 }
1291
1292 #line 1938
1293
1294 sub _message_at_caller {
1295 my $self = shift;
1296
1297 local $Level = $Level + 1;
1298 my( $pack, $file, $line ) = $self->caller;
1299 return join( "", @_ ) . " at $file line $line.\n";
1300 }
1301
1302 sub carp {
1303 my $self = shift;
1304 return warn $self->_message_at_caller(@_);
1305 }
1306
1307 sub croak {
1308 my $self = shift;
1309 return die $self->_message_at_caller(@_);
1310 }
1311
1312
1313 #line 1978
1314
1315 sub current_test {
1316 my( $self, $num ) = @_;
1317
1318 lock( $self->{Curr_Test} );
1319 if( defined $num ) {
1320 $self->{Curr_Test} = $num;
1321
1322 # If the test counter is being pushed forward fill in the details.
1323 my $test_results = $self->{Test_Results};
1324 if( $num > @$test_results ) {
1325 my $start = @$test_results ? @$test_results : 0;
1326 for( $start .. $num - 1 ) {
1327 $test_results->[$_] = &share(
1328 {
1329 'ok' => 1,
1330 actual_ok => undef,
1331 reason => 'incrementing test number',
1332 type => 'unknown',
1333 name => undef
1334 }
1335 );
1336 }
1337 }
1338 # If backward, wipe history. Its their funeral.
1339 elsif( $num < @$test_results ) {
1340 $#{$test_results} = $num - 1;
1341 }
1342 }
1343 return $self->{Curr_Test};
1344 }
1345
1346 #line 2026
1347
1348 sub is_passing {
1349 my $self = shift;
1350
1351 if( @_ ) {
1352 $self->{Is_Passing} = shift;
1353 }
1354
1355 return $self->{Is_Passing};
1356 }
1357
1358
1359 #line 2048
1360
1361 sub summary {
1362 my($self) = shift;
1363
1364 return map { $_->{'ok'} } @{ $self->{Test_Results} };
1365 }
1366
1367 #line 2103
1368
1369 sub details {
1370 my $self = shift;
1371 return @{ $self->{Test_Results} };
1372 }
1373
1374 #line 2132
1375
1376 sub todo {
1377 my( $self, $pack ) = @_;
1378
1379 return $self->{Todo} if defined $self->{Todo};
1380
1381 local $Level = $Level + 1;
1382 my $todo = $self->find_TODO($pack);
1383 return $todo if defined $todo;
1384
1385 return '';
1386 }
1387
1388 #line 2159
1389
1390 sub find_TODO {
1391 my( $self, $pack, $set, $new_value ) = @_;
1392
1393 $pack = $pack || $self->caller(1) || $self->exported_to;
1394 return unless $pack;
1395
1396 no strict 'refs'; ## no critic
1397 my $old_value = ${ $pack . '::TODO' };
1398 $set and ${ $pack . '::TODO' } = $new_value;
1399 return $old_value;
1400 }
1401
1402 #line 2179
1403
1404 sub in_todo {
1405 my $self = shift;
1406
1407 local $Level = $Level + 1;
1408 return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
1409 }
1410
1411 #line 2229
1412
1413 sub todo_start {
1414 my $self = shift;
1415 my $message = @_ ? shift : '';
1416
1417 $self->{Start_Todo}++;
1418 if( $self->in_todo ) {
1419 push @{ $self->{Todo_Stack} } => $self->todo;
1420 }
1421 $self->{Todo} = $message;
1422
1423 return;
1424 }
1425
1426 #line 2251
1427
1428 sub todo_end {
1429 my $self = shift;
1430
1431 if( !$self->{Start_Todo} ) {
1432 $self->croak('todo_end() called without todo_start()');
1433 }
1434
1435 $self->{Start_Todo}--;
1436
1437 if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
1438 $self->{Todo} = pop @{ $self->{Todo_Stack} };
1439 }
1440 else {
1441 delete $self->{Todo};
1442 }
1443
1444 return;
1445 }
1446
1447 #line 2284
1448
1449 sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
1450 my( $self, $height ) = @_;
1451 $height ||= 0;
1452
1453 my $level = $self->level + $height + 1;
1454 my @caller;
1455 do {
1456 @caller = CORE::caller( $level );
1457 $level--;
1458 } until @caller;
1459 return wantarray ? @caller : $caller[0];
1460 }
1461
1462 #line 2301
1463
1464 #line 2315
1465
1466 #'#
1467 sub _sanity_check {
1468 my $self = shift;
1469
1470 $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
1471 $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
1472 'Somehow you got a different number of results than tests ran!' );
1473
1474 return;
1475 }
1476
1477 #line 2336
1478
1479 sub _whoa {
1480 my( $self, $check, $desc ) = @_;
1481 if($check) {
1482 local $Level = $Level + 1;
1483 $self->croak(<<"WHOA");
1484 WHOA! $desc
1485 This should never happen! Please contact the author immediately!
1486 WHOA
1487 }
1488
1489 return;
1490 }
1491
1492 #line 2360
1493
1494 sub _my_exit {
1495 $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
1496
1497 return 1;
1498 }
1499
1500 #line 2372
1501
1502 sub _ending {
1503 my $self = shift;
1504 return if $self->no_ending;
1505 return if $self->{Ending}++;
1506
1507 my $real_exit_code = $?;
1508
1509 # Don't bother with an ending if this is a forked copy. Only the parent
1510 # should do the ending.
1511 if( $self->{Original_Pid} != $$ ) {
1512 return;
1513 }
1514
1515 # Ran tests but never declared a plan or hit done_testing
1516 if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
1517 $self->is_passing(0);
1518 $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
1519 }
1520
1521 # Exit if plan() was never called. This is so "require Test::Simple"
1522 # doesn't puke.
1523 if( !$self->{Have_Plan} ) {
1524 return;
1525 }
1526
1527 # Don't do an ending if we bailed out.
1528 if( $self->{Bailed_Out} ) {
1529 $self->is_passing(0);
1530 return;
1531 }
1532 # Figure out if we passed or failed and print helpful messages.
1533 my $test_results = $self->{Test_Results};
1534 if(@$test_results) {
1535 # The plan? We have no plan.
1536 if( $self->{No_Plan} ) {
1537 $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
1538 $self->{Expected_Tests} = $self->{Curr_Test};
1539 }
1540
1541 # Auto-extended arrays and elements which aren't explicitly
1542 # filled in with a shared reference will puke under 5.8.0
1543 # ithreads. So we have to fill them in by hand. :(
1544 my $empty_result = &share( {} );
1545 for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
1546 $test_results->[$idx] = $empty_result
1547 unless defined $test_results->[$idx];
1548 }
1549
1550 my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
1551
1552 my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1553
1554 if( $num_extra != 0 ) {
1555 my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1556 $self->diag(<<"FAIL");
1557 Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
1558 FAIL
1559 $self->is_passing(0);
1560 }
1561
1562 if($num_failed) {
1563 my $num_tests = $self->{Curr_Test};
1564 my $s = $num_failed == 1 ? '' : 's';
1565
1566 my $qualifier = $num_extra == 0 ? '' : ' run';
1567
1568 $self->diag(<<"FAIL");
1569 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1570 FAIL
1571 $self->is_passing(0);
1572 }
1573
1574 if($real_exit_code) {
1575 $self->diag(<<"FAIL");
1576 Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
1577 FAIL
1578 $self->is_passing(0);
1579 _my_exit($real_exit_code) && return;
1580 }
1581
1582 my $exit_code;
1583 if($num_failed) {
1584 $exit_code = $num_failed <= 254 ? $num_failed : 254;
1585 }
1586 elsif( $num_extra != 0 ) {
1587 $exit_code = 255;
1588 }
1589 else {
1590 $exit_code = 0;
1591 }
1592
1593 _my_exit($exit_code) && return;
1594 }
1595 elsif( $self->{Skip_All} ) {
1596 _my_exit(0) && return;
1597 }
1598 elsif($real_exit_code) {
1599 $self->diag(<<"FAIL");
1600 Looks like your test exited with $real_exit_code before it could output anything.
1601 FAIL
1602 $self->is_passing(0);
1603 _my_exit($real_exit_code) && return;
1604 }
1605 else {
1606 $self->diag("No tests run!\n");
1607 $self->is_passing(0);
1608 _my_exit(255) && return;
1609 }
1610
1611 $self->is_passing(0);
1612 $self->_whoa( 1, "We fell off the end of _ending()" );
1613 }
1614
1615 END {
1616 $Test->_ending if defined $Test;
1617 }
1618
1619 #line 2560
1620
1621 1;
1622
+762
-0
inc/Test/More.pm less more
0 #line 1
1 package Test::More;
2
3 use 5.006;
4 use strict;
5 use warnings;
6
7 #---- perlcritic exemptions. ----#
8
9 # We use a lot of subroutine prototypes
10 ## no critic (Subroutines::ProhibitSubroutinePrototypes)
11
12 # Can't use Carp because it might cause use_ok() to accidentally succeed
13 # even though the module being used forgot to use Carp. Yes, this
14 # actually happened.
15 sub _carp {
16 my( $file, $line ) = ( caller(1) )[ 1, 2 ];
17 return warn @_, " at $file line $line\n";
18 }
19
20 our $VERSION = '0.96';
21 $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
22
23 use Test::Builder::Module;
24 our @ISA = qw(Test::Builder::Module);
25 our @EXPORT = qw(ok use_ok require_ok
26 is isnt like unlike is_deeply
27 cmp_ok
28 skip todo todo_skip
29 pass fail
30 eq_array eq_hash eq_set
31 $TODO
32 plan
33 done_testing
34 can_ok isa_ok new_ok
35 diag note explain
36 subtest
37 BAIL_OUT
38 );
39
40 #line 164
41
42 sub plan {
43 my $tb = Test::More->builder;
44
45 return $tb->plan(@_);
46 }
47
48 # This implements "use Test::More 'no_diag'" but the behavior is
49 # deprecated.
50 sub import_extra {
51 my $class = shift;
52 my $list = shift;
53
54 my @other = ();
55 my $idx = 0;
56 while( $idx <= $#{$list} ) {
57 my $item = $list->[$idx];
58
59 if( defined $item and $item eq 'no_diag' ) {
60 $class->builder->no_diag(1);
61 }
62 else {
63 push @other, $item;
64 }
65
66 $idx++;
67 }
68
69 @$list = @other;
70
71 return;
72 }
73
74 #line 217
75
76 sub done_testing {
77 my $tb = Test::More->builder;
78 $tb->done_testing(@_);
79 }
80
81 #line 289
82
83 sub ok ($;$) {
84 my( $test, $name ) = @_;
85 my $tb = Test::More->builder;
86
87 return $tb->ok( $test, $name );
88 }
89
90 #line 367
91
92 sub is ($$;$) {
93 my $tb = Test::More->builder;
94
95 return $tb->is_eq(@_);
96 }
97
98 sub isnt ($$;$) {
99 my $tb = Test::More->builder;
100
101 return $tb->isnt_eq(@_);
102 }
103
104 *isn't = \&isnt;
105
106 #line 411
107
108 sub like ($$;$) {
109 my $tb = Test::More->builder;
110
111 return $tb->like(@_);
112 }
113
114 #line 426
115
116 sub unlike ($$;$) {
117 my $tb = Test::More->builder;
118
119 return $tb->unlike(@_);
120 }
121
122 #line 471
123
124 sub cmp_ok($$$;$) {
125 my $tb = Test::More->builder;
126
127 return $tb->cmp_ok(@_);
128 }
129
130 #line 506
131
132 sub can_ok ($@) {
133 my( $proto, @methods ) = @_;
134 my $class = ref $proto || $proto;
135 my $tb = Test::More->builder;
136
137 unless($class) {
138 my $ok = $tb->ok( 0, "->can(...)" );
139 $tb->diag(' can_ok() called with empty class or reference');
140 return $ok;
141 }
142
143 unless(@methods) {
144 my $ok = $tb->ok( 0, "$class->can(...)" );
145 $tb->diag(' can_ok() called with no methods');
146 return $ok;
147 }
148
149 my @nok = ();
150 foreach my $method (@methods) {
151 $tb->_try( sub { $proto->can($method) } ) or push @nok, $method;
152 }
153
154 my $name = (@methods == 1) ? "$class->can('$methods[0]')" :
155 "$class->can(...)" ;
156
157 my $ok = $tb->ok( !@nok, $name );
158
159 $tb->diag( map " $class->can('$_') failed\n", @nok );
160
161 return $ok;
162 }
163
164 #line 572
165
166 sub isa_ok ($$;$) {
167 my( $object, $class, $obj_name ) = @_;
168 my $tb = Test::More->builder;
169
170 my $diag;
171
172 if( !defined $object ) {
173 $obj_name = 'The thing' unless defined $obj_name;
174 $diag = "$obj_name isn't defined";
175 }
176 else {
177 my $whatami = ref $object ? 'object' : 'class';
178 # We can't use UNIVERSAL::isa because we want to honor isa() overrides
179 my( $rslt, $error ) = $tb->_try( sub { $object->isa($class) } );
180 if($error) {
181 if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
182 # Its an unblessed reference
183 $obj_name = 'The reference' unless defined $obj_name;
184 if( !UNIVERSAL::isa( $object, $class ) ) {
185 my $ref = ref $object;
186 $diag = "$obj_name isn't a '$class' it's a '$ref'";
187 }
188 }
189 elsif( $error =~ /Can't call method "isa" without a package/ ) {
190 # It's something that can't even be a class
191 $obj_name = 'The thing' unless defined $obj_name;
192 $diag = "$obj_name isn't a class or reference";
193 }
194 else {
195 die <<WHOA;
196 WHOA! I tried to call ->isa on your $whatami and got some weird error.
197 Here's the error.
198 $error
199 WHOA
200 }
201 }
202 else {
203 $obj_name = "The $whatami" unless defined $obj_name;
204 if( !$rslt ) {
205 my $ref = ref $object;
206 $diag = "$obj_name isn't a '$class' it's a '$ref'";
207 }
208 }
209 }
210
211 my $name = "$obj_name isa $class";
212 my $ok;
213 if($diag) {
214 $ok = $tb->ok( 0, $name );
215 $tb->diag(" $diag\n");
216 }
217 else {
218 $ok = $tb->ok( 1, $name );
219 }
220
221 return $ok;
222 }
223
224 #line 651
225
226 sub new_ok {
227 my $tb = Test::More->builder;
228 $tb->croak("new_ok() must be given at least a class") unless @_;
229
230 my( $class, $args, $object_name ) = @_;
231
232 $args ||= [];
233 $object_name = "The object" unless defined $object_name;
234
235 my $obj;
236 my( $success, $error ) = $tb->_try( sub { $obj = $class->new(@$args); 1 } );
237 if($success) {
238 local $Test::Builder::Level = $Test::Builder::Level + 1;
239 isa_ok $obj, $class, $object_name;
240 }
241 else {
242 $tb->ok( 0, "new() died" );
243 $tb->diag(" Error was: $error");
244 }
245
246 return $obj;
247 }
248
249 #line 736
250
251 sub subtest($&) {
252 my ($name, $subtests) = @_;
253
254 my $tb = Test::More->builder;
255 return $tb->subtest(@_);
256 }
257
258 #line 760
259
260 sub pass (;$) {
261 my $tb = Test::More->builder;
262
263 return $tb->ok( 1, @_ );
264 }
265
266 sub fail (;$) {
267 my $tb = Test::More->builder;
268
269 return $tb->ok( 0, @_ );
270 }
271
272 #line 823
273
274 sub use_ok ($;@) {
275 my( $module, @imports ) = @_;
276 @imports = () unless @imports;
277 my $tb = Test::More->builder;
278
279 my( $pack, $filename, $line ) = caller;
280
281 my $code;
282 if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
283 # probably a version check. Perl needs to see the bare number
284 # for it to work with non-Exporter based modules.
285 $code = <<USE;
286 package $pack;
287 use $module $imports[0];
288 1;
289 USE
290 }
291 else {
292 $code = <<USE;
293 package $pack;
294 use $module \@{\$args[0]};
295 1;
296 USE
297 }
298
299 my( $eval_result, $eval_error ) = _eval( $code, \@imports );
300 my $ok = $tb->ok( $eval_result, "use $module;" );
301
302 unless($ok) {
303 chomp $eval_error;
304 $@ =~ s{^BEGIN failed--compilation aborted at .*$}
305 {BEGIN failed--compilation aborted at $filename line $line.}m;
306 $tb->diag(<<DIAGNOSTIC);
307 Tried to use '$module'.
308 Error: $eval_error
309 DIAGNOSTIC
310
311 }
312
313 return $ok;
314 }
315
316 sub _eval {
317 my( $code, @args ) = @_;
318
319 # Work around oddities surrounding resetting of $@ by immediately
320 # storing it.
321 my( $sigdie, $eval_result, $eval_error );
322 {
323 local( $@, $!, $SIG{__DIE__} ); # isolate eval
324 $eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
325 $eval_error = $@;
326 $sigdie = $SIG{__DIE__} || undef;
327 }
328 # make sure that $code got a chance to set $SIG{__DIE__}
329 $SIG{__DIE__} = $sigdie if defined $sigdie;
330
331 return( $eval_result, $eval_error );
332 }
333
334 #line 892
335
336 sub require_ok ($) {
337 my($module) = shift;
338 my $tb = Test::More->builder;
339
340 my $pack = caller;
341
342 # Try to determine if we've been given a module name or file.
343 # Module names must be barewords, files not.
344 $module = qq['$module'] unless _is_module_name($module);
345
346 my $code = <<REQUIRE;
347 package $pack;
348 require $module;
349 1;
350 REQUIRE
351
352 my( $eval_result, $eval_error ) = _eval($code);
353 my $ok = $tb->ok( $eval_result, "require $module;" );
354
355 unless($ok) {
356 chomp $eval_error;
357 $tb->diag(<<DIAGNOSTIC);
358 Tried to require '$module'.
359 Error: $eval_error
360 DIAGNOSTIC
361
362 }
363
364 return $ok;
365 }
366
367 sub _is_module_name {
368 my $module = shift;
369
370 # Module names start with a letter.
371 # End with an alphanumeric.
372 # The rest is an alphanumeric or ::
373 $module =~ s/\b::\b//g;
374
375 return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
376 }
377
378 #line 969
379
380 our( @Data_Stack, %Refs_Seen );
381 my $DNE = bless [], 'Does::Not::Exist';
382
383 sub _dne {
384 return ref $_[0] eq ref $DNE;
385 }
386
387 ## no critic (Subroutines::RequireArgUnpacking)
388 sub is_deeply {
389 my $tb = Test::More->builder;
390
391 unless( @_ == 2 or @_ == 3 ) {
392 my $msg = <<'WARNING';
393 is_deeply() takes two or three args, you gave %d.
394 This usually means you passed an array or hash instead
395 of a reference to it
396 WARNING
397 chop $msg; # clip off newline so carp() will put in line/file
398
399 _carp sprintf $msg, scalar @_;
400
401 return $tb->ok(0);
402 }
403
404 my( $got, $expected, $name ) = @_;
405
406 $tb->_unoverload_str( \$expected, \$got );
407
408 my $ok;
409 if( !ref $got and !ref $expected ) { # neither is a reference
410 $ok = $tb->is_eq( $got, $expected, $name );
411 }
412 elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't
413 $ok = $tb->ok( 0, $name );
414 $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
415 }
416 else { # both references
417 local @Data_Stack = ();
418 if( _deep_check( $got, $expected ) ) {
419 $ok = $tb->ok( 1, $name );
420 }
421 else {
422 $ok = $tb->ok( 0, $name );
423 $tb->diag( _format_stack(@Data_Stack) );
424 }
425 }
426
427 return $ok;
428 }
429
430 sub _format_stack {
431 my(@Stack) = @_;
432
433 my $var = '$FOO';
434 my $did_arrow = 0;
435 foreach my $entry (@Stack) {
436 my $type = $entry->{type} || '';
437 my $idx = $entry->{'idx'};
438 if( $type eq 'HASH' ) {
439 $var .= "->" unless $did_arrow++;
440 $var .= "{$idx}";
441 }
442 elsif( $type eq 'ARRAY' ) {
443 $var .= "->" unless $did_arrow++;
444 $var .= "[$idx]";
445 }
446 elsif( $type eq 'REF' ) {
447 $var = "\${$var}";
448 }
449 }
450
451 my @vals = @{ $Stack[-1]{vals} }[ 0, 1 ];
452 my @vars = ();
453 ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
454 ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
455
456 my $out = "Structures begin differing at:\n";
457 foreach my $idx ( 0 .. $#vals ) {
458 my $val = $vals[$idx];
459 $vals[$idx]
460 = !defined $val ? 'undef'
461 : _dne($val) ? "Does not exist"
462 : ref $val ? "$val"
463 : "'$val'";
464 }
465
466 $out .= "$vars[0] = $vals[0]\n";
467 $out .= "$vars[1] = $vals[1]\n";
468
469 $out =~ s/^/ /msg;
470 return $out;
471 }
472
473 sub _type {
474 my $thing = shift;
475
476 return '' if !ref $thing;
477
478 for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
479 return $type if UNIVERSAL::isa( $thing, $type );
480 }
481
482 return '';
483 }
484
485 #line 1129
486
487 sub diag {
488 return Test::More->builder->diag(@_);
489 }
490
491 sub note {
492 return Test::More->builder->note(@_);
493 }
494
495 #line 1155
496
497 sub explain {
498 return Test::More->builder->explain(@_);
499 }
500
501 #line 1221
502
503 ## no critic (Subroutines::RequireFinalReturn)
504 sub skip {
505 my( $why, $how_many ) = @_;
506 my $tb = Test::More->builder;
507
508 unless( defined $how_many ) {
509 # $how_many can only be avoided when no_plan is in use.
510 _carp "skip() needs to know \$how_many tests are in the block"
511 unless $tb->has_plan eq 'no_plan';
512 $how_many = 1;
513 }
514
515 if( defined $how_many and $how_many =~ /\D/ ) {
516 _carp
517 "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
518 $how_many = 1;
519 }
520
521 for( 1 .. $how_many ) {
522 $tb->skip($why);
523 }
524
525 no warnings 'exiting';
526 last SKIP;
527 }
528
529 #line 1305
530
531 sub todo_skip {
532 my( $why, $how_many ) = @_;
533 my $tb = Test::More->builder;
534
535 unless( defined $how_many ) {
536 # $how_many can only be avoided when no_plan is in use.
537 _carp "todo_skip() needs to know \$how_many tests are in the block"
538 unless $tb->has_plan eq 'no_plan';
539 $how_many = 1;
540 }
541
542 for( 1 .. $how_many ) {
543 $tb->todo_skip($why);
544 }
545
546 no warnings 'exiting';
547 last TODO;
548 }
549
550 #line 1360
551
552 sub BAIL_OUT {
553 my $reason = shift;
554 my $tb = Test::More->builder;
555
556 $tb->BAIL_OUT($reason);
557 }
558
559 #line 1399
560
561 #'#
562 sub eq_array {
563 local @Data_Stack = ();
564 _deep_check(@_);
565 }
566
567 sub _eq_array {
568 my( $a1, $a2 ) = @_;
569
570 if( grep _type($_) ne 'ARRAY', $a1, $a2 ) {
571 warn "eq_array passed a non-array ref";
572 return 0;
573 }
574
575 return 1 if $a1 eq $a2;
576
577 my $ok = 1;
578 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
579 for( 0 .. $max ) {
580 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
581 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
582
583 next if _equal_nonrefs($e1, $e2);
584
585 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
586 $ok = _deep_check( $e1, $e2 );
587 pop @Data_Stack if $ok;
588
589 last unless $ok;
590 }
591
592 return $ok;
593 }
594
595 sub _equal_nonrefs {
596 my( $e1, $e2 ) = @_;
597
598 return if ref $e1 or ref $e2;
599
600 if ( defined $e1 ) {
601 return 1 if defined $e2 and $e1 eq $e2;
602 }
603 else {
604 return 1 if !defined $e2;
605 }
606
607 return;
608 }
609
610 sub _deep_check {
611 my( $e1, $e2 ) = @_;
612 my $tb = Test::More->builder;
613
614 my $ok = 0;
615
616 # Effectively turn %Refs_Seen into a stack. This avoids picking up
617 # the same referenced used twice (such as [\$a, \$a]) to be considered
618 # circular.
619 local %Refs_Seen = %Refs_Seen;
620
621 {
622 $tb->_unoverload_str( \$e1, \$e2 );
623
624 # Either they're both references or both not.
625 my $same_ref = !( !ref $e1 xor !ref $e2 );
626 my $not_ref = ( !ref $e1 and !ref $e2 );
627
628 if( defined $e1 xor defined $e2 ) {
629 $ok = 0;
630 }
631 elsif( !defined $e1 and !defined $e2 ) {
632 # Shortcut if they're both undefined.
633 $ok = 1;
634 }
635 elsif( _dne($e1) xor _dne($e2) ) {
636 $ok = 0;
637 }
638 elsif( $same_ref and( $e1 eq $e2 ) ) {
639 $ok = 1;
640 }
641 elsif($not_ref) {
642 push @Data_Stack, { type => '', vals => [ $e1, $e2 ] };
643 $ok = 0;
644 }
645 else {
646 if( $Refs_Seen{$e1} ) {
647 return $Refs_Seen{$e1} eq $e2;
648 }
649 else {
650 $Refs_Seen{$e1} = "$e2";
651 }
652
653 my $type = _type($e1);
654 $type = 'DIFFERENT' unless _type($e2) eq $type;
655
656 if( $type eq 'DIFFERENT' ) {
657 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
658 $ok = 0;
659 }
660 elsif( $type eq 'ARRAY' ) {
661 $ok = _eq_array( $e1, $e2 );
662 }
663 elsif( $type eq 'HASH' ) {
664 $ok = _eq_hash( $e1, $e2 );
665 }
666 elsif( $type eq 'REF' ) {
667 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
668 $ok = _deep_check( $$e1, $$e2 );
669 pop @Data_Stack if $ok;
670 }
671 elsif( $type eq 'SCALAR' ) {
672 push @Data_Stack, { type => 'REF', vals => [ $e1, $e2 ] };
673 $ok = _deep_check( $$e1, $$e2 );
674 pop @Data_Stack if $ok;
675 }
676 elsif($type) {
677 push @Data_Stack, { type => $type, vals => [ $e1, $e2 ] };
678 $ok = 0;
679 }
680 else {
681 _whoa( 1, "No type in _deep_check" );
682 }
683 }
684 }
685
686 return $ok;
687 }
688
689 sub _whoa {
690 my( $check, $desc ) = @_;
691 if($check) {
692 die <<"WHOA";
693 WHOA! $desc
694 This should never happen! Please contact the author immediately!
695 WHOA
696 }
697 }
698
699 #line 1546
700
701 sub eq_hash {
702 local @Data_Stack = ();
703 return _deep_check(@_);
704 }
705
706 sub _eq_hash {
707 my( $a1, $a2 ) = @_;
708
709 if( grep _type($_) ne 'HASH', $a1, $a2 ) {
710 warn "eq_hash passed a non-hash ref";
711 return 0;
712 }
713
714 return 1 if $a1 eq $a2;
715
716 my $ok = 1;
717 my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
718 foreach my $k ( keys %$bigger ) {
719 my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
720 my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
721
722 next if _equal_nonrefs($e1, $e2);
723
724 push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
725 $ok = _deep_check( $e1, $e2 );
726 pop @Data_Stack if $ok;
727
728 last unless $ok;
729 }
730
731 return $ok;
732 }
733
734 #line 1605
735
736 sub eq_set {
737 my( $a1, $a2 ) = @_;
738 return 0 unless @$a1 == @$a2;
739
740 no warnings 'uninitialized';
741
742 # It really doesn't matter how we sort them, as long as both arrays are
743 # sorted with the same algorithm.
744 #
745 # Ensure that references are not accidentally treated the same as a
746 # string containing the reference.
747 #
748 # Have to inline the sort routine due to a threading/sort bug.
749 # See [rt.cpan.org 6782]
750 #
751 # I don't know how references would be sorted so we just don't sort
752 # them. This means eq_set doesn't really work with refs.
753 return eq_array(
754 [ grep( ref, @$a1 ), sort( grep( !ref, @$a1 ) ) ],
755 [ grep( ref, @$a2 ), sort( grep( !ref, @$a2 ) ) ],
756 );
757 }
758
759 #line 1807
760
761 1;
+308
-0
lib/Object/Container/ja.pod less more
0 =encoding utf-8
1
2 =for stopwords OO
3
4 =head1 NAME
5
6 Object::Container::ja - シンプルなオブジェクトコンテナインタフェース
7
8 =head1 SYNOPSIS
9
10 use Object::Container;
11
12 ## OO インタフェース
13 # 初期化
14 my $container = Object::Container->new;
15
16 # クラスを登録
17 $container->register('HTML::TreeBuilder');
18
19 # クラスをイニシャライザ指定して登録
20 $container->register('WWW::Mechanize', sub {
21 my $mech = WWW::Mechanize->new( stack_depth => 1 );
22 $mech->agent_alias('Windows IE 6');
23 return $mech;
24 });
25
26 # 登録したオブジェクトを得る
27 my $mech = $container->get('WWW::Mechanize');
28
29 ## Singletonインタフェース
30 my $container = Object::Container->instance;
31
32 # Singletonインタフェースの場合はregister/getはクラスメソッドとして動作する
33 Object::Container->register('WWW::Mechanize');
34 my $mech = Object::Container->get('WWW::Mechanize');
35
36 # Singletonインタフェースはget関数を任意の名前でエクスポートできる
37 use Object::Container 'container';
38 container->register('WWW::Mechanize');
39 my $mech = container->get('WWW::Mechanize');
40 my $mech = container('WWW::Mechanize'); # save as above
41
42 # Singletonインタフェースのサブクラス化
43 package MyObj;
44 use Object::Container '-base';
45
46 register 'ua' => sub { LWP::UserAgent->new };
47
48 =head1 DESCRIPTION
49
50 Object::Container は Singleton インタフェース、OO インタフェースどちらでもつかえるシンプルなオブジェクトコンテナーを提供するモジュールです。
51
52 アプリケーション中で同一のオブジェクトをいろいろな場所で使用したい場合があるかもしれません。
53 そのような場合に、L<Class::Singleton> などを使用してどこからでもそのオブジェクトを取り出せるように設計することがありますが、この方法だと使用したいクラスをサブクラス化して使用する必要があります。
54
55 このモジュールではオブジェクトを複数格納できるコンテナーを提供し、コンテナー自身を Singleton にすることで複数のオブジェクトを簡単にどこからでもアクセスできるようにすることができます。
56
57 設計思想は L<Object::Registrar> というモジュールに似ていますが、OOインターフェースを持つ点、登録されたオブジェクトの初期化を実際に必要になるまで行わない (遅延実行）点が異なっています。
58
59 =head2 OOインターフェースとSingletonインターフェース
60
61 このモジュールは OO インターフェースと Singleton インタフェースの二種類のインターフェースを持ちます。
62
63 OOインターフェスは
64
65 my $container = Object::Container->new;
66
67 などのようにコンストラクタを呼び、その返り値のオブジェクトを介してオブジェクトの登録や取得を行います。この場合登録したオブジェクトはコンテナーオブジェクトごとに独立しています。
68
69 例えば
70
71 my $container1 = Object::Container->new;
72 my $container2 = Object::Container->new;
73
74 などのように複数のコンテナーを使い分けるような使い方ができます。
75
76 Singletonインタフェースは
77
78 my $container = Object::Container->instance;
79
80 というように明示的にコンストラクタをよばす、クラスに割り当てられた唯一のオブジェクトを使用するインターフェースです。
81
82 Singletonインタフェースを使用する場合は、register や get 関数などは
83
84 Object::Container->register('WWW::Mechanize', sub { WWW::Mechanize->new( stack_depth => 1 ) });
85
86 というようにすべてクラスメソッドとして使用することができます。Singletonインターフェースで複数のコンテナーを使いたい場合はサブクラス化をして
87
88 MyContainer1->get('WWW::Mechanize');
89 MyContainer2->get('WWW::Mechanize');
90
91 のようにします。
92
93 =head2 SingletonインタフェースとEXPORT関数
94
95 Singletonインタフェースで、いちいち
96
97 MyContainer->get('WWW::Mechanize');
98
99 と書くのがだるい、と言う人のために好きな名前でコンテナをEXPORTできる機能を用意してあります。
100
101 use MyContainer 'obj';
102
103 と、use 時にエクスポートしたい関数名を指定します。すると
104
105 obj->register( mech => sub { WWW::Mechanize->new });
106
107 obj->get('mech');
108 obj('mech'); # shortcut to obj->get('mech')
109
110 などと短い書き方でコンテナーにアクセスできるようになります。
111
112 =head2 Singletonインタフェースとサブクラス化
113
114 Singletonインタフェースのサブクラス内でオブジェクトを登録したいときに
115
116 __PACKAGE__->register( mech => sub { WWW::Mechanize->new } );
117
118 と書くのがだるい、と言う人のためにサブクラス化時のインタフェースも用意してあります。
119
120 サブクラス化するときに、
121
122 use base 'Object::Container';
123
124 とするかわりに
125
126 use Object::Container '-base';
127
128 とすると register と言う関数がエクスポートされます。こうすると上記の C<< __PACKAGE__->register >> のかわりに
129
130 register mech => sub { WWW::Mechanize->new };
131
132 と書くことができるようになります。
133
134 =head2 遅延ロードと依存性解決
135
136 registerメソッドで登録されたオブジェクトは、初回の get メソッドを実行したときに初めて初期化されます。
137
138 Object::Container->register('WWW::Mechanize', sub { WWW::Mechanize->new }); # ここで WWW::Mechanize->new は実行されない
139 my $mech = Object::Container->get('WWW::Mechanize'); # ここで実行される
140
141 この機能により大量にクラスが登録されていても、必要な物のみ初期化されるためリソースを大量に消費することがないため永続プロセス以外でも手軽に導入できるでしょう。
142
143 また Singleton インタフェースは初期化関数と組み合わせることにより、オブジェクト同士の依存性の解決も行うことができます。
144
145 たとえば、L<HTTP::Cookies> オブジェクトに依存した L<LWP::UserAgent> を考えます。このような場合、
146
147 Object::Container->register('HTTP::Cookies', sub { HTTP::Cookies->new( file => '/path/to/cookie.dat' ) });
148 Object::Container->register('LWP::UserAgent', sub {
149 my $cookies = Object::Container->get('HTTP::Cookies');
150 LWP::UserAgent->new( cookie_jar => $cookies );
151 });
152
153 というように初期化関数のなかで get メソッドをしようすることで依存性の解決が行えます。
154
155 上記の場合、
156
157 my $ua = Object::Container->get('LWP::UserAgent');
158
159 した場合に LWP::UserAgent と HTTP::Cookies の両方が初期化されます。
160
161 もし、登録と同時に初期化したい場合、以下のようにできます。
162
163 Object::Container->register({ class => 'LWP::UserAgent', preload => 1 });
164
165 I<initializer> オプションを指定することができます。
166
167 Object::Container->register({ class => 'WWW::Mechanize', initializer => sub {
168 my $mech = WWW::Mechanize->new( stack_depth );
169 $mech->agent_alias('Windows IE 6');
170 return $mech;
171 }, preload => 1 });
172
173 これは、以下のように書くのと同じです。
174
175 Object::Container->register('WWW::Mechanize', sub {
176 my $mech = WWW::Mechanize->new( stack_depth );
177 $mech->agent_alias('Windows IE 6');
178 return $mech;
179 });
180 Object::Container->get('WWW::Mechanize');
181
182 I<args> オプションを指定した場合は:
183
184 Object::Container->register({ class => 'LWP::UserAgent', args => \@args, preload => 1 });
185
186 これは、もうおわかりのように、以下と同じです。
187
188 Object::Container->register('LWP::UserAgent', @args);
189 Object::Container->get('LWP::UserAgent');
190
191 =head1 METHODS
192
193 =head2 register( $class, @args )
194
195 =head2 register( $class_or_name, $initialize_code )
196
197 Object::Container にオブジェクトを登録します。
198
199 いちばんシンプルな使い方は
200
201 Object::Container->register('WWW::Mechanize');
202
203 などのようにクラス名のみを登録する方法です。この場合 get した場合に WWW::Mechanize->new が引数なしで呼ばれます。
204
205 new の引数を指定したい場合は
206
207 Object::Container->register('WWW::Mechanize', @constructor_args);
208
209 などのように第二引数以降に配列をわたせばそれがそのまま new にわたされます。
210
211 new 以外のコンストラクタが必要な場合、他に初期化処理が必要な場合、依存しているモジュールがある場合などは、第二引数にコードリファレンスを渡すことで任意の初期化処理が行えます。
212
213 Object::Container->register('WWW::Mechanize', sub {
214 my $mech = WWW::Mechanize->new( stack_depth );
215 $mech->agent_alias('Windows IE 6');
216 return $mech;
217 });
218
219 このコードリファレンスではコンテナに格納するオブジェクトを返す必要があります。
220
221 またこのように初期化関数を渡す場合、第一引数ではクラス名を与える必要はなく任意の名前を与えることができます。
222
223 Object::Container->register('ua1', sub { LWP::UserAgent->new });
224 Object::Container->register('ua2', sub { LWP::UserAgent->new });
225
226 などと言った使い方も可能です。
227
228 =head2 get($class_or_name)
229
230 registerメソッドで登録したオブジェクトを取得します。
231
232 与える引数はregisterメソッドに与えた第一引数と同じ物を渡します。
233
234 =head2 ensure_class_loaded($class)
235
236 $class がロードされているか確認し、ロードされていなかった場合そのクラスを use してくれるユーティリティ関数です。
237
238 初期化関数に依存性を含ませるような場合でその依存モジュールを遅延ロードしたい場合などに使用すると便利です。
239
240 =head2 load_all
241
242 =head2 load_all_except(@classes_or_names)
243
244 基本的にこのモジュールは必要になるまで（getメソッドが呼ばれるまで）オブジェクトを初期化しませんが、
245 C<Copy-On-Write> や、実行時の速度を重視する場合など、あらかじめオブジェクトを初期化しておきたい場合があるかもしれません。そのような場合には
246
247 Object::Container->load_all;
248
249 とすることで全てのオブジェクトを初期化済みにすることができます。
250
251 また、特定のオブジェクトだけは初期化したくないという場合、
252
253 Object::Container->load_all_except(qw/Foo Bar/);
254
255 などとすると初期化したくないオブジェクト以外の全てのオブジェクトを初期化することも出来ます。
256 上記の場合は Foo と Bar と言うオブジェクト以外の全てのオブジェクトを初期化します。
257
258 =head1 EXPORT FUNCTIONS ON SUBCLASS INTERFACE
259
260 package MyContainer;
261 use strict;
262 use warnings;
263 use Object::Container '-base';
264
265 とすることで Object::Container を継承し独自のコンテナークラスを定義することが出来ます。
266
267 このサブクラス中では以下の関数をしようしてオブジェクト定義をすることができます。
268
269 =head2 register( $class, @args )
270
271 =head2 register( $class_or_name, $initialize_code )
272
273 register Foo => sub {
274 my ($self) = @_;
275 $self->ensure_class_loaded('Foo');
276 Foo->new;
277 };
278
279 オブジェクトを登録します。上述したクラス（オブジェクト）メソッドの C<register> メソッドとおなじ役割をします。
280
281 =head2 preload(@classes_or_names)
282
283 =head2 preload_all
284
285 =head2 preload_all_except
286
287 これらはクラス（オブジェクト）メソッドの C<load_all>、C<load_all_except> と同じようにつかえる関数で、その名前の通り C<preload_all> が C<load_all> と、C<preload_all_except> が C<load_all_except> とそれぞれ対応しています。
288
289 =head1 SEE ALSO
290
291 L<Class::Singleton>, L<Object::Registrar>.
292
293 =head1 AUTHOR
294
295 Daisuke Murase <typester@cpan.org>
296
297 =head1 COPYRIGHT & LICENSE
298
299 Copyright (c) 2009 by KAYAC Inc.
300
301 This program is free software; you can redistribute
302 it and/or modify it under the same terms as Perl itself.
303
304 The full text of the license can be found in the
305 LICENSE file included with this module.
306
307 =cut
+552
-0
lib/Object/Container.pm less more
0 package Object::Container;
1
2 use strict;
3 use warnings;
4 use parent qw(Class::Accessor::Fast);
5 use Carp;
6
7 our $VERSION = '0.14';
8
9 __PACKAGE__->mk_accessors(qw/registered_classes autoloader_rules objects/);
10
11 BEGIN {
12 our $_HAVE_EAC = 1;
13 eval { local $SIG{__DIE__}; require Exporter::AutoClean; };
14 if ($@) {
15 $_HAVE_EAC = 0;
16 }
17 }
18
19 do {
20 my @EXPORTS;
21
22 sub import {
23 my ($class, $name) = @_;
24 return unless $name;
25
26 my $caller = caller;
27 {
28 no strict 'refs';
29 if ($name =~ /^-base$/i) {
30 push @{"${caller}::ISA"}, $class;
31 my $r = $class->can('register');
32 my $l = $class->can('autoloader');
33
34 my %exports = (
35 register => sub { $r->($caller, @_) },
36 autoloader => sub { $l->($caller, @_) },
37 preload => sub {
38 $caller->instance->get($_) for @_;
39 },
40 preload_all_except => sub {
41 $caller->instance->load_all_except(@_);
42 },
43 preload_all => sub {
44 $caller->instance->load_all;
45 },
46 );
47
48 if ($Object::Container::_HAVE_EAC) {
49 Exporter::AutoClean->export( $caller, %exports );
50 }
51 else {
52 while (my ($name, $fn) = each %exports) {
53 *{"${caller}::${name}"} = $fn;
54 }
55 @EXPORTS = keys %exports;
56 }
57 }
58 else {
59 no strict 'refs';
60 *{"${caller}::${name}"} = sub {
61 my ($target) = @_;
62 return $target ? $class->get($target) : $class;
63 };
64 }
65 }
66 }
67
68 sub unimport {
69 my $caller = caller;
70
71 no strict 'refs';
72 for my $name (@EXPORTS) {
73 delete ${ $caller . '::' }{ $name };
74 }
75
76 1; # for EOF
77 }
78 };
79
80 my %INSTANCES;
81 sub instance {
82 my $class = shift;
83 return $INSTANCES{$class} ||= $class->new;
84 }
85
86 sub has_instance {
87 my $class = shift;
88 $class = ref $class || $class;
89 return $INSTANCES{$class};
90 };
91
92 sub new {
93 $_[0]->SUPER::new( +{
94 registered_classes => +{},
95 autoloader_rules => +[],
96 objects => +{},
97 } );
98 }
99
100 sub register {
101 my ($self, $args, @rest) = @_;
102 $self = $self->instance unless ref $self;
103
104 my ($class, $initializer, $is_preload);
105 if (defined $args && !ref $args) {
106 $class = $args;
107 if (@rest == 1 and ref $rest[0] eq 'CODE') {
108 $initializer = $rest[0];
109 }
110 else {
111 $initializer = sub {
112 $self->ensure_class_loaded($class);
113 $class->new(@rest);
114 };
115 }
116 }
117 elsif (ref $args eq 'HASH') {
118 $class = $args->{class};
119 $args->{args} ||= [];
120 if (ref $args->{initializer} eq 'CODE') {
121 $initializer = $args->{initializer};
122 }
123 else {
124 $initializer = sub {
125 $self->ensure_class_loaded($class);
126 $class->new(@{$args->{args}});
127 };
128 }
129
130 $is_preload = 1 if $args->{preload};
131 }
132 else {
133 croak "Usage: $self->register($class || { class => $class ... })";
134 }
135
136 $self->registered_classes->{$class} = $initializer;
137 $self->get($class) if $is_preload;
138
139 return $initializer;
140 }
141
142 sub unregister {
143 my ($self, $class) = @_;
144 $self = $self->instance unless ref $self;
145
146 delete $self->registered_classes->{$class} and $self->remove($class);
147 }
148
149 sub autoloader {
150 my ($self, $rule, $trigger) = @_;
151 $self = $self->instance unless ref $self;
152
153 push @{ $self->autoloader_rules }, [$rule, $trigger];
154 }
155
156 sub get {
157 my ($self, $class) = @_;
158 $self = $self->instance unless ref $self;
159
160 my $obj = $self->objects->{ $class } ||= do {
161 my $initializer = $self->registered_classes->{ $class };
162 $initializer ? $initializer->($self) : ();
163 };
164
165 unless ($obj) {
166 # autoloaderer
167 if (my ($trigger) = grep { $class =~ /$_->[0]/ } @{ $self->autoloader_rules }) {
168 $trigger->[1]->($self, $class);
169 }
170
171 $obj = $self->objects->{ $class } ||= do {
172 my $initializer = $self->registered_classes->{ $class };
173 $initializer ? $initializer->($self) : ();
174 };
175 }
176
177 $obj or croak qq["$class" is not registered in @{[ ref $self ]}];
178 }
179
180 sub remove {
181 my ($self, $class) = @_;
182 $self = $self->instance unless ref $self;
183 delete $self->objects->{ $class };
184 }
185
186 sub load_all {
187 my ($self) = @_;
188 $self->load_all_except;
189 }
190
191 sub load_all_except {
192 my ($self, @except) = @_;
193 $self = $self->instance unless ref $self;
194
195 for my $class (keys %{ $self->registered_classes }) {
196 next if grep { $class eq $_ } @except;
197 $self->get($class);
198 }
199 }
200
201 # taken from Mouse
202 sub _is_class_loaded {
203 my $class = shift;
204
205 return 0 if ref($class) || !defined($class) || !length($class);
206
207 # walk the symbol table tree to avoid autovififying
208 # \*{${main::}{"Foo::"}{"Bar::"}} == \*main::Foo::Bar::
209
210 my $pack = \%::;
211 foreach my $part (split('::', $class)) {
212 $part .= '::';
213 return 0 if !exists $pack->{$part};
214
215 my $entry = \$pack->{$part};
216 return 0 if ref($entry) ne 'GLOB';
217 $pack = *{$entry}{HASH};
218 }
219
220 return 0 if !%{$pack};
221
222 # check for $VERSION or @ISA
223 return 1 if exists $pack->{VERSION}
224 && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
225 return 1 if exists $pack->{ISA}
226 && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
227
228 # check for any method
229 foreach my $name( keys %{$pack} ) {
230 my $entry = \$pack->{$name};
231 return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
232 }
233
234 # fail
235 return 0;
236 }
237
238
239 sub _try_load_one_class {
240 my $class = shift;
241
242 return '' if _is_class_loaded($class);
243 my $klass = $class;
244 $klass =~ s{::}{/}g;
245 $klass .= '.pm';
246
247 return do {
248 local $@;
249 eval { require $klass };
250 $@;
251 };
252 }
253
254 sub ensure_class_loaded {
255 my ($self, $class) = @_;
256 my $e = _try_load_one_class($class);
257 Carp::confess "Could not load class ($class) because : $e" if $e;
258
259 return $class;
260 }
261
262 1;
263 __END__
264
265 =for stopwords DSL OO runtime singletonize unregister preload
266
267 =head1 NAME
268
269 Object::Container - simple object container
270
271 =head1 SYNOPSIS
272
273 use Object::Container;
274
275 # initialize container
276 my $container = Object::Container->new;
277
278 # register class
279 $container->register('HTML::TreeBuilder');
280
281 # register class with initializer
282 $container->register('WWW::Mechanize', sub {
283 my $mech = WWW::Mechanize->new( stack_depth => 1 );
284 $mech->agent_alias('Windows IE 6');
285 return $mech;
286 });
287
288 # get object
289 my $mech = $container->get('WWW::Mechanize');
290
291 # also available Singleton interface
292 my $container = Object::Container->instance;
293
294 # With singleton interface, you can use register/get method as class method
295 Object::Container->register('WWW::Mechanize');
296 my $mech = Object::Container->get('WWW::Mechanize');
297
298 # Export singleton interface
299 use Object::Container 'container';
300 container->register('WWW::Mechanize');
301 my $mech = container->get('WWW::Mechanize');
302 my $mech = container('WWW::Mechanize'); # save as above
303
304 # Subclassing singleton interface
305 package MyContainer;
306 use Object::Container '-base';
307
308 register mech => sub { WWW::Mechanize->new };
309
310 # use it
311 use MyContainer 'con';
312
313 con('mech')->get('http://example.com');
314
315 =head1 DESCRIPTION
316
317 This module is a object container interface which supports both OO interface and Singleton interface.
318
319 If you want to use one module from several places, you might use L<Class::Singleton> to access the module from any places. But you should subclass each modules to singletonize.
320
321 This module provide singleton container instead of module itself, so it is easy to singleton multiple classes.
322
323 L<Object::Registrar> is a similar module to this. But Object::Container has also OO interface and supports lazy initializer. (describing below)
324
325 =head2 OO and Singleton interfaces
326
327 This module provide two interfaces: OO and Singleton.
328
329 OO interface is like this:
330
331 my $container = Object::Container->new;
332
333 It is normal object oriented interface. And you can use multiple container at the same Time:
334
335 my $container1 = Object::Container->new;
336 my $container2 = Object::Container->new;
337
338 Singleton is also like this:
339
340 my $container = Object::Container->instance;
341
342 instance method always returns singleton object. With this interface, you can 'register' and 'get' method as class method:
343
344 Object::Container->register('WWW::Mechanize');
345 my $mech = Object::Container->get('WWW::Mechanize');
346
347 When you want use multiple container with Singleton interface, you have to create subclass like this:
348
349 MyContainer1->get('WWW::Mechanize');
350 MyContainer2->get('WWW::Mechanize');
351
352 =head2 Singleton interface with EXPORT function for lazy people
353
354 If you are lazy person, and don't want to write something long code like:
355
356 MyContainer->get('WWW::Mechanize');
357
358 This module provide export functions to shorten this.
359 If you use your container with function name, the function will be exported and act as container:
360
361 use MyContainer 'container';
362
363 container->register(...);
364
365 container->get(...);
366 container(...); # shortcut to ->get(...);
367
368 =head2 Subclassing singleton interface for lazy people
369
370 If you are lazy person, and don't want to write something long code in your subclass like:
371
372 __PACKAGE__->register( ... );
373
374 Instead of above, this module provide subclassing interface.
375 To do this, you need to write below code to subclass instead of C<use base>.
376
377 use Object::Container '-base';
378
379 And then you can register your object via DSL functions:
380
381 register ua => sub { LWP::UserAgent->new };
382
383 =head2 lazy loading and resolve dependencies
384
385 The object that is registered by 'register' method is not initialized until calling 'get' method.
386
387 Object::Container->register('WWW::Mechanize', sub { WWW::Mechanize->new }); # doesn't initialize here
388 my $mech = Object::Container->get('WWW::Mechanize'); # initialize here
389
390 This feature helps you to create less resource and fast runtime script in case of lots of object registered.
391
392 And you can resolve dependencies between multiple modules with Singleton interface.
393
394 For example:
395
396 Object::Container->register('HTTP::Cookies', sub { HTTP::Cookies->new( file => '/path/to/cookie.dat' ) });
397 Object::Container->register('LWP::UserAgent', sub {
398 my $cookies = Object::Container->get('HTTP::Cookies');
399 LWP::UserAgent->new( cookie_jar => $cookies );
400 });
401
402 You can resolve dependencies by calling 'get' method in initializer like above.
403
404 In that case, only LWP::UserAgent and HTTP::Cookies are initialized.
405
406 =head1 METHODS
407
408 =head2 new
409
410 Create new object.
411
412 =head2 instance
413
414 Create singleton object and return it.
415
416 =head2 register( $class, @args )
417
418 =head2 register( $class_or_name, $initialize_code )
419
420 =head2 register( { class => $class_or_name ... } )
421
422 Register classes to container.
423
424 Most simple usage is:
425
426 Object::Container->register('WWW::Mechanize');
427
428 First argument is class name to object. In this case, execute 'WWW::Mechanize->new' when first get method call.
429
430 Object::Container->register('WWW::Mechanize', @args );
431
432 is also execute 'WWW::Mechanize->new(@args)'.
433
434 If you use different constructor from 'new', want to custom initializer, or want to include dependencies, you can custom initializer to pass a coderef as second argument.
435
436 Object::Container->register('WWW::Mechanize', sub {
437 my $mech = WWW::Mechanize->new( stack_depth );
438 $mech->agent_alias('Windows IE 6');
439 return $mech;
440 });
441
442 This coderef (initialize) should return object to contain.
443
444 With last way you can pass any name to first argument instead of class name.
445
446 Object::Container->register('ua1', sub { LWP::UserAgent->new });
447 Object::Container->register('ua2', sub { LWP::UserAgent->new });
448
449 If you want to initialize and register at the same time, the following can.
450
451 Object::Container->register({ class => 'LWP::UserAgent', preload => 1 });
452
453 I<initializer> option can be specified.
454
455 Object::Container->register({ class => 'WWW::Mechanize', initializer => sub {
456 my $mech = WWW::Mechanize->new( stack_depth );
457 $mech->agent_alias('Windows IE 6');
458 return $mech;
459 }, preload => 1 });
460
461 This is the same as written below.
462
463 Object::Container->register('WWW::Mechanize', sub {
464 my $mech = WWW::Mechanize->new( stack_depth );
465 $mech->agent_alias('Windows IE 6');
466 return $mech;
467 });
468 Object::Container->get('WWW::Mechanize');
469
470 If you specify I<args> option is:
471
472 Object::Container->register({ class => 'LWP::UserAgent', args => \@args, preload => 1 });
473
474 It is, as you know, the same below.
475
476 Object::Container->register('LWP::UserAgent', @args);
477 Object::Container->get('LWP::UserAgent');
478
479 =head2 unregister($class_or_name)
480
481 Unregister classes from container.
482
483 =head2 get($class_or_name)
484
485 Get the object that registered by 'register' method.
486
487 First argument is same as 'register' method.
488
489 =head2 remove($class_or_name)
490
491 Remove the cached object that is created at C<get> method above.
492
493 Return value is the deleted object if it's exists.
494
495 =head2 ensure_class_loaded($class)
496
497 This is utility method that load $class if $class is not loaded.
498
499 It's useful when you want include dependency in initializer and want lazy load the modules.
500
501 =head2 load_all
502
503 =head2 load_all_except(@classes_or_names)
504
505 This module basically does lazy object initializations, but in some situation, for Copy-On-Write or for runtime speed for example, you might want to preload objects.
506 For the purpose C<load_all> and C<load_all_except> method are exists.
507
508 Object::Container->load_all;
509
510 This method is load all registered object at once.
511
512 Also if you have some objects that keeps lazy loading, do like following:
513
514 Object::Container->load_all_except(qw/Foo Bar/);
515
516 This means all objects except 'Foo' and 'Bar' are loaded.
517
518 =head1 EXPORT FUNCTIONS ON SUBCLASS INTERFACE
519
520 Same functions for C<load_all> and C<load_all_except> exists at subclass interface.
521 Below is list of these functions.
522
523 =head2 preload(@classes_or_names)
524
525 =head2 preload_all
526
527 =head2 preload_all_except
528
529 As predictable by name, C<preload_all> is equals to C<load_all> and C<preload_all_except> is equals to <load_all_except>.
530
531 =head1 SEE ALSO
532
533 L<Class::Singleton>, L<Object::Registrar>.
534
535 =head1 AUTHOR
536
537 Daisuke Murase <typester@cpan.org>
538
539 =head1 COPYRIGHT & LICENSE
540
541 Copyright (c) 2009 KAYAC Inc. All rights reserved.
542
543 This program is free software; you can redistribute
544 it and/or modify it under the same terms as Perl itself.
545
546 The full text of the license can be found in the
547 LICENSE file included with this module.
548
549 =cut
550
551 1;
+4
-0
t/00_compile.t less more
0 use strict;
1 use Test::More tests => 1;
2
3 BEGIN { use_ok 'Object::Container' }
+19
-0
t/01_object.t less more
0 use Test::Base;
1
2 plan tests => 4;
3
4 use Object::Container;
5
6 my $container = Object::Container->new;
7 ok($container->register('FileHandle'), 'register class ok');
8 isa_ok($container->get('FileHandle'), 'FileHandle');
9
10 {
11 my $obj;
12 eval {
13 $obj = $container->get('unknown_object');
14 };
15
16 ok !$obj, 'return nothing when getting unknown object';
17 like $@, qr/"unknown_object" is not registered in Object::Container/, 'unknown object error ok';
18 }
+14
-0
t/02_singleton.t less more
0 use Test::Base;
1
2 plan tests => 3;
3
4 use Object::Container;
5
6 ok(Object::Container->register('FileHandle'), 'register ok');
7 isa_ok(Object::Container->get('FileHandle'), 'FileHandle' );
8
9 is(
10 Object::Container->get('FileHandle'),
11 Object::Container->get('FileHandle'),
12 'same object ok',
13 );
+34
-0
t/03_args_and_initializer.t less more
0 use Test::Base;
1
2 plan tests => 4;
3
4 use Object::Container;
5
6 {
7 package SampleClass;
8 use base 'Class::Accessor::Fast';
9
10 __PACKAGE__->mk_accessors(qw/text/);
11
12 sub new {
13 my $class = shift;
14 my $args = @_ > 1 ? {@_} : $_;
15
16 $class->SUPER::new($args);
17 }
18 }
19
20 my $c = Object::Container->new;
21
22 # args
23 $c->register('SampleClass', text => 'custom args');
24
25 isa_ok( $c->get('SampleClass'), 'SampleClass' );
26 is( $c->get('SampleClass')->text, 'custom args', 'args set ok');
27
28 # initializer
29 $c->register('SampleClass2', sub { SampleClass->new(text => 'custom initializer') });
30
31 isa_ok( $c->get('SampleClass2'), 'SampleClass' );
32 is( $c->get('SampleClass2')->text, 'custom initializer', 'initializer set ok');
33
+20
-0
t/04_export.t less more
0 use Test::Base;
1
2 plan 'no_plan';
3
4 use Object::Container 'obj';
5
6 {
7 package Foo;
8 sub new { bless {}, shift }
9 sub hello { 'hello' }
10 }
11
12 obj->register( foo => sub { Foo->new } );
13
14 isa_ok( obj('foo'), 'Foo' );
15 isa_ok( obj->get('foo'), 'Foo' );
16 is( obj('foo')->hello, 'hello', 'hello method ok');
17 is( obj->get('foo')->hello, 'hello', 'hello method ok');
18
19
+14
-0
t/05_subclass.t less more
0 use Test::Base;
1 use FindBin;
2 use lib "$FindBin::Bin/subclass";
3 use Test::Requires 'Exporter::AutoClean';
4
5 plan tests => 4;
6
7 use_ok 'Foo', 'obj';
8
9 isa_ok( my $obj = obj('foo_object'), 'FooObject' );
10 is($obj->{foo}, 'bar', 'object data ok');
11
12 isa_ok( $obj = obj('Object::Container'), 'Object::Container' );
13
+24
-0
t/05_subclass_no_autoclean.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 use FindBin;
5 use lib "$FindBin::Bin/no_clean";
6 use lib "$FindBin::Bin/subclass";
7
8 use Foo 'obj';
9
10 isa_ok( my $obj = obj('foo_object'), 'FooObject' );
11 is($obj->{foo}, 'bar', 'object data ok');
12 isa_ok( $obj = obj('Object::Container'), 'Object::Container' );
13
14 # obj->register == Foo::register because this is in no clean state
15 is obj->can('register'), Foo->can('register'), 'obj->register == Foo::register ok';
16 isnt obj->can('register'), Object::Container->can('register'), 'obj->register != Object::Container::register ok';;
17
18
19 use Bar 'obj_clean';
20
21
22
23 done_testing;
+28
-0
t/06_remove.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 use Object::Container;
5
6 my $c = Object::Container->new;
7
8 $c->register('FileHandle');
9
10 is $c->get('FileHandle'), $c->get('FileHandle'), 'save object ok';
11
12 my $cached = $c->get('FileHandle');
13 is $c->remove('FileHandle'), $cached, 'remove return cached object ok';
14
15 isnt $c->get('FileHandle'), $cached, 'recreate object after remove ok';
16
17 $c->unregister('FileHandle');
18 my $obj;
19 {
20 local $SIG{__WARN__} = {};
21 eval {
22 $obj = $c->get('FileHandle');
23 };
24 }
25 ok !$obj, 'no more avaiable after unregister ok';
26
27 done_testing;
+40
-0
t/07_hashref.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 use Object::Container;
5
6 {
7 package SampleClass;
8 use base 'Class::Accessor::Fast';
9
10 __PACKAGE__->mk_accessors(qw/text/);
11
12 sub new {
13 my $class = shift;
14 my $args = @_ > 1 ? {@_} : $_;
15
16 $class->SUPER::new($args);
17 }
18 }
19
20 my $c = Object::Container->new;
21
22 # args
23 $c->register({ class => 'SampleClass', args => [text => 'costom args'] });
24
25 isa_ok( $c->get('SampleClass'), 'SampleClass' );
26 is( $c->get('SampleClass')->text, 'costom args', 'outer args set ok');
27
28 # initializer
29 $c->register({ class => 'SampleClass2', initializer => sub { SampleClass->new(text => 'custom initializer') } });
30
31 isa_ok( $c->get('SampleClass2'), 'SampleClass' );
32 is( $c->get('SampleClass2')->text, 'custom initializer', 'initializer set ok');
33
34 # preload
35 $c->register({ class => 'SampleClass3', initializer => sub { SampleClass->new(text => 'ploeaded :)') }, preload => 1 });
36
37 is( $c->objects->{'SampleClass3'}->text, 'ploeaded :)', 'ploeaded success');
38
39 done_testing;
+56
-0
t/07_preload.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 use Object::Container;
5
6 {
7 package Foo;
8 use base 'Class::Accessor::Fast';
9
10 sub name { 'foo' }
11
12 package Bar;
13 use base 'Class::Accessor::Fast';
14
15 sub name { 'bar' }
16 }
17
18
19 subtest load_all => sub {
20 my $c = Object::Container->new;
21
22 $c->register('Foo');
23 $c->register('Bar');
24
25 # doesn't load yet
26 ok !$c->objects->{'Foo'}, 'Foo is not loaded';
27 ok !$c->objects->{'Bar'}, 'Bar is not loaded';
28
29 $c->load_all;
30
31 ok $c->objects->{'Foo'}, 'Foo is loaded';
32 ok $c->objects->{'Bar'}, 'Bar is loaded';
33
34 done_testing;
35 };
36
37 subtest load_all_except => sub {
38 my $c = Object::Container->new;
39
40 $c->register('Foo');
41 $c->register('Bar');
42
43 # doesn't load yet
44 ok !$c->objects->{'Foo'}, 'Foo is not loaded';
45 ok !$c->objects->{'Bar'}, 'Bar is not loaded';
46
47 $c->load_all_except(qw/Bar/);
48
49 ok $c->objects->{'Foo'}, 'Foo is loaded';
50 ok !$c->objects->{'Bar'}, 'Bar is not loaded too';
51
52 done_testing;
53 };
54
55 done_testing;
+32
-0
t/08_preload_subclass.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3 use Test::Requires 'Exporter::AutoClean';
4
5 {
6 package Foo;
7 use base 'Class::Accessor::Fast';
8
9 sub name { 'foo' }
10
11 package Bar;
12 use base 'Class::Accessor::Fast';
13
14 sub name { 'bar' }
15
16 package MyContainer;
17 use Object::Container '-base';
18
19 register 'Foo';
20 register 'Bar';
21
22 preload_all_except qw/Bar/;
23 }
24
25 # doesn't load yet
26 my $c = MyContainer->instance;
27
28 ok $c->objects->{'Foo'}, 'Foo is loaded';
29 ok !$c->objects->{'Bar'}, 'Bar is not loaded too';
30
31 done_testing;
+27
-0
t/09_autoload.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 use Carp;
5 $SIG{__DIE__} = sub { Carp::confess(@_) };
6
7 use Object::Container;
8 my $obj = Object::Container->new;
9
10 $obj->autoloader( qr/^Schema::.+/, sub {
11 my ($self, $class) = @_;
12
13 my ($table) = $class =~ /^Schema::(.*)/;
14 $self->register("Schema::${table}", sub { "Result $table" });
15 });
16
17 ok !$obj->{registered_classes}{'Schema::Foo'}, 'Schema::Foo does not registered';
18 ok !$obj->{objects}{'Schema::Foo'}, 'Schema::Foo does not initialized';
19
20 my $foo = $obj->get('Schema::Foo');
21 is $foo, 'Result Foo', 'result class ok';
22
23 ok $obj->{registered_classes}{'Schema::Foo'}, 'Schema::Foo registered';
24 ok $obj->{objects}{'Schema::Foo'}, 'Schema::Foo initialized';
25
26 done_testing;
+13
-0
t/10_class_singleton_compatible.t less more
0 use strict;
1 use warnings;
2 use Test::More;
3
4 use Object::Container;
5
6 ok !Object::Container->has_instance;
7
8 my $obj = Object::Container->new;
9 is_deeply $obj, Object::Container->instance;
10 is_deeply $obj, Object::Container->has_instance;
11
12 done_testing;
+2
-0
t/no_clean/Exporter/AutoClean.pm less more
0 die "Can't locale Exporter/AutoClean.pm";
1
+9
-0
t/subclass/Bar.pm less more
0 package Bar;
1 use strict;
2 use warnings;
3 use Object::Container '-base';
4
5 register foo_object => sub { bless { foo => 'bar' }, 'FooObject' };
6 register 'Object::Container';
7
8 no Object::Container;
+9
-0
t/subclass/Foo.pm less more
0 package Foo;
1 use strict;
2 use warnings;
3 use Object::Container '-base';
4
5 register foo_object => sub { bless { foo => 'bar' }, 'FooObject' };
6 register 'Object::Container';
7
8 1;
+4
-0
xt/pod.t less more
0 use Test::More;
1 eval "use Test::Pod 1.00";
2 plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
3 all_pod_files_ok();
+5
-0
xt/pod_coverage.t less more
0 use Test::More;
1 eval "use Test::Pod::Coverage 1.04";
2 plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage"
3 if $@;
4 all_pod_coverage_ok();
+28
-0
xt/pod_spell.t less more
0 use Test::More;
1 eval q{ use Test::Spelling };
2
3 plan skip_all => "Test::Spelling is not installed." if $@;
4 add_stopwords(<DATA>);
5 set_spell_cmd("aspell -l en list");
6
7 my %ignore_files = (
8 'lib/Object/Container/ja.pod' => 1,
9 );
10 my @pods = all_pod_files('lib');
11
12 plan tests => scalar @pods;
13
14 foreach my $pod(@pods){
15 if(!$ignore_files{$pod}){
16 pod_file_spelling_ok($pod);
17 }
18 else{
19 pass "IGNORE: POD spelling for $pod";
20 }
21 }
22 __DATA__
23 Daisuke
24 Murase
25 KAYAC
26
27