Codebase list libperlx-maybe-perl / upstream/0.002
Imported Upstream version 0.002 Jonas Smedegaard 11 years ago
33 changed file(s) with 5240 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+16
-0
Changes less more
0 PerlX-Maybe
1 ===========
2
3 Created: 2012-02-15
4 Home page: <https://metacpan.org/release/PerlX-Maybe>
5 Bug tracker: <http://rt.cpan.org/Dist/Display.html?Queue=PerlX-Maybe>
6
7 0.002 2012-05-03
8
9 - Faster implementation. Tested on Perl 5.10.1 on Linux, the new version
10 is 60% faster. (Not that it was slow to begin with - 'maybe' is a pretty
11 simple function.)
12
13 0.001 2012-02-15 # Initial release
14
15
+377
-0
LICENSE less more
0 This software is copyright (c) 2012 by Toby Inkster <tobyink@cpan.org>.
1
2 This is free software; you can redistribute it and/or modify it under
3 the same terms as the Perl 5 programming language system itself.
4
5 Terms of the Perl programming language system itself
6
7 a) the GNU General Public License as published by the Free
8 Software Foundation; either version 1, or (at your option) any
9 later version, or
10 b) the "Artistic License"
11
12 --- The GNU General Public License, Version 1, February 1989 ---
13
14 This software is Copyright (c) 2012 by Toby Inkster <tobyink@cpan.org>.
15
16 This is free software, licensed under:
17
18 The GNU General Public License, Version 1, February 1989
19
20 GNU GENERAL PUBLIC LICENSE
21 Version 1, February 1989
22
23 Copyright (C) 1989 Free Software Foundation, Inc.
24 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
25 Everyone is permitted to copy and distribute verbatim copies
26 of this license document, but changing it is not allowed.
27
28 Preamble
29
30 The license agreements of most software companies try to keep users
31 at the mercy of those companies. By contrast, our General Public
32 License is intended to guarantee your freedom to share and change free
33 software--to make sure the software is free for all its users. The
34 General Public License applies to the Free Software Foundation's
35 software and to any other program whose authors commit to using it.
36 You can use it for your programs, too.
37
38 When we speak of free software, we are referring to freedom, not
39 price. Specifically, the General Public License is designed to make
40 sure that you have the freedom to give away or sell copies of free
41 software, that you receive source code or can get it if you want it,
42 that you can change the software or use pieces of it in new free
43 programs; and that you know you can do these things.
44
45 To protect your rights, we need to make restrictions that forbid
46 anyone to deny you these rights or to ask you to surrender the rights.
47 These restrictions translate to certain responsibilities for you if you
48 distribute copies of the software, or if you modify it.
49
50 For example, if you distribute copies of a such a program, whether
51 gratis or for a fee, you must give the recipients all the rights that
52 you have. You must make sure that they, too, receive or can get the
53 source code. And you must tell them their rights.
54
55 We protect your rights with two steps: (1) copyright the software, and
56 (2) offer you this license which gives you legal permission to copy,
57 distribute and/or modify the software.
58
59 Also, for each author's protection and ours, we want to make certain
60 that everyone understands that there is no warranty for this free
61 software. If the software is modified by someone else and passed on, we
62 want its recipients to know that what they have is not the original, so
63 that any problems introduced by others will not reflect on the original
64 authors' reputations.
65
66 The precise terms and conditions for copying, distribution and
67 modification follow.
68
69 GNU GENERAL PUBLIC LICENSE
70 TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
71
72 0. This License Agreement applies to any program or other work which
73 contains a notice placed by the copyright holder saying it may be
74 distributed under the terms of this General Public License. The
75 "Program", below, refers to any such program or work, and a "work based
76 on the Program" means either the Program or any work containing the
77 Program or a portion of it, either verbatim or with modifications. Each
78 licensee is addressed as "you".
79
80 1. You may copy and distribute verbatim copies of the Program's source
81 code as you receive it, in any medium, provided that you conspicuously and
82 appropriately publish on each copy an appropriate copyright notice and
83 disclaimer of warranty; keep intact all the notices that refer to this
84 General Public License and to the absence of any warranty; and give any
85 other recipients of the Program a copy of this General Public License
86 along with the Program. You may charge a fee for the physical act of
87 transferring a copy.
88
89 2. You may modify your copy or copies of the Program or any portion of
90 it, and copy and distribute such modifications under the terms of Paragraph
91 1 above, provided that you also do the following:
92
93 a) cause the modified files to carry prominent notices stating that
94 you changed the files and the date of any change; and
95
96 b) cause the whole of any work that you distribute or publish, that
97 in whole or in part contains the Program or any part thereof, either
98 with or without modifications, to be licensed at no charge to all
99 third parties under the terms of this General Public License (except
100 that you may choose to grant warranty protection to some or all
101 third parties, at your option).
102
103 c) If the modified program normally reads commands interactively when
104 run, you must cause it, when started running for such interactive use
105 in the simplest and most usual way, to print or display an
106 announcement including an appropriate copyright notice and a notice
107 that there is no warranty (or else, saying that you provide a
108 warranty) and that users may redistribute the program under these
109 conditions, and telling the user how to view a copy of this General
110 Public License.
111
112 d) You may charge a fee for the physical act of transferring a
113 copy, and you may at your option offer warranty protection in
114 exchange for a fee.
115
116 Mere aggregation of another independent work with the Program (or its
117 derivative) on a volume of a storage or distribution medium does not bring
118 the other work under the scope of these terms.
119
120 3. You may copy and distribute the Program (or a portion or derivative of
121 it, under Paragraph 2) in object code or executable form under the terms of
122 Paragraphs 1 and 2 above provided that you also do one of the following:
123
124 a) accompany it with the complete corresponding machine-readable
125 source code, which must be distributed under the terms of
126 Paragraphs 1 and 2 above; or,
127
128 b) accompany it with a written offer, valid for at least three
129 years, to give any third party free (except for a nominal charge
130 for the cost of distribution) a complete machine-readable copy of the
131 corresponding source code, to be distributed under the terms of
132 Paragraphs 1 and 2 above; or,
133
134 c) accompany it with the information you received as to where the
135 corresponding source code may be obtained. (This alternative is
136 allowed only for noncommercial distribution and only if you
137 received the program in object code or executable form alone.)
138
139 Source code for a work means the preferred form of the work for making
140 modifications to it. For an executable file, complete source code means
141 all the source code for all modules it contains; but, as a special
142 exception, it need not include source code for modules which are standard
143 libraries that accompany the operating system on which the executable
144 file runs, or for standard header files or definitions files that
145 accompany that operating system.
146
147 4. You may not copy, modify, sublicense, distribute or transfer the
148 Program except as expressly provided under this General Public License.
149 Any attempt otherwise to copy, modify, sublicense, distribute or transfer
150 the Program is void, and will automatically terminate your rights to use
151 the Program under this License. However, parties who have received
152 copies, or rights to use copies, from you under this General Public
153 License will not have their licenses terminated so long as such parties
154 remain in full compliance.
155
156 5. By copying, distributing or modifying the Program (or any work based
157 on the Program) you indicate your acceptance of this license to do so,
158 and all its terms and conditions.
159
160 6. Each time you redistribute the Program (or any work based on the
161 Program), the recipient automatically receives a license from the original
162 licensor to copy, distribute or modify the Program subject to these
163 terms and conditions. You may not impose any further restrictions on the
164 recipients' exercise of the rights granted herein.
165
166 7. The Free Software Foundation may publish revised and/or new versions
167 of the General Public License from time to time. Such new versions will
168 be similar in spirit to the present version, but may differ in detail to
169 address new problems or concerns.
170
171 Each version is given a distinguishing version number. If the Program
172 specifies a version number of the license which applies to it and "any
173 later version", you have the option of following the terms and conditions
174 either of that version or of any later version published by the Free
175 Software Foundation. If the Program does not specify a version number of
176 the license, you may choose any version ever published by the Free Software
177 Foundation.
178
179 8. If you wish to incorporate parts of the Program into other free
180 programs whose distribution conditions are different, write to the author
181 to ask for permission. For software which is copyrighted by the Free
182 Software Foundation, write to the Free Software Foundation; we sometimes
183 make exceptions for this. Our decision will be guided by the two goals
184 of preserving the free status of all derivatives of our free software and
185 of promoting the sharing and reuse of software generally.
186
187 NO WARRANTY
188
189 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
190 FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
191 OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
192 PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
193 OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
194 MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
195 TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
196 PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
197 REPAIR OR CORRECTION.
198
199 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
200 WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
201 REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
202 INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
203 OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
204 TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
205 YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
206 PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
207 POSSIBILITY OF SUCH DAMAGES.
208
209 END OF TERMS AND CONDITIONS
210
211 Appendix: How to Apply These Terms to Your New Programs
212
213 If you develop a new program, and you want it to be of the greatest
214 possible use to humanity, the best way to achieve this is to make it
215 free software which everyone can redistribute and change under these
216 terms.
217
218 To do so, attach the following notices to the program. It is safest to
219 attach them to the start of each source file to most effectively convey
220 the exclusion of warranty; and each file should have at least the
221 "copyright" line and a pointer to where the full notice is found.
222
223 <one line to give the program's name and a brief idea of what it does.>
224 Copyright (C) 19yy <name of author>
225
226 This program is free software; you can redistribute it and/or modify
227 it under the terms of the GNU General Public License as published by
228 the Free Software Foundation; either version 1, or (at your option)
229 any later version.
230
231 This program is distributed in the hope that it will be useful,
232 but WITHOUT ANY WARRANTY; without even the implied warranty of
233 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
234 GNU General Public License for more details.
235
236 You should have received a copy of the GNU General Public License
237 along with this program; if not, write to the Free Software Foundation,
238 Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
239
240 Also add information on how to contact you by electronic and paper mail.
241
242 If the program is interactive, make it output a short notice like this
243 when it starts in an interactive mode:
244
245 Gnomovision version 69, Copyright (C) 19xx name of author
246 Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
247 This is free software, and you are welcome to redistribute it
248 under certain conditions; type `show c' for details.
249
250 The hypothetical commands `show w' and `show c' should show the
251 appropriate parts of the General Public License. Of course, the
252 commands you use may be called something other than `show w' and `show
253 c'; they could even be mouse-clicks or menu items--whatever suits your
254 program.
255
256 You should also get your employer (if you work as a programmer) or your
257 school, if any, to sign a "copyright disclaimer" for the program, if
258 necessary. Here a sample; alter the names:
259
260 Yoyodyne, Inc., hereby disclaims all copyright interest in the
261 program `Gnomovision' (a program to direct compilers to make passes
262 at assemblers) written by James Hacker.
263
264 <signature of Ty Coon>, 1 April 1989
265 Ty Coon, President of Vice
266
267 That's all there is to it!
268
269
270 --- The Artistic License 1.0 ---
271
272 This software is Copyright (c) 2012 by Toby Inkster <tobyink@cpan.org>.
273
274 This is free software, licensed under:
275
276 The Artistic License 1.0
277
278 The Artistic License
279
280 Preamble
281
282 The intent of this document is to state the conditions under which a Package
283 may be copied, such that the Copyright Holder maintains some semblance of
284 artistic control over the development of the package, while giving the users of
285 the package the right to use and distribute the Package in a more-or-less
286 customary fashion, plus the right to make reasonable modifications.
287
288 Definitions:
289
290 - "Package" refers to the collection of files distributed by the Copyright
291 Holder, and derivatives of that collection of files created through
292 textual modification.
293 - "Standard Version" refers to such a Package if it has not been modified,
294 or has been modified in accordance with the wishes of the Copyright
295 Holder.
296 - "Copyright Holder" is whoever is named in the copyright or copyrights for
297 the package.
298 - "You" is you, if you're thinking about copying or distributing this Package.
299 - "Reasonable copying fee" is whatever you can justify on the basis of media
300 cost, duplication charges, time of people involved, and so on. (You will
301 not be required to justify it to the Copyright Holder, but only to the
302 computing community at large as a market that must bear the fee.)
303 - "Freely Available" means that no fee is charged for the item itself, though
304 there may be fees involved in handling the item. It also means that
305 recipients of the item may redistribute it under the same conditions they
306 received it.
307
308 1. You may make and give away verbatim copies of the source form of the
309 Standard Version of this Package without restriction, provided that you
310 duplicate all of the original copyright notices and associated disclaimers.
311
312 2. You may apply bug fixes, portability fixes and other modifications derived
313 from the Public Domain or from the Copyright Holder. A Package modified in such
314 a way shall still be considered the Standard Version.
315
316 3. You may otherwise modify your copy of this Package in any way, provided that
317 you insert a prominent notice in each changed file stating how and when you
318 changed that file, and provided that you do at least ONE of the following:
319
320 a) place your modifications in the Public Domain or otherwise make them
321 Freely Available, such as by posting said modifications to Usenet or an
322 equivalent medium, or placing the modifications on a major archive site
323 such as ftp.uu.net, or by allowing the Copyright Holder to include your
324 modifications in the Standard Version of the Package.
325
326 b) use the modified Package only within your corporation or organization.
327
328 c) rename any non-standard executables so the names do not conflict with
329 standard executables, which must also be provided, and provide a separate
330 manual page for each non-standard executable that clearly documents how it
331 differs from the Standard Version.
332
333 d) make other distribution arrangements with the Copyright Holder.
334
335 4. You may distribute the programs of this Package in object code or executable
336 form, provided that you do at least ONE of the following:
337
338 a) distribute a Standard Version of the executables and library files,
339 together with instructions (in the manual page or equivalent) on where to
340 get the Standard Version.
341
342 b) accompany the distribution with the machine-readable source of the Package
343 with your modifications.
344
345 c) accompany any non-standard executables with their corresponding Standard
346 Version executables, giving the non-standard executables non-standard
347 names, and clearly documenting the differences in manual pages (or
348 equivalent), together with instructions on where to get the Standard
349 Version.
350
351 d) make other distribution arrangements with the Copyright Holder.
352
353 5. You may charge a reasonable copying fee for any distribution of this
354 Package. You may charge any fee you choose for support of this Package. You
355 may not charge a fee for this Package itself. However, you may distribute this
356 Package in aggregate with other (possibly commercial) programs as part of a
357 larger (possibly commercial) software distribution provided that you do not
358 advertise this Package as a product of your own.
359
360 6. The scripts and library files supplied as input to or produced as output
361 from the programs of this Package do not automatically fall under the copyright
362 of this Package, but belong to whomever generated them, and may be sold
363 commercially, and may be aggregated with this Package.
364
365 7. C or perl subroutines supplied by you and linked into this Package shall not
366 be considered part of this Package.
367
368 8. The name of the Copyright Holder may not be used to endorse or promote
369 products derived from this software without specific prior written permission.
370
371 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
372 WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
373 MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
374
375 The End
376
+33
-0
MANIFEST less more
0 Changes
1 inc/Module/AutoInstall.pm
2 inc/Module/Install.pm
3 inc/Module/Install/AutoInstall.pm
4 inc/Module/Install/AutoManifest.pm
5 inc/Module/Install/Base.pm
6 inc/Module/Install/Can.pm
7 inc/Module/Install/Fetch.pm
8 inc/Module/Install/Include.pm
9 inc/Module/Install/Makefile.pm
10 inc/Module/Install/Metadata.pm
11 inc/Module/Install/Package.pm
12 inc/Module/Install/TrustMetaYml.pm
13 inc/Module/Install/Win32.pm
14 inc/Module/Install/WriteAll.pm
15 inc/Module/Package.pm
16 inc/Module/Package/Dist/RDF.pm
17 inc/Scalar/Util.pm
18 inc/Scalar/Util/PP.pm
19 inc/YAML/Tiny.pm
20 lib/PerlX/Maybe.pm
21 lib/Syntax/Feature/Maybe.pm
22 LICENSE
23 Makefile.PL
24 MANIFEST This list of files
25 META.yml
26 meta/changes.ttl
27 meta/doap.ttl
28 meta/makefile.ttl
29 README
30 t/01basic.t
31 t/02maybe.t
32 SIGNATURE Public-key signature (added by MakeMaker)
+33
-0
META.yml less more
0 ---
1 abstract: 'return a given list only if they are all defined'
2 author:
3 - 'Toby Inkster <tobyink@cpan.org>'
4 build_requires:
5 ExtUtils::MakeMaker: 6.42
6 Test::More: 0.61
7 configure_requires:
8 ExtUtils::MakeMaker: 6.42
9 distribution_type: module
10 generated_by: 'Module::Install version 1.02'
11 keywords: []
12 license: perl
13 meta-spec:
14 url: http://module-build.sourceforge.net/META-spec-v1.4.html
15 version: 1.4
16 module_name: PerlX::Maybe
17 name: PerlX-Maybe
18 no_index:
19 directory:
20 - inc
21 - t
22 - xt
23 requires:
24 Exporter: 0
25 perl: 5.8.0
26 strict: 0
27 resources:
28 bugtracker: http://rt.cpan.org/Dist/Display.html?Queue=PerlX-Maybe
29 homepage: https://metacpan.org/release/PerlX-Maybe
30 license: http://dev.perl.org/licenses/
31 repository: https://bitbucket.org/tobyink/p5-perlx-maybe
32 version: 0.002
+2
-0
Makefile.PL less more
0 use inc::Module::Package 'RDF:standard';
1
+97
-0
README less more
0 NAME
1 PerlX::Maybe - return a pair only if they are both defined
2
3 SYNOPSIS
4 You once wrote:
5
6 my $bob = Person->new(
7 defined $name ? (name => $name) : (),
8 defined $age ? (age => $age) : (),
9 );
10
11 Now you can write:
12
13 my $bob = Person->new(
14 maybe name => $name,
15 maybe age => $age,
16 );
17
18 DESCRIPTION
19 Moose classes (and some other classes) distinguish between an attribute
20 being unset and the attribute being set to undef. Supplying a
21 constructor arguments like this:
22
23 my $bob = Person->new(
24 name => $name,
25 age => $age,
26 );
27
28 Will result in the "name" and "age" attributes possibly being set to
29 undef (if the corresponding $name and $age variables are not defined),
30 which may violate the Person class' type constraints.
31
32 (Note: if you are the *author* of the class in question, you can solve
33 this using MooseX::UndefTolerant. However, some of us are stuck using
34 non-UndefTolerant classes written by third parties.)
35
36 To ensure that the Person constructor does not try to set a name or age
37 at all when they are undefined, ugly looking code like this is often
38 used:
39
40 my $bob = Person->new(
41 defined $name ? (name => $name) : (),
42 defined $age ? (age => $age) : (),
43 );
44
45 or:
46
47 my $bob = Person->new(
48 (name => $name) x!!(defined $name),
49 (age => $age) x!!(defined $age),
50 );
51
52 A slightly more elegant solution is the "maybe" function:
53
54 "maybe $x => $y, @rest"
55 This function checks that $x and $y are both defined. If they are, it
56 returns them both as a list; otherwise it returns the empty list.
57
58 If @rest is provided, it is unconditionally appended to the end of
59 whatever list is returned.
60
61 The combination of these behaviours allows the following very sugary
62 syntax to "just work".
63
64 my $bob = Person->new(
65 name => $name,
66 address => $addr,
67 maybe phone => $tel,
68 maybe email => $email,
69 unique_id => $id,
70 );
71
72 This function is exported by default.
73
74 BUGS
75 Please report any bugs to
76 <http://rt.cpan.org/Dist/Display.html?Queue=PerlX-Maybe>.
77
78 SEE ALSO
79 Syntax::Feature::Maybe.
80
81 MooseX::UndefTolerant, PerlX::Perform, Exporter.
82
83 AUTHOR
84 Toby Inkster <tobyink@cpan.org>.
85
86 COPYRIGHT AND LICENCE
87 This software is copyright (c) 2012 by Toby Inkster.
88
89 This is free software; you can redistribute it and/or modify it under
90 the same terms as the Perl 5 programming language system itself.
91
92 DISCLAIMER OF WARRANTIES
93 THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
94 WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
95 MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
96
+55
-0
SIGNATURE less more
0 This file contains message digests of all files listed in MANIFEST,
1 signed via the Module::Signature module, version 0.66.
2
3 To verify the content in this distribution, first make sure you have
4 Module::Signature installed, then type:
5
6 % cpansign -v
7
8 It will check each file's integrity, as well as the signature's
9 validity. If "==> Signature verified OK! <==" is not displayed,
10 the distribution may already have been compromised, and you should
11 not run its Makefile.PL or Build.PL.
12
13 -----BEGIN PGP SIGNED MESSAGE-----
14 Hash: SHA1
15
16 SHA1 92ef62c0de13e8545a0d31f10406025371aa50ba Changes
17 SHA1 1d54db0b8134eb1c8ea0cee400f9dc612bcaa61a LICENSE
18 SHA1 cf87de9185eb4d8409344c716b72930449430a1d MANIFEST
19 SHA1 9b5306cfd14416ef353fb8a78154b453cb3f008e META.yml
20 SHA1 7150e5e086ef493e1e527a1eeec44a8344b80db6 Makefile.PL
21 SHA1 da978d574620c957831376dbe75cd0a699b983d8 README
22 SHA1 5d94bc10deff1dd74e4bc5dfa6fc015e39271f15 inc/Module/AutoInstall.pm
23 SHA1 40106479d4e07f379cb82ca1d69fca92e3a40f47 inc/Module/Install.pm
24 SHA1 34a24a530ecf0365cc02e4150b06c9bed702a441 inc/Module/Install/AutoInstall.pm
25 SHA1 c04f94f91fa97b9f8cfb5a36071098ab0e6c78e3 inc/Module/Install/AutoManifest.pm
26 SHA1 ae8aa01a73cb83da31c39e8eed1120c59cb530a1 inc/Module/Install/Base.pm
27 SHA1 5c87d2d0e2c08b5173259006c88ad81c24303f9d inc/Module/Install/Can.pm
28 SHA1 98daf9d8c50b4b7e8988cf1fa2b86044ad219533 inc/Module/Install/Fetch.pm
29 SHA1 f3e008113f7f49b0625083b6cc358a312854f613 inc/Module/Install/Include.pm
30 SHA1 e67589fcbacdda6c98ff34d8e26a004ab0467bdc inc/Module/Install/Makefile.pm
31 SHA1 209ea405d4ab94475661bb450d0ea042d2ec25b5 inc/Module/Install/Metadata.pm
32 SHA1 3b9281ddf7dd6d6f5de0a9642c69333023193c80 inc/Module/Install/Package.pm
33 SHA1 b86d0385e10881db680d28bde94f275e49e34a27 inc/Module/Install/TrustMetaYml.pm
34 SHA1 1326052d1df1065debee74f9d8583a734b9b3d00 inc/Module/Install/Win32.pm
35 SHA1 bb607f3715c40fc3bc1c46496587cdb215bc4fa2 inc/Module/Install/WriteAll.pm
36 SHA1 26d58a041cd6b3d21db98b32e8fd1841aae21204 inc/Module/Package.pm
37 SHA1 6b807287940754cc31a3db59f2b22e363d5525be inc/Module/Package/Dist/RDF.pm
38 SHA1 e31c281782183601e1e057c5914f63269e043932 inc/Scalar/Util.pm
39 SHA1 5eae2f71c45a996a296d2445b18d0589307111f0 inc/Scalar/Util/PP.pm
40 SHA1 eef6bff62046bff2ce08ba132d0b58fba30f40b4 inc/YAML/Tiny.pm
41 SHA1 03d73a6ec001330a0caafeef4e1aa5b2c013d934 lib/PerlX/Maybe.pm
42 SHA1 dbab1703220f624dec03528977fe5ccb76e708a7 lib/Syntax/Feature/Maybe.pm
43 SHA1 ad2bfe18cd3501353c1bc805692549dc31507d3c meta/changes.ttl
44 SHA1 4615287be6141b45a1f5466d1316f0ee77f89fd0 meta/doap.ttl
45 SHA1 21b1360a6a156c4deafd2eab8a4e8b686af8b310 meta/makefile.ttl
46 SHA1 0eda281cd41c7bfa28293ff92f8599deb2f9e288 t/01basic.t
47 SHA1 3079896117a38ecef4125ac9756cb2d665434bea t/02maybe.t
48 -----BEGIN PGP SIGNATURE-----
49 Version: GnuPG v1.4.10 (GNU/Linux)
50
51 iEYEARECAAYFAk+iR1oACgkQzr+BKGoqfTlp1wCdGZ9q8phvamW03KjFUPtm2dtD
52 CEMAoJixIRK0Y0ebLz4YLYIxM5TtrPx4
53 =oOf5
54 -----END PGP SIGNATURE-----
+915
-0
inc/Module/AutoInstall.pm less more
0 #line 1
1 package Module::AutoInstall;
2
3 use strict;
4 use Cwd ();
5 use ExtUtils::MakeMaker ();
6
7 use vars qw{$VERSION};
8 BEGIN {
9 $VERSION = '1.03';
10 }
11
12 # special map on pre-defined feature sets
13 my %FeatureMap = (
14 '' => 'Core Features', # XXX: deprecated
15 '-core' => 'Core Features',
16 );
17
18 # various lexical flags
19 my ( @Missing, @Existing, %DisabledTests, $UnderCPAN, $InstallDepsTarget, $HasCPANPLUS );
20 my (
21 $Config, $CheckOnly, $SkipInstall, $AcceptDefault, $TestOnly, $AllDeps,
22 $UpgradeDeps
23 );
24 my ( $PostambleActions, $PostambleActionsNoTest, $PostambleActionsUpgradeDeps,
25 $PostambleActionsUpgradeDepsNoTest, $PostambleActionsListDeps,
26 $PostambleActionsListAllDeps, $PostambleUsed, $NoTest);
27
28 # See if it's a testing or non-interactive session
29 _accept_default( $ENV{AUTOMATED_TESTING} or ! -t STDIN );
30 _init();
31
32 sub _accept_default {
33 $AcceptDefault = shift;
34 }
35
36 sub _installdeps_target {
37 $InstallDepsTarget = shift;
38 }
39
40 sub missing_modules {
41 return @Missing;
42 }
43
44 sub do_install {
45 __PACKAGE__->install(
46 [
47 $Config
48 ? ( UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
49 : ()
50 ],
51 @Missing,
52 );
53 }
54
55 # initialize various flags, and/or perform install
56 sub _init {
57 foreach my $arg (
58 @ARGV,
59 split(
60 /[\s\t]+/,
61 $ENV{PERL_AUTOINSTALL} || $ENV{PERL_EXTUTILS_AUTOINSTALL} || ''
62 )
63 )
64 {
65 if ( $arg =~ /^--config=(.*)$/ ) {
66 $Config = [ split( ',', $1 ) ];
67 }
68 elsif ( $arg =~ /^--installdeps=(.*)$/ ) {
69 __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
70 exit 0;
71 }
72 elsif ( $arg =~ /^--upgradedeps=(.*)$/ ) {
73 $UpgradeDeps = 1;
74 __PACKAGE__->install( $Config, @Missing = split( /,/, $1 ) );
75 exit 0;
76 }
77 elsif ( $arg =~ /^--default(?:deps)?$/ ) {
78 $AcceptDefault = 1;
79 }
80 elsif ( $arg =~ /^--check(?:deps)?$/ ) {
81 $CheckOnly = 1;
82 }
83 elsif ( $arg =~ /^--skip(?:deps)?$/ ) {
84 $SkipInstall = 1;
85 }
86 elsif ( $arg =~ /^--test(?:only)?$/ ) {
87 $TestOnly = 1;
88 }
89 elsif ( $arg =~ /^--all(?:deps)?$/ ) {
90 $AllDeps = 1;
91 }
92 }
93 }
94
95 # overrides MakeMaker's prompt() to automatically accept the default choice
96 sub _prompt {
97 goto &ExtUtils::MakeMaker::prompt unless $AcceptDefault;
98
99 my ( $prompt, $default ) = @_;
100 my $y = ( $default =~ /^[Yy]/ );
101
102 print $prompt, ' [', ( $y ? 'Y' : 'y' ), '/', ( $y ? 'n' : 'N' ), '] ';
103 print "$default\n";
104 return $default;
105 }
106
107 # the workhorse
108 sub import {
109 my $class = shift;
110 my @args = @_ or return;
111 my $core_all;
112
113 print "*** $class version " . $class->VERSION . "\n";
114 print "*** Checking for Perl dependencies...\n";
115
116 my $cwd = Cwd::cwd();
117
118 $Config = [];
119
120 my $maxlen = length(
121 (
122 sort { length($b) <=> length($a) }
123 grep { /^[^\-]/ }
124 map {
125 ref($_)
126 ? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
127 : ''
128 }
129 map { +{@args}->{$_} }
130 grep { /^[^\-]/ or /^-core$/i } keys %{ +{@args} }
131 )[0]
132 );
133
134 # We want to know if we're under CPAN early to avoid prompting, but
135 # if we aren't going to try and install anything anyway then skip the
136 # check entirely since we don't want to have to load (and configure)
137 # an old CPAN just for a cosmetic message
138
139 $UnderCPAN = _check_lock(1) unless $SkipInstall || $InstallDepsTarget;
140
141 while ( my ( $feature, $modules ) = splice( @args, 0, 2 ) ) {
142 my ( @required, @tests, @skiptests );
143 my $default = 1;
144 my $conflict = 0;
145
146 if ( $feature =~ m/^-(\w+)$/ ) {
147 my $option = lc($1);
148
149 # check for a newer version of myself
150 _update_to( $modules, @_ ) and return if $option eq 'version';
151
152 # sets CPAN configuration options
153 $Config = $modules if $option eq 'config';
154
155 # promote every features to core status
156 $core_all = ( $modules =~ /^all$/i ) and next
157 if $option eq 'core';
158
159 next unless $option eq 'core';
160 }
161
162 print "[" . ( $FeatureMap{ lc($feature) } || $feature ) . "]\n";
163
164 $modules = [ %{$modules} ] if UNIVERSAL::isa( $modules, 'HASH' );
165
166 unshift @$modules, -default => &{ shift(@$modules) }
167 if ( ref( $modules->[0] ) eq 'CODE' ); # XXX: bugward combatability
168
169 while ( my ( $mod, $arg ) = splice( @$modules, 0, 2 ) ) {
170 if ( $mod =~ m/^-(\w+)$/ ) {
171 my $option = lc($1);
172
173 $default = $arg if ( $option eq 'default' );
174 $conflict = $arg if ( $option eq 'conflict' );
175 @tests = @{$arg} if ( $option eq 'tests' );
176 @skiptests = @{$arg} if ( $option eq 'skiptests' );
177
178 next;
179 }
180
181 printf( "- %-${maxlen}s ...", $mod );
182
183 if ( $arg and $arg =~ /^\D/ ) {
184 unshift @$modules, $arg;
185 $arg = 0;
186 }
187
188 # XXX: check for conflicts and uninstalls(!) them.
189 my $cur = _load($mod);
190 if (_version_cmp ($cur, $arg) >= 0)
191 {
192 print "loaded. ($cur" . ( $arg ? " >= $arg" : '' ) . ")\n";
193 push @Existing, $mod => $arg;
194 $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
195 }
196 else {
197 if (not defined $cur) # indeed missing
198 {
199 print "missing." . ( $arg ? " (would need $arg)" : '' ) . "\n";
200 }
201 else
202 {
203 # no need to check $arg as _version_cmp ($cur, undef) would satisfy >= above
204 print "too old. ($cur < $arg)\n";
205 }
206
207 push @required, $mod => $arg;
208 }
209 }
210
211 next unless @required;
212
213 my $mandatory = ( $feature eq '-core' or $core_all );
214
215 if (
216 !$SkipInstall
217 and (
218 $CheckOnly
219 or ($mandatory and $UnderCPAN)
220 or $AllDeps
221 or $InstallDepsTarget
222 or _prompt(
223 qq{==> Auto-install the }
224 . ( @required / 2 )
225 . ( $mandatory ? ' mandatory' : ' optional' )
226 . qq{ module(s) from CPAN?},
227 $default ? 'y' : 'n',
228 ) =~ /^[Yy]/
229 )
230 )
231 {
232 push( @Missing, @required );
233 $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
234 }
235
236 elsif ( !$SkipInstall
237 and $default
238 and $mandatory
239 and
240 _prompt( qq{==> The module(s) are mandatory! Really skip?}, 'n', )
241 =~ /^[Nn]/ )
242 {
243 push( @Missing, @required );
244 $DisabledTests{$_} = 1 for map { glob($_) } @skiptests;
245 }
246
247 else {
248 $DisabledTests{$_} = 1 for map { glob($_) } @tests;
249 }
250 }
251
252 if ( @Missing and not( $CheckOnly or $UnderCPAN) ) {
253 require Config;
254 my $make = $Config::Config{make};
255 if ($InstallDepsTarget) {
256 print
257 "*** To install dependencies type '$make installdeps' or '$make installdeps_notest'.\n";
258 }
259 else {
260 print
261 "*** Dependencies will be installed the next time you type '$make'.\n";
262 }
263
264 # make an educated guess of whether we'll need root permission.
265 print " (You may need to do that as the 'root' user.)\n"
266 if eval '$>';
267 }
268 print "*** $class configuration finished.\n";
269
270 chdir $cwd;
271
272 # import to main::
273 no strict 'refs';
274 *{'main::WriteMakefile'} = \&Write if caller(0) eq 'main';
275
276 return (@Existing, @Missing);
277 }
278
279 sub _running_under {
280 my $thing = shift;
281 print <<"END_MESSAGE";
282 *** Since we're running under ${thing}, I'll just let it take care
283 of the dependency's installation later.
284 END_MESSAGE
285 return 1;
286 }
287
288 # Check to see if we are currently running under CPAN.pm and/or CPANPLUS;
289 # if we are, then we simply let it taking care of our dependencies
290 sub _check_lock {
291 return unless @Missing or @_;
292
293 if ($ENV{PERL5_CPANM_IS_RUNNING}) {
294 return _running_under('cpanminus');
295 }
296
297 my $cpan_env = $ENV{PERL5_CPAN_IS_RUNNING};
298
299 if ($ENV{PERL5_CPANPLUS_IS_RUNNING}) {
300 return _running_under($cpan_env ? 'CPAN' : 'CPANPLUS');
301 }
302
303 require CPAN;
304
305 if ($CPAN::VERSION > '1.89') {
306 if ($cpan_env) {
307 return _running_under('CPAN');
308 }
309 return; # CPAN.pm new enough, don't need to check further
310 }
311
312 # last ditch attempt, this -will- configure CPAN, very sorry
313
314 _load_cpan(1); # force initialize even though it's already loaded
315
316 # Find the CPAN lock-file
317 my $lock = MM->catfile( $CPAN::Config->{cpan_home}, ".lock" );
318 return unless -f $lock;
319
320 # Check the lock
321 local *LOCK;
322 return unless open(LOCK, $lock);
323
324 if (
325 ( $^O eq 'MSWin32' ? _under_cpan() : <LOCK> == getppid() )
326 and ( $CPAN::Config->{prerequisites_policy} || '' ) ne 'ignore'
327 ) {
328 print <<'END_MESSAGE';
329
330 *** Since we're running under CPAN, I'll just let it take care
331 of the dependency's installation later.
332 END_MESSAGE
333 return 1;
334 }
335
336 close LOCK;
337 return;
338 }
339
340 sub install {
341 my $class = shift;
342
343 my $i; # used below to strip leading '-' from config keys
344 my @config = ( map { s/^-// if ++$i; $_ } @{ +shift } );
345
346 my ( @modules, @installed );
347 while ( my ( $pkg, $ver ) = splice( @_, 0, 2 ) ) {
348
349 # grep out those already installed
350 if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
351 push @installed, $pkg;
352 }
353 else {
354 push @modules, $pkg, $ver;
355 }
356 }
357
358 if ($UpgradeDeps) {
359 push @modules, @installed;
360 @installed = ();
361 }
362
363 return @installed unless @modules; # nothing to do
364 return @installed if _check_lock(); # defer to the CPAN shell
365
366 print "*** Installing dependencies...\n";
367
368 return unless _connected_to('cpan.org');
369
370 my %args = @config;
371 my %failed;
372 local *FAILED;
373 if ( $args{do_once} and open( FAILED, '.#autoinstall.failed' ) ) {
374 while (<FAILED>) { chomp; $failed{$_}++ }
375 close FAILED;
376
377 my @newmod;
378 while ( my ( $k, $v ) = splice( @modules, 0, 2 ) ) {
379 push @newmod, ( $k => $v ) unless $failed{$k};
380 }
381 @modules = @newmod;
382 }
383
384 if ( _has_cpanplus() and not $ENV{PERL_AUTOINSTALL_PREFER_CPAN} ) {
385 _install_cpanplus( \@modules, \@config );
386 } else {
387 _install_cpan( \@modules, \@config );
388 }
389
390 print "*** $class installation finished.\n";
391
392 # see if we have successfully installed them
393 while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
394 if ( _version_cmp( _load($pkg), $ver ) >= 0 ) {
395 push @installed, $pkg;
396 }
397 elsif ( $args{do_once} and open( FAILED, '>> .#autoinstall.failed' ) ) {
398 print FAILED "$pkg\n";
399 }
400 }
401
402 close FAILED if $args{do_once};
403
404 return @installed;
405 }
406
407 sub _install_cpanplus {
408 my @modules = @{ +shift };
409 my @config = _cpanplus_config( @{ +shift } );
410 my $installed = 0;
411
412 require CPANPLUS::Backend;
413 my $cp = CPANPLUS::Backend->new;
414 my $conf = $cp->configure_object;
415
416 return unless $conf->can('conf') # 0.05x+ with "sudo" support
417 or _can_write($conf->_get_build('base')); # 0.04x
418
419 # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
420 my $makeflags = $conf->get_conf('makeflags') || '';
421 if ( UNIVERSAL::isa( $makeflags, 'HASH' ) ) {
422 # 0.03+ uses a hashref here
423 $makeflags->{UNINST} = 1 unless exists $makeflags->{UNINST};
424
425 } else {
426 # 0.02 and below uses a scalar
427 $makeflags = join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
428 if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
429
430 }
431 $conf->set_conf( makeflags => $makeflags );
432 $conf->set_conf( prereqs => 1 );
433
434
435
436 while ( my ( $key, $val ) = splice( @config, 0, 2 ) ) {
437 $conf->set_conf( $key, $val );
438 }
439
440 my $modtree = $cp->module_tree;
441 while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
442 print "*** Installing $pkg...\n";
443
444 MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
445
446 my $success;
447 my $obj = $modtree->{$pkg};
448
449 if ( $obj and _version_cmp( $obj->{version}, $ver ) >= 0 ) {
450 my $pathname = $pkg;
451 $pathname =~ s/::/\\W/;
452
453 foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
454 delete $INC{$inc};
455 }
456
457 my $rv = $cp->install( modules => [ $obj->{module} ] );
458
459 if ( $rv and ( $rv->{ $obj->{module} } or $rv->{ok} ) ) {
460 print "*** $pkg successfully installed.\n";
461 $success = 1;
462 } else {
463 print "*** $pkg installation cancelled.\n";
464 $success = 0;
465 }
466
467 $installed += $success;
468 } else {
469 print << ".";
470 *** Could not find a version $ver or above for $pkg; skipping.
471 .
472 }
473
474 MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
475 }
476
477 return $installed;
478 }
479
480 sub _cpanplus_config {
481 my @config = ();
482 while ( @_ ) {
483 my ($key, $value) = (shift(), shift());
484 if ( $key eq 'prerequisites_policy' ) {
485 if ( $value eq 'follow' ) {
486 $value = CPANPLUS::Internals::Constants::PREREQ_INSTALL();
487 } elsif ( $value eq 'ask' ) {
488 $value = CPANPLUS::Internals::Constants::PREREQ_ASK();
489 } elsif ( $value eq 'ignore' ) {
490 $value = CPANPLUS::Internals::Constants::PREREQ_IGNORE();
491 } else {
492 die "*** Cannot convert option $key = '$value' to CPANPLUS version.\n";
493 }
494 push @config, 'prereqs', $value;
495 } elsif ( $key eq 'force' ) {
496 push @config, $key, $value;
497 } elsif ( $key eq 'notest' ) {
498 push @config, 'skiptest', $value;
499 } else {
500 die "*** Cannot convert option $key to CPANPLUS version.\n";
501 }
502 }
503 return @config;
504 }
505
506 sub _install_cpan {
507 my @modules = @{ +shift };
508 my @config = @{ +shift };
509 my $installed = 0;
510 my %args;
511
512 _load_cpan();
513 require Config;
514
515 if (CPAN->VERSION < 1.80) {
516 # no "sudo" support, probe for writableness
517 return unless _can_write( MM->catfile( $CPAN::Config->{cpan_home}, 'sources' ) )
518 and _can_write( $Config::Config{sitelib} );
519 }
520
521 # if we're root, set UNINST=1 to avoid trouble unless user asked for it.
522 my $makeflags = $CPAN::Config->{make_install_arg} || '';
523 $CPAN::Config->{make_install_arg} =
524 join( ' ', split( ' ', $makeflags ), 'UNINST=1' )
525 if ( $makeflags !~ /\bUNINST\b/ and eval qq{ $> eq '0' } );
526
527 # don't show start-up info
528 $CPAN::Config->{inhibit_startup_message} = 1;
529
530 # set additional options
531 while ( my ( $opt, $arg ) = splice( @config, 0, 2 ) ) {
532 ( $args{$opt} = $arg, next )
533 if $opt =~ /^(?:force|notest)$/; # pseudo-option
534 $CPAN::Config->{$opt} = $arg;
535 }
536
537 if ($args{notest} && (not CPAN::Shell->can('notest'))) {
538 die "Your version of CPAN is too old to support the 'notest' pragma";
539 }
540
541 local $CPAN::Config->{prerequisites_policy} = 'follow';
542
543 while ( my ( $pkg, $ver ) = splice( @modules, 0, 2 ) ) {
544 MY::preinstall( $pkg, $ver ) or next if defined &MY::preinstall;
545
546 print "*** Installing $pkg...\n";
547
548 my $obj = CPAN::Shell->expand( Module => $pkg );
549 my $success = 0;
550
551 if ( $obj and _version_cmp( $obj->cpan_version, $ver ) >= 0 ) {
552 my $pathname = $pkg;
553 $pathname =~ s/::/\\W/;
554
555 foreach my $inc ( grep { m/$pathname.pm/i } keys(%INC) ) {
556 delete $INC{$inc};
557 }
558
559 my $rv = do {
560 if ($args{force}) {
561 CPAN::Shell->force( install => $pkg )
562 } elsif ($args{notest}) {
563 CPAN::Shell->notest( install => $pkg )
564 } else {
565 CPAN::Shell->install($pkg)
566 }
567 };
568
569 $rv ||= eval {
570 $CPAN::META->instance( 'CPAN::Distribution', $obj->cpan_file, )
571 ->{install}
572 if $CPAN::META;
573 };
574
575 if ( $rv eq 'YES' ) {
576 print "*** $pkg successfully installed.\n";
577 $success = 1;
578 }
579 else {
580 print "*** $pkg installation failed.\n";
581 $success = 0;
582 }
583
584 $installed += $success;
585 }
586 else {
587 print << ".";
588 *** Could not find a version $ver or above for $pkg; skipping.
589 .
590 }
591
592 MY::postinstall( $pkg, $ver, $success ) if defined &MY::postinstall;
593 }
594
595 return $installed;
596 }
597
598 sub _has_cpanplus {
599 return (
600 $HasCPANPLUS = (
601 $INC{'CPANPLUS/Config.pm'}
602 or _load('CPANPLUS::Shell::Default')
603 )
604 );
605 }
606
607 # make guesses on whether we're under the CPAN installation directory
608 sub _under_cpan {
609 require Cwd;
610 require File::Spec;
611
612 my $cwd = File::Spec->canonpath( Cwd::cwd() );
613 my $cpan = File::Spec->canonpath( $CPAN::Config->{cpan_home} );
614
615 return ( index( $cwd, $cpan ) > -1 );
616 }
617
618 sub _update_to {
619 my $class = __PACKAGE__;
620 my $ver = shift;
621
622 return
623 if _version_cmp( _load($class), $ver ) >= 0; # no need to upgrade
624
625 if (
626 _prompt( "==> A newer version of $class ($ver) is required. Install?",
627 'y' ) =~ /^[Nn]/
628 )
629 {
630 die "*** Please install $class $ver manually.\n";
631 }
632
633 print << ".";
634 *** Trying to fetch it from CPAN...
635 .
636
637 # install ourselves
638 _load($class) and return $class->import(@_)
639 if $class->install( [], $class, $ver );
640
641 print << '.'; exit 1;
642
643 *** Cannot bootstrap myself. :-( Installation terminated.
644 .
645 }
646
647 # check if we're connected to some host, using inet_aton
648 sub _connected_to {
649 my $site = shift;
650
651 return (
652 ( _load('Socket') and Socket::inet_aton($site) ) or _prompt(
653 qq(
654 *** Your host cannot resolve the domain name '$site', which
655 probably means the Internet connections are unavailable.
656 ==> Should we try to install the required module(s) anyway?), 'n'
657 ) =~ /^[Yy]/
658 );
659 }
660
661 # check if a directory is writable; may create it on demand
662 sub _can_write {
663 my $path = shift;
664 mkdir( $path, 0755 ) unless -e $path;
665
666 return 1 if -w $path;
667
668 print << ".";
669 *** You are not allowed to write to the directory '$path';
670 the installation may fail due to insufficient permissions.
671 .
672
673 if (
674 eval '$>' and lc(`sudo -V`) =~ /version/ and _prompt(
675 qq(
676 ==> Should we try to re-execute the autoinstall process with 'sudo'?),
677 ((-t STDIN) ? 'y' : 'n')
678 ) =~ /^[Yy]/
679 )
680 {
681
682 # try to bootstrap ourselves from sudo
683 print << ".";
684 *** Trying to re-execute the autoinstall process with 'sudo'...
685 .
686 my $missing = join( ',', @Missing );
687 my $config = join( ',',
688 UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
689 if $Config;
690
691 return
692 unless system( 'sudo', $^X, $0, "--config=$config",
693 "--installdeps=$missing" );
694
695 print << ".";
696 *** The 'sudo' command exited with error! Resuming...
697 .
698 }
699
700 return _prompt(
701 qq(
702 ==> Should we try to install the required module(s) anyway?), 'n'
703 ) =~ /^[Yy]/;
704 }
705
706 # load a module and return the version it reports
707 sub _load {
708 my $mod = pop; # class/instance doesn't matter
709 my $file = $mod;
710
711 $file =~ s|::|/|g;
712 $file .= '.pm';
713
714 local $@;
715 return eval { require $file; $mod->VERSION } || ( $@ ? undef: 0 );
716 }
717
718 # Load CPAN.pm and it's configuration
719 sub _load_cpan {
720 return if $CPAN::VERSION and $CPAN::Config and not @_;
721 require CPAN;
722
723 # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to
724 # CPAN::HandleConfig->load. CPAN reports that the redirection
725 # is deprecated in a warning printed at the user.
726
727 # CPAN-1.81 expects CPAN::HandleConfig->load, does not have
728 # $CPAN::HandleConfig::VERSION but cannot handle
729 # CPAN::Config->load
730
731 # Which "versions expect CPAN::Config->load?
732
733 if ( $CPAN::HandleConfig::VERSION
734 || CPAN::HandleConfig->can('load')
735 ) {
736 # Newer versions of CPAN have a HandleConfig module
737 CPAN::HandleConfig->load;
738 } else {
739 # Older versions had the load method in Config directly
740 CPAN::Config->load;
741 }
742 }
743
744 # compare two versions, either use Sort::Versions or plain comparison
745 # return values same as <=>
746 sub _version_cmp {
747 my ( $cur, $min ) = @_;
748 return -1 unless defined $cur; # if 0 keep comparing
749 return 1 unless $min;
750
751 $cur =~ s/\s+$//;
752
753 # check for version numbers that are not in decimal format
754 if ( ref($cur) or ref($min) or $cur =~ /v|\..*\./ or $min =~ /v|\..*\./ ) {
755 if ( ( $version::VERSION or defined( _load('version') )) and
756 version->can('new')
757 ) {
758
759 # use version.pm if it is installed.
760 return version->new($cur) <=> version->new($min);
761 }
762 elsif ( $Sort::Versions::VERSION or defined( _load('Sort::Versions') ) )
763 {
764
765 # use Sort::Versions as the sorting algorithm for a.b.c versions
766 return Sort::Versions::versioncmp( $cur, $min );
767 }
768
769 warn "Cannot reliably compare non-decimal formatted versions.\n"
770 . "Please install version.pm or Sort::Versions.\n";
771 }
772
773 # plain comparison
774 local $^W = 0; # shuts off 'not numeric' bugs
775 return $cur <=> $min;
776 }
777
778 # nothing; this usage is deprecated.
779 sub main::PREREQ_PM { return {}; }
780
781 sub _make_args {
782 my %args = @_;
783
784 $args{PREREQ_PM} = { %{ $args{PREREQ_PM} || {} }, @Existing, @Missing }
785 if $UnderCPAN or $TestOnly;
786
787 if ( $args{EXE_FILES} and -e 'MANIFEST' ) {
788 require ExtUtils::Manifest;
789 my $manifest = ExtUtils::Manifest::maniread('MANIFEST');
790
791 $args{EXE_FILES} =
792 [ grep { exists $manifest->{$_} } @{ $args{EXE_FILES} } ];
793 }
794
795 $args{test}{TESTS} ||= 't/*.t';
796 $args{test}{TESTS} = join( ' ',
797 grep { !exists( $DisabledTests{$_} ) }
798 map { glob($_) } split( /\s+/, $args{test}{TESTS} ) );
799
800 my $missing = join( ',', @Missing );
801 my $config =
802 join( ',', UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config} )
803 if $Config;
804
805 $PostambleActions = (
806 ($missing and not $UnderCPAN)
807 ? "\$(PERL) $0 --config=$config --installdeps=$missing"
808 : "\$(NOECHO) \$(NOOP)"
809 );
810
811 my $deps_list = join( ',', @Missing, @Existing );
812
813 $PostambleActionsUpgradeDeps =
814 "\$(PERL) $0 --config=$config --upgradedeps=$deps_list";
815
816 my $config_notest =
817 join( ',', (UNIVERSAL::isa( $Config, 'HASH' ) ? %{$Config} : @{$Config}),
818 'notest', 1 )
819 if $Config;
820
821 $PostambleActionsNoTest = (
822 ($missing and not $UnderCPAN)
823 ? "\$(PERL) $0 --config=$config_notest --installdeps=$missing"
824 : "\$(NOECHO) \$(NOOP)"
825 );
826
827 $PostambleActionsUpgradeDepsNoTest =
828 "\$(PERL) $0 --config=$config_notest --upgradedeps=$deps_list";
829
830 $PostambleActionsListDeps =
831 '@$(PERL) -le "print for @ARGV" '
832 . join(' ', map $Missing[$_], grep $_ % 2 == 0, 0..$#Missing);
833
834 my @all = (@Missing, @Existing);
835
836 $PostambleActionsListAllDeps =
837 '@$(PERL) -le "print for @ARGV" '
838 . join(' ', map $all[$_], grep $_ % 2 == 0, 0..$#all);
839
840 return %args;
841 }
842
843 # a wrapper to ExtUtils::MakeMaker::WriteMakefile
844 sub Write {
845 require Carp;
846 Carp::croak "WriteMakefile: Need even number of args" if @_ % 2;
847
848 if ($CheckOnly) {
849 print << ".";
850 *** Makefile not written in check-only mode.
851 .
852 return;
853 }
854
855 my %args = _make_args(@_);
856
857 no strict 'refs';
858
859 $PostambleUsed = 0;
860 local *MY::postamble = \&postamble unless defined &MY::postamble;
861 ExtUtils::MakeMaker::WriteMakefile(%args);
862
863 print << "." unless $PostambleUsed;
864 *** WARNING: Makefile written with customized MY::postamble() without
865 including contents from Module::AutoInstall::postamble() --
866 auto installation features disabled. Please contact the author.
867 .
868
869 return 1;
870 }
871
872 sub postamble {
873 $PostambleUsed = 1;
874 my $fragment;
875
876 $fragment .= <<"AUTO_INSTALL" if !$InstallDepsTarget;
877
878 config :: installdeps
879 \t\$(NOECHO) \$(NOOP)
880 AUTO_INSTALL
881
882 $fragment .= <<"END_MAKE";
883
884 checkdeps ::
885 \t\$(PERL) $0 --checkdeps
886
887 installdeps ::
888 \t$PostambleActions
889
890 installdeps_notest ::
891 \t$PostambleActionsNoTest
892
893 upgradedeps ::
894 \t$PostambleActionsUpgradeDeps
895
896 upgradedeps_notest ::
897 \t$PostambleActionsUpgradeDepsNoTest
898
899 listdeps ::
900 \t$PostambleActionsListDeps
901
902 listalldeps ::
903 \t$PostambleActionsListAllDeps
904
905 END_MAKE
906
907 return $fragment;
908 }
909
910 1;
911
912 __END__
913
914 #line 1178
+93
-0
inc/Module/Install/AutoInstall.pm less more
0 #line 1
1 package Module::Install::AutoInstall;
2
3 use strict;
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.02';
9 @ISA = 'Module::Install::Base';
10 $ISCORE = 1;
11 }
12
13 sub AutoInstall { $_[0] }
14
15 sub run {
16 my $self = shift;
17 $self->auto_install_now(@_);
18 }
19
20 sub write {
21 my $self = shift;
22 $self->auto_install(@_);
23 }
24
25 sub auto_install {
26 my $self = shift;
27 return if $self->{done}++;
28
29 # Flatten array of arrays into a single array
30 my @core = map @$_, map @$_, grep ref,
31 $self->build_requires, $self->requires;
32
33 my @config = @_;
34
35 # We'll need Module::AutoInstall
36 $self->include('Module::AutoInstall');
37 require Module::AutoInstall;
38
39 my @features_require = Module::AutoInstall->import(
40 (@config ? (-config => \@config) : ()),
41 (@core ? (-core => \@core) : ()),
42 $self->features,
43 );
44
45 my %seen;
46 my @requires = map @$_, map @$_, grep ref, $self->requires;
47 while (my ($mod, $ver) = splice(@requires, 0, 2)) {
48 $seen{$mod}{$ver}++;
49 }
50 my @build_requires = map @$_, map @$_, grep ref, $self->build_requires;
51 while (my ($mod, $ver) = splice(@build_requires, 0, 2)) {
52 $seen{$mod}{$ver}++;
53 }
54 my @configure_requires = map @$_, map @$_, grep ref, $self->configure_requires;
55 while (my ($mod, $ver) = splice(@configure_requires, 0, 2)) {
56 $seen{$mod}{$ver}++;
57 }
58
59 my @deduped;
60 while (my ($mod, $ver) = splice(@features_require, 0, 2)) {
61 push @deduped, $mod => $ver unless $seen{$mod}{$ver}++;
62 }
63
64 $self->requires(@deduped);
65
66 $self->makemaker_args( Module::AutoInstall::_make_args() );
67
68 my $class = ref($self);
69 $self->postamble(
70 "# --- $class section:\n" .
71 Module::AutoInstall::postamble()
72 );
73 }
74
75 sub installdeps_target {
76 my ($self, @args) = @_;
77
78 $self->include('Module::AutoInstall');
79 require Module::AutoInstall;
80
81 Module::AutoInstall::_installdeps_target(1);
82
83 $self->auto_install(@args);
84 }
85
86 sub auto_install_now {
87 my $self = shift;
88 $self->auto_install(@_);
89 Module::AutoInstall::do_install();
90 }
91
92 1;
+45
-0
inc/Module/Install/AutoManifest.pm less more
0 #line 1
1 use strict;
2 use warnings;
3
4 package Module::Install::AutoManifest;
5
6 use Module::Install::Base;
7
8 BEGIN {
9 our $VERSION = '0.003';
10 our $ISCORE = 1;
11 our @ISA = qw(Module::Install::Base);
12 }
13
14 sub auto_manifest {
15 my ($self) = @_;
16
17 return unless $Module::Install::AUTHOR;
18
19 die "auto_manifest requested, but no MANIFEST.SKIP exists\n"
20 unless -e "MANIFEST.SKIP";
21
22 if (-e "MANIFEST") {
23 unlink('MANIFEST') or die "Can't remove MANIFEST: $!";
24 }
25
26 $self->postamble(<<"END");
27 create_distdir: manifest_clean manifest
28
29 distclean :: manifest_clean
30
31 manifest_clean:
32 \t\$(RM_F) MANIFEST
33 END
34
35 }
36
37 1;
38 __END__
39
40 #line 48
41
42 #line 131
43
44 1; # End of Module::Install::AutoManifest
+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.02';
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.02';
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.02';
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.02';
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.02';
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
+716
-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.02';
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 really 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 2\.0' => 'artistic_2', 1,
518 'Artistic license' => 'artistic', 1,
519 'Apache (?:Software )?license' => 'apache', 1,
520 'GPL' => 'gpl', 1,
521 'LGPL' => 'lgpl', 1,
522 'BSD' => 'bsd', 1,
523 'Artistic' => 'artistic', 1,
524 'MIT' => 'mit', 1,
525 'Mozilla Public License' => 'mozilla', 1,
526 'Q Public License' => 'open_source', 1,
527 'OpenSSL License' => 'unrestricted', 1,
528 'SSLeay License' => 'unrestricted', 1,
529 'zlib License' => 'open_source', 1,
530 'proprietary' => 'proprietary', 0,
531 );
532 while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
533 $pattern =~ s#\s+#\\s+#gs;
534 if ( $license_text =~ /\b$pattern\b/i ) {
535 return $license;
536 }
537 }
538 return '';
539 }
540
541 sub license_from {
542 my $self = shift;
543 if (my $license=_extract_license(Module::Install::_read($_[0]))) {
544 $self->license($license);
545 } else {
546 warn "Cannot determine license info from $_[0]\n";
547 return 'unknown';
548 }
549 }
550
551 sub _extract_bugtracker {
552 my @links = $_[0] =~ m#L<(
553 https?\Q://rt.cpan.org/\E[^>]+|
554 https?\Q://github.com/\E[\w_]+/[\w_]+/issues|
555 https?\Q://code.google.com/p/\E[\w_\-]+/issues/list
556 )>#gx;
557 my %links;
558 @links{@links}=();
559 @links=keys %links;
560 return @links;
561 }
562
563 sub bugtracker_from {
564 my $self = shift;
565 my $content = Module::Install::_read($_[0]);
566 my @links = _extract_bugtracker($content);
567 unless ( @links ) {
568 warn "Cannot determine bugtracker info from $_[0]\n";
569 return 0;
570 }
571 if ( @links > 1 ) {
572 warn "Found more than one bugtracker link in $_[0]\n";
573 return 0;
574 }
575
576 # Set the bugtracker
577 bugtracker( $links[0] );
578 return 1;
579 }
580
581 sub requires_from {
582 my $self = shift;
583 my $content = Module::Install::_readperl($_[0]);
584 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg;
585 while ( @requires ) {
586 my $module = shift @requires;
587 my $version = shift @requires;
588 $self->requires( $module => $version );
589 }
590 }
591
592 sub test_requires_from {
593 my $self = shift;
594 my $content = Module::Install::_readperl($_[0]);
595 my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
596 while ( @requires ) {
597 my $module = shift @requires;
598 my $version = shift @requires;
599 $self->test_requires( $module => $version );
600 }
601 }
602
603 # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
604 # numbers (eg, 5.006001 or 5.008009).
605 # Also, convert double-part versions (eg, 5.8)
606 sub _perl_version {
607 my $v = $_[-1];
608 $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
609 $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
610 $v =~ s/(\.\d\d\d)000$/$1/;
611 $v =~ s/_.+$//;
612 if ( ref($v) ) {
613 # Numify
614 $v = $v + 0;
615 }
616 return $v;
617 }
618
619 sub add_metadata {
620 my $self = shift;
621 my %hash = @_;
622 for my $key (keys %hash) {
623 warn "add_metadata: $key is not prefixed with 'x_'.\n" .
624 "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/;
625 $self->{values}->{$key} = $hash{$key};
626 }
627 }
628
629
630 ######################################################################
631 # MYMETA Support
632
633 sub WriteMyMeta {
634 die "WriteMyMeta has been deprecated";
635 }
636
637 sub write_mymeta_yaml {
638 my $self = shift;
639
640 # We need YAML::Tiny to write the MYMETA.yml file
641 unless ( eval { require YAML::Tiny; 1; } ) {
642 return 1;
643 }
644
645 # Generate the data
646 my $meta = $self->_write_mymeta_data or return 1;
647
648 # Save as the MYMETA.yml file
649 print "Writing MYMETA.yml\n";
650 YAML::Tiny::DumpFile('MYMETA.yml', $meta);
651 }
652
653 sub write_mymeta_json {
654 my $self = shift;
655
656 # We need JSON to write the MYMETA.json file
657 unless ( eval { require JSON; 1; } ) {
658 return 1;
659 }
660
661 # Generate the data
662 my $meta = $self->_write_mymeta_data or return 1;
663
664 # Save as the MYMETA.yml file
665 print "Writing MYMETA.json\n";
666 Module::Install::_write(
667 'MYMETA.json',
668 JSON->new->pretty(1)->canonical->encode($meta),
669 );
670 }
671
672 sub _write_mymeta_data {
673 my $self = shift;
674
675 # If there's no existing META.yml there is nothing we can do
676 return undef unless -f 'META.yml';
677
678 # We need Parse::CPAN::Meta to load the file
679 unless ( eval { require Parse::CPAN::Meta; 1; } ) {
680 return undef;
681 }
682
683 # Merge the perl version into the dependencies
684 my $val = $self->Meta->{values};
685 my $perl = delete $val->{perl_version};
686 if ( $perl ) {
687 $val->{requires} ||= [];
688 my $requires = $val->{requires};
689
690 # Canonize to three-dot version after Perl 5.6
691 if ( $perl >= 5.006 ) {
692 $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e
693 }
694 unshift @$requires, [ perl => $perl ];
695 }
696
697 # Load the advisory META.yml file
698 my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
699 my $meta = $yaml[0];
700
701 # Overwrite the non-configure dependency hashs
702 delete $meta->{requires};
703 delete $meta->{build_requires};
704 delete $meta->{recommends};
705 if ( exists $val->{requires} ) {
706 $meta->{requires} = { map { @$_ } @{ $val->{requires} } };
707 }
708 if ( exists $val->{build_requires} ) {
709 $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
710 }
711
712 return $meta;
713 }
714
715 1;
+323
-0
inc/Module/Install/Package.pm less more
0 #line 1
1 ##
2 # name: Module::Install::Package
3 # abstract: Module::Install support for Module::Package
4 # author: Ingy döt Net <ingy@cpan.org>
5 # license: perl
6 # copyright: 2011
7 # see:
8 # - Module::Package
9
10 # This module contains the Module::Package logic that must be available to
11 # both the Author and the End User. Author-only logic goes in a
12 # Module::Package::Plugin subclass.
13 package Module::Install::Package;
14 use strict;
15 use Module::Install::Base;
16 use vars qw'@ISA $VERSION';
17 @ISA = 'Module::Install::Base';
18 $VERSION = '0.30';
19
20 #-----------------------------------------------------------------------------#
21 # XXX BOOTBUGHACK
22 # This is here to try to get us out of Module-Package-0.11 cpantesters hell...
23 # Remove this when the situation has blown over.
24 sub pkg {
25 *inc::Module::Package::VERSION = sub { $VERSION };
26 my $self = shift;
27 $self->module_package_internals_init($@);
28 }
29
30 #-----------------------------------------------------------------------------#
31 # We allow the author to specify key/value options after the plugin. These
32 # options need to be available both at author time and install time.
33 #-----------------------------------------------------------------------------#
34 # OO accessor for command line options:
35 sub package_options {
36 @_>1?($_[0]->{package_options}=$_[1]):$_[0]->{package_options}}
37
38 my $default_options = {
39 deps_list => 1,
40 install_bin => 1,
41 install_share => 1,
42 manifest_skip => 1,
43 requires_from => 1,
44 };
45
46 #-----------------------------------------------------------------------------#
47 # Module::Install plugin directives. Use long, ugly names to not pollute the
48 # Module::Install plugin namespace. These are only intended to be called from
49 # Module::Package.
50 #-----------------------------------------------------------------------------#
51
52 # Module::Package starts off life as a normal call to this Module::Install
53 # plugin directive:
54 my $module_install_plugin;
55 my $module_package_plugin;
56 my $module_package_dist_plugin;
57 # XXX ARGVHACK This @argv thing is a temporary fix for an ugly bug somewhere in the
58 # Wikitext module usage.
59 my @argv;
60 sub module_package_internals_init {
61 my $self = $module_install_plugin = shift;
62 my ($plugin_spec, %options) = @_;
63 $self->package_options({%$default_options, %options});
64
65 if ($module_install_plugin->is_admin) {
66 $module_package_plugin = $self->_load_plugin($plugin_spec);
67 $module_package_plugin->mi($module_install_plugin);
68 $module_package_plugin->version_check($VERSION);
69 }
70 else {
71 $module_package_dist_plugin = $self->_load_dist_plugin($plugin_spec);
72 $module_package_dist_plugin->mi($module_install_plugin) if ref $module_package_dist_plugin;
73 }
74 # NOTE - This is the point in time where the body of Makefile.PL runs...
75 return;
76
77 sub INIT {
78 return unless $module_install_plugin;
79 return if $Module::Package::ERROR;
80 eval {
81 if ($module_install_plugin->is_admin) {
82 $module_package_plugin->initial();
83 $module_package_plugin->main();
84 }
85 else {
86 $module_install_plugin->_initial();
87 $module_package_dist_plugin->_initial() if ref $module_package_dist_plugin;
88 $module_install_plugin->_main();
89 $module_package_dist_plugin->_main() if ref $module_package_dist_plugin;
90 }
91 };
92 if ($@) {
93 $Module::Package::ERROR = $@;
94 die $@;
95 }
96 @argv = @ARGV; # XXX ARGVHACK
97 }
98
99 # If this Module::Install plugin was used (by Module::Package) then wrap
100 # up any loose ends. This will get called after Makefile.PL has completed.
101 sub END {
102 @ARGV = @argv; # XXX ARGVHACK
103 return unless $module_install_plugin;
104 return if $Module::Package::ERROR;
105 $module_package_plugin
106 ? do {
107 $module_package_plugin->final;
108 $module_package_plugin->replicate_module_package;
109 }
110 : do {
111 $module_install_plugin->_final;
112 $module_package_dist_plugin->_final() if ref $module_package_dist_plugin;
113 }
114 }
115 }
116
117 # Module::Package, Module::Install::Package and Module::Package::Plugin
118 # must all have the same version. Seems wise.
119 sub module_package_internals_version_check {
120 my ($self, $version) = @_;
121 return if $version < 0.1800001; # XXX BOOTBUGHACK!!
122 die <<"..." unless $version == $VERSION;
123
124 Error! Something has gone awry:
125 Module::Package version=$version is using
126 Module::Install::Package version=$VERSION
127 If you are the author of this module, try upgrading Module::Package.
128 Otherwise, please notify the author of this error.
129
130 ...
131 }
132
133 # Find and load the author side plugin:
134 sub _load_plugin {
135 my ($self, $spec, $namespace) = @_;
136 $spec ||= '';
137 $namespace ||= 'Module::Package';
138 my $version = '';
139 $Module::Package::plugin_version = 0;
140 if ($spec =~ s/\s+(\S+)\s*//) {
141 $version = $1;
142 $Module::Package::plugin_version = $version;
143 }
144 my ($module, $plugin) =
145 not($spec) ? ('Plugin', "Plugin::basic") :
146 ($spec =~ /^\w(\w|::)*$/) ? ($spec, $spec) :
147 ($spec =~ /^:(\w+)$/) ? ('Plugin', "Plugin::$1") :
148 ($spec =~ /^(\S*\w):(\w+)$/) ? ($1, "$1::$2") :
149 die "$spec is invalid";
150 $module = "${namespace}::${module}";
151 $plugin = "${namespace}::${plugin}";
152 eval "use $module $version (); 1" or die $@;
153 return $plugin->new();
154 }
155
156 # Find and load the user side plugin:
157 sub _load_dist_plugin {
158 my ($self, $spec, $namespace) = @_;
159 $spec ||= '';
160 $namespace ||= 'Module::Package::Dist';
161 my $r = eval { $self->_load_plugin($spec, $namespace); };
162 return $r if ref $r;
163 return;
164 }
165
166 #-----------------------------------------------------------------------------#
167 # These are the user side analogs to the author side plugin API calls.
168 # Prefix with '_' to not pollute Module::Install plugin space.
169 #-----------------------------------------------------------------------------#
170 sub _initial {
171 my ($self) = @_;
172 }
173
174 sub _main {
175 my ($self) = @_;
176 }
177
178 # NOTE These must match Module::Package::Plugin::final.
179 sub _final {
180 my ($self) = @_;
181 $self->_all_from;
182 $self->_requires_from;
183 $self->_install_bin;
184 $self->_install_share;
185 $self->_WriteAll;
186 }
187
188 #-----------------------------------------------------------------------------#
189 # This section is where all the useful code bits go. These bits are needed by
190 # both Author and User side runs.
191 #-----------------------------------------------------------------------------#
192
193 my $all_from = 0;
194 sub _all_from {
195 my $self = shift;
196 return if $all_from++;
197 return if $self->name;
198 my $file = shift || "$main::PM" or die "all_from has no file";
199 $self->all_from($file);
200 }
201
202 my $requires_from = 0;
203 sub _requires_from {
204 my $self = shift;
205 return if $requires_from++;
206 return unless $self->package_options->{requires_from};
207 my $file = shift || "$main::PM" or die "requires_from has no file";
208 $self->requires_from($main::PM)
209 }
210
211 my $install_bin = 0;
212 sub _install_bin {
213 my $self = shift;
214 return if $install_bin++;
215 return unless $self->package_options->{install_bin};
216 return unless -d 'bin';
217 my @bin;
218 File::Find::find(sub {
219 return unless -f $_;
220 push @bin, $File::Find::name;
221 }, 'bin');
222 $self->install_script($_) for @bin;
223 }
224
225 my $install_share = 0;
226 sub _install_share {
227 my $self = shift;
228 return if $install_share++;
229 return unless $self->package_options->{install_share};
230 return unless -d 'share';
231 $self->install_share;
232 }
233
234 my $WriteAll = 0;
235 sub _WriteAll {
236 my $self = shift;
237 return if $WriteAll++;
238 $self->WriteAll(@_);
239 }
240
241 # Base package for Module::Package plugin distributed components.
242 package Module::Package::Dist;
243
244 sub new {
245 my ($class, %args) = @_;
246 bless \%args, $class;
247 }
248
249 sub mi {
250 @_ > 1 ? ($_[0]->{mi}=$_[1]) : $_[0]->{mi};
251 }
252
253 sub _initial {
254 my ($self) = @_;
255 }
256
257 sub _main {
258 my ($self) = @_;
259 }
260
261 sub _final {
262 my ($self) = @_;
263 }
264
265 1;
266
267 #-----------------------------------------------------------------------------#
268 # Take a guess at the primary .pm and .pod files for 'all_from', and friends.
269 # Put them in global magical vars in the main:: namespace.
270 #-----------------------------------------------------------------------------#
271 package Module::Package::PM;
272 use overload '""' => sub {
273 $_[0]->guess_pm unless @{$_[0]};
274 return $_[0]->[0];
275 };
276 sub set { $_[0]->[0] = $_[1] }
277 sub guess_pm {
278 my $pm = '';
279 my $self = shift;
280 if (-e 'META.yml') {
281 open META, 'META.yml' or die "Can't open 'META.yml' for input:\n$!";
282 my $meta = do { local $/; <META> };
283 close META;
284 $meta =~ /^module_name: (\S+)$/m
285 or die "Can't get module_name from META.yml";
286 $pm = $1;
287 $pm =~ s!::!/!g;
288 $pm = "lib/$pm.pm";
289 }
290 else {
291 require File::Find;
292 my @array = ();
293 File::Find::find(sub {
294 return unless /\.pm$/;
295 my $name = $File::Find::name;
296 my $num = ($name =~ s!/+!/!g);
297 my $ary = $array[$num] ||= [];
298 push @$ary, $name;
299 }, 'lib');
300 shift @array while @array and not defined $array[0];
301 die "Can't guess main module" unless @array;
302 (($pm) = sort @{$array[0]}) or
303 die "Can't guess main module";
304 }
305 my $pmc = $pm . 'c';
306 $pm = $pmc if -e $pmc;
307 $self->set($pm);
308 }
309 $main::PM = bless [$main::PM ? ($main::PM) : ()], __PACKAGE__;
310
311 package Module::Package::POD;
312 use overload '""' => sub {
313 return $_[0]->[0] if @{$_[0]};
314 (my $pod = "$main::PM") =~ s/\.pm/.pod/
315 or die "Module::Package's \$main::PM value should end in '.pm'";
316 return -e $pod ? $pod : '';
317 };
318 sub set { $_[0][0] = $_[1] }
319 $main::POD = bless [$main::POD ? ($main::POD) : ()], __PACKAGE__;
320
321 1;
322
+52
-0
inc/Module/Install/TrustMetaYml.pm less more
0 #line 1
1 package Module::Install::TrustMetaYml;
2
3 use 5.008;
4 use constant { FALSE => 0, TRUE => 1 };
5 use strict;
6 use utf8;
7
8 BEGIN {
9 $Module::Install::TrustMetaYml::AUTHORITY = 'cpan:TOBYINK';
10 }
11 BEGIN {
12 $Module::Install::TrustMetaYml::VERSION = '0.001';
13 }
14
15 use base qw(Module::Install::Base);
16
17 sub trust_meta_yml
18 {
19 my ($self, $where) = @_;
20 $where ||= 'META.yml';
21
22 $self->perl_version('5.006') unless defined $self->perl_version;
23
24 $self->include_deps('YAML::Tiny', 0);
25 return $self if $self->is_admin;
26
27 require YAML::Tiny;
28 my $data = YAML::Tiny::LoadFile($where);
29
30 $self->perl_version($data->{requires}{perl} || '5.006');
31
32 KEY: foreach my $key (qw(requires recommends build_requires))
33 {
34 next KEY unless ref $data->{$key} eq 'HASH';
35 my %deps = %{$data->{$key}};
36 DEP: while (my ($pkg, $ver) = each %deps)
37 {
38 next if $pkg eq 'perl';
39 $self->$key($pkg, $ver);
40 }
41 }
42
43 return $self;
44 }
45
46 *trust_meta_yaml = \&trust_meta_yml;
47
48 TRUE;
49
50 __END__
51
+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.02';
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.02';
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.02';
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 - 2011 Adam Kennedy.
+27
-0
inc/Module/Package/Dist/RDF.pm less more
0 #line 1
1 package Module::Package::Dist::RDF;
2
3 use 5.008003;
4 BEGIN {
5 $Module::Package::Dist::RDF::AUTHORITY = 'cpan:TOBYINK';
6 $Module::Package::Dist::RDF::VERSION = '0.005';
7 }
8
9 package Module::Package::Dist::RDF::standard;
10
11 use 5.008003;
12 use strict;
13 use base qw[Module::Package::Dist];
14 BEGIN {
15 $Module::Package::Dist::RDF::standard::AUTHORITY = 'cpan:TOBYINK';
16 $Module::Package::Dist::RDF::standard::VERSION = '0.005';
17 }
18
19 sub _main
20 {
21 my ($self) = @_;
22 $self->mi->trust_meta_yml;
23 $self->mi->auto_install;
24 }
25
26 1;
+71
-0
inc/Module/Package.pm less more
0 #line 1
1 ##
2 # name: Module::Package
3 # abstract: Postmodern Perl Module Packaging
4 # author: Ingy döt Net <ingy@cpan.org>
5 # license: perl
6 # copyright: 2011
7 # see:
8 # - Module::Package::Plugin
9 # - Module::Install::Package
10 # - Module::Package::Tutorial
11
12 package Module::Package;
13 use 5.005;
14 use strict;
15
16 BEGIN {
17 $Module::Package::VERSION = '0.30';
18 $inc::Module::Package::VERSION ||= $Module::Package::VERSION;
19 @inc::Module::Package::ISA = __PACKAGE__;
20 }
21
22 sub import {
23 my $class = shift;
24 $INC{'inc/Module/Install.pm'} = __FILE__;
25 unshift @INC, 'inc' unless $INC[0] eq 'inc';
26 eval "use Module::Install 1.01 (); 1" or $class->error($@);
27
28 package main;
29 Module::Install->import();
30 eval {
31 module_package_internals_version_check($Module::Package::VERSION);
32 module_package_internals_init(@_);
33 };
34 if ($@) {
35 $Module::Package::ERROR = $@;
36 die $@;
37 }
38 }
39
40 # XXX Remove this when things are stable.
41 sub error {
42 my ($class, $error) = @_;
43 if (-e 'inc' and not -e 'inc/.author') {
44 require Data::Dumper;
45 $Data::Dumper::Sortkeys = 1;
46 my $dump1 = Data::Dumper::Dumper(\%INC);
47 my $dump2 = Data::Dumper::Dumper(\@INC);
48 die <<"...";
49 This should not have happened. Hopefully this dump will explain the problem:
50
51 inc::Module::Package: $inc::Module::Package::VERSION
52 Module::Package: $Module::Package::VERSION
53 inc::Module::Install: $inc::Module::Install::VERSION
54 Module::Install: $Module::Install::VERSION
55
56 Error: $error
57
58 %INC:
59 $dump1
60 \@INC:
61 $dump2
62 ...
63 }
64 else {
65 die $error;
66 }
67 }
68
69 1;
70
+109
-0
inc/Scalar/Util/PP.pm less more
0 #line 1
1 # Scalar::Util::PP.pm
2 #
3 # Copyright (c) 1997-2009 Graham Barr <gbarr@pobox.com>. All rights reserved.
4 # This program is free software; you can redistribute it and/or
5 # modify it under the same terms as Perl itself.
6 #
7 # This module is normally only loaded if the XS module is not available
8
9 package Scalar::Util::PP;
10
11 use strict;
12 use warnings;
13 use vars qw(@ISA @EXPORT $VERSION $recurse);
14 require Exporter;
15 use B qw(svref_2object);
16
17 @ISA = qw(Exporter);
18 @EXPORT = qw(blessed reftype tainted readonly refaddr looks_like_number);
19 $VERSION = "1.23";
20 $VERSION = eval $VERSION;
21
22 sub blessed ($) {
23 return undef unless length(ref($_[0]));
24 my $b = svref_2object($_[0]);
25 return undef unless $b->isa('B::PVMG');
26 my $s = $b->SvSTASH;
27 return $s->isa('B::HV') ? $s->NAME : undef;
28 }
29
30 sub refaddr($) {
31 return undef unless length(ref($_[0]));
32
33 my $addr;
34 if(defined(my $pkg = blessed($_[0]))) {
35 $addr .= bless $_[0], 'Scalar::Util::Fake';
36 bless $_[0], $pkg;
37 }
38 else {
39 $addr .= $_[0]
40 }
41
42 $addr =~ /0x(\w+)/;
43 local $^W;
44 no warnings 'portable';
45 hex($1);
46 }
47
48 {
49 my %tmap = qw(
50 B::NULL SCALAR
51
52 B::HV HASH
53 B::AV ARRAY
54 B::CV CODE
55 B::IO IO
56 B::GV GLOB
57 B::REGEXP REGEXP
58 );
59
60 sub reftype ($) {
61 my $r = shift;
62
63 return undef unless length(ref($r));
64
65 my $t = ref(svref_2object($r));
66
67 return
68 exists $tmap{$t} ? $tmap{$t}
69 : length(ref($$r)) ? 'REF'
70 : 'SCALAR';
71 }
72 }
73
74 sub tainted {
75 local($@, $SIG{__DIE__}, $SIG{__WARN__});
76 local $^W = 0;
77 no warnings;
78 eval { kill 0 * $_[0] };
79 $@ =~ /^Insecure/;
80 }
81
82 sub readonly {
83 return 0 if tied($_[0]) || (ref(\($_[0])) ne "SCALAR");
84
85 local($@, $SIG{__DIE__}, $SIG{__WARN__});
86 my $tmp = $_[0];
87
88 !eval { $_[0] = $tmp; 1 };
89 }
90
91 sub looks_like_number {
92 local $_ = shift;
93
94 # checks from perlfaq4
95 return 0 if !defined($_);
96 if (ref($_)) {
97 require overload;
98 return overload::Overloaded($_) ? defined(0 + $_) : 0;
99 }
100 return 1 if (/^[+-]?[0-9]+$/); # is a +/- integer
101 return 1 if (/^([+-]?)(?=[0-9]|\.[0-9])[0-9]*(\.[0-9]*)?([Ee]([+-]?[0-9]+))?$/); # a C float
102 return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
103
104 0;
105 }
106
107
108 1;
+71
-0
inc/Scalar/Util.pm less more
0 #line 1
1 # Scalar::Util.pm
2 #
3 # Copyright (c) 1997-2007 Graham Barr <gbarr@pobox.com>. All rights reserved.
4 # This program is free software; you can redistribute it and/or
5 # modify it under the same terms as Perl itself.
6
7 package Scalar::Util;
8
9 use strict;
10 use vars qw(@ISA @EXPORT_OK $VERSION @EXPORT_FAIL);
11 require Exporter;
12 require List::Util; # List::Util loads the XS
13
14 @ISA = qw(Exporter);
15 @EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
16 $VERSION = "1.23";
17 $VERSION = eval $VERSION;
18
19 unless (defined &dualvar) {
20 # Load Pure Perl version if XS not loaded
21 require Scalar::Util::PP;
22 Scalar::Util::PP->import;
23 push @EXPORT_FAIL, qw(weaken isweak dualvar isvstring set_prototype);
24 }
25
26 sub export_fail {
27 if (grep { /dualvar/ } @EXPORT_FAIL) { # no XS loaded
28 my $pat = join("|", @EXPORT_FAIL);
29 if (my ($err) = grep { /^($pat)$/ } @_ ) {
30 require Carp;
31 Carp::croak("$err is only available with the XS version of Scalar::Util");
32 }
33 }
34
35 if (grep { /^(weaken|isweak)$/ } @_ ) {
36 require Carp;
37 Carp::croak("Weak references are not implemented in the version of perl");
38 }
39
40 if (grep { /^(isvstring)$/ } @_ ) {
41 require Carp;
42 Carp::croak("Vstrings are not implemented in the version of perl");
43 }
44
45 @_;
46 }
47
48 sub openhandle ($) {
49 my $fh = shift;
50 my $rt = reftype($fh) || '';
51
52 return defined(fileno($fh)) ? $fh : undef
53 if $rt eq 'IO';
54
55 if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA)
56 $fh = \(my $tmp=$fh);
57 }
58 elsif ($rt ne 'GLOB') {
59 return undef;
60 }
61
62 (tied(*$fh) or defined(fileno($fh)))
63 ? $fh : undef;
64 }
65
66 1;
67
68 __END__
69
70 #line 283
+622
-0
inc/YAML/Tiny.pm less more
0 #line 1
1 package YAML::Tiny;
2
3 use strict;
4 use Carp 'croak';
5
6 # UTF Support?
7 sub HAVE_UTF8 () { $] >= 5.007003 }
8 BEGIN {
9 if ( HAVE_UTF8 ) {
10 # The string eval helps hide this from Test::MinimumVersion
11 eval "require utf8;";
12 die "Failed to load UTF-8 support" if $@;
13 }
14
15 # Class structure
16 require 5.004;
17 require Exporter;
18 $YAML::Tiny::VERSION = '1.41';
19 @YAML::Tiny::ISA = qw{ Exporter };
20 @YAML::Tiny::EXPORT = qw{ Load Dump };
21 @YAML::Tiny::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
22
23 # Error storage
24 $YAML::Tiny::errstr = '';
25 }
26
27 # The character class of all characters we need to escape
28 # NOTE: Inlined, since it's only used once
29 # my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
30
31 # Printed form of the unprintable characters in the lowest range
32 # of ASCII characters, listed by ASCII ordinal position.
33 my @UNPRINTABLE = qw(
34 z x01 x02 x03 x04 x05 x06 a
35 x08 t n v f r x0e x0f
36 x10 x11 x12 x13 x14 x15 x16 x17
37 x18 x19 x1a e x1c x1d x1e x1f
38 );
39
40 # Printable characters for escapes
41 my %UNESCAPES = (
42 z => "\x00", a => "\x07", t => "\x09",
43 n => "\x0a", v => "\x0b", f => "\x0c",
44 r => "\x0d", e => "\x1b", '\\' => '\\',
45 );
46
47 # Special magic boolean words
48 my %QUOTE = map { $_ => 1 } qw{
49 null Null NULL
50 y Y yes Yes YES n N no No NO
51 true True TRUE false False FALSE
52 on On ON off Off OFF
53 };
54
55
56
57
58
59 #####################################################################
60 # Implementation
61
62 # Create an empty YAML::Tiny object
63 sub new {
64 my $class = shift;
65 bless [ @_ ], $class;
66 }
67
68 # Create an object from a file
69 sub read {
70 my $class = ref $_[0] ? ref shift : shift;
71
72 # Check the file
73 my $file = shift or return $class->_error( 'You did not specify a file name' );
74 return $class->_error( "File '$file' does not exist" ) unless -e $file;
75 return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
76 return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
77
78 # Slurp in the file
79 local $/ = undef;
80 local *CFG;
81 unless ( open(CFG, $file) ) {
82 return $class->_error("Failed to open file '$file': $!");
83 }
84 my $contents = <CFG>;
85 unless ( close(CFG) ) {
86 return $class->_error("Failed to close file '$file': $!");
87 }
88
89 $class->read_string( $contents );
90 }
91
92 # Create an object from a string
93 sub read_string {
94 my $class = ref $_[0] ? ref shift : shift;
95 my $self = bless [], $class;
96 my $string = $_[0];
97 unless ( defined $string ) {
98 return $self->_error("Did not provide a string to load");
99 }
100
101 # Byte order marks
102 # NOTE: Keeping this here to educate maintainers
103 # my %BOM = (
104 # "\357\273\277" => 'UTF-8',
105 # "\376\377" => 'UTF-16BE',
106 # "\377\376" => 'UTF-16LE',
107 # "\377\376\0\0" => 'UTF-32LE'
108 # "\0\0\376\377" => 'UTF-32BE',
109 # );
110 if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
111 return $self->_error("Stream has a non UTF-8 BOM");
112 } else {
113 # Strip UTF-8 bom if found, we'll just ignore it
114 $string =~ s/^\357\273\277//;
115 }
116
117 # Try to decode as utf8
118 utf8::decode($string) if HAVE_UTF8;
119
120 # Check for some special cases
121 return $self unless length $string;
122 unless ( $string =~ /[\012\015]+\z/ ) {
123 return $self->_error("Stream does not end with newline character");
124 }
125
126 # Split the file into lines
127 my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
128 split /(?:\015{1,2}\012|\015|\012)/, $string;
129
130 # Strip the initial YAML header
131 @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
132
133 # A nibbling parser
134 while ( @lines ) {
135 # Do we have a document header?
136 if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
137 # Handle scalar documents
138 shift @lines;
139 if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
140 push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
141 next;
142 }
143 }
144
145 if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
146 # A naked document
147 push @$self, undef;
148 while ( @lines and $lines[0] !~ /^---/ ) {
149 shift @lines;
150 }
151
152 } elsif ( $lines[0] =~ /^\s*\-/ ) {
153 # An array at the root
154 my $document = [ ];
155 push @$self, $document;
156 $self->_read_array( $document, [ 0 ], \@lines );
157
158 } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
159 # A hash at the root
160 my $document = { };
161 push @$self, $document;
162 $self->_read_hash( $document, [ length($1) ], \@lines );
163
164 } else {
165 croak("YAML::Tiny failed to classify the line '$lines[0]'");
166 }
167 }
168
169 $self;
170 }
171
172 # Deparse a scalar string to the actual scalar
173 sub _read_scalar {
174 my ($self, $string, $indent, $lines) = @_;
175
176 # Trim trailing whitespace
177 $string =~ s/\s*\z//;
178
179 # Explitic null/undef
180 return undef if $string eq '~';
181
182 # Single quote
183 if ( $string =~ /^\'(.*?)\'\z/ ) {
184 return '' unless defined $1;
185 $string = $1;
186 $string =~ s/\'\'/\'/g;
187 return $string;
188 }
189
190 # Double quote.
191 # The commented out form is simpler, but overloaded the Perl regex
192 # engine due to recursion and backtracking problems on strings
193 # larger than 32,000ish characters. Keep it for reference purposes.
194 # if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
195 if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"\z/ ) {
196 # Reusing the variable is a little ugly,
197 # but avoids a new variable and a string copy.
198 $string = $1;
199 $string =~ s/\\"/"/g;
200 $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
201 return $string;
202 }
203
204 # Special cases
205 if ( $string =~ /^[\'\"!&]/ ) {
206 croak("YAML::Tiny does not support a feature in line '$lines->[0]'");
207 }
208 return {} if $string eq '{}';
209 return [] if $string eq '[]';
210
211 # Regular unquoted string
212 return $string unless $string =~ /^[>|]/;
213
214 # Error
215 croak("YAML::Tiny failed to find multi-line scalar content") unless @$lines;
216
217 # Check the indent depth
218 $lines->[0] =~ /^(\s*)/;
219 $indent->[-1] = length("$1");
220 if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
221 croak("YAML::Tiny found bad indenting in line '$lines->[0]'");
222 }
223
224 # Pull the lines
225 my @multiline = ();
226 while ( @$lines ) {
227 $lines->[0] =~ /^(\s*)/;
228 last unless length($1) >= $indent->[-1];
229 push @multiline, substr(shift(@$lines), length($1));
230 }
231
232 my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
233 my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
234 return join( $j, @multiline ) . $t;
235 }
236
237 # Parse an array
238 sub _read_array {
239 my ($self, $array, $indent, $lines) = @_;
240
241 while ( @$lines ) {
242 # Check for a new document
243 if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
244 while ( @$lines and $lines->[0] !~ /^---/ ) {
245 shift @$lines;
246 }
247 return 1;
248 }
249
250 # Check the indent level
251 $lines->[0] =~ /^(\s*)/;
252 if ( length($1) < $indent->[-1] ) {
253 return 1;
254 } elsif ( length($1) > $indent->[-1] ) {
255 croak("YAML::Tiny found bad indenting in line '$lines->[0]'");
256 }
257
258 if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
259 # Inline nested hash
260 my $indent2 = length("$1");
261 $lines->[0] =~ s/-/ /;
262 push @$array, { };
263 $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
264
265 } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
266 # Array entry with a value
267 shift @$lines;
268 push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
269
270 } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
271 shift @$lines;
272 unless ( @$lines ) {
273 push @$array, undef;
274 return 1;
275 }
276 if ( $lines->[0] =~ /^(\s*)\-/ ) {
277 my $indent2 = length("$1");
278 if ( $indent->[-1] == $indent2 ) {
279 # Null array entry
280 push @$array, undef;
281 } else {
282 # Naked indenter
283 push @$array, [ ];
284 $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
285 }
286
287 } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
288 push @$array, { };
289 $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
290
291 } else {
292 croak("YAML::Tiny failed to classify line '$lines->[0]'");
293 }
294
295 } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
296 # This is probably a structure like the following...
297 # ---
298 # foo:
299 # - list
300 # bar: value
301 #
302 # ... so lets return and let the hash parser handle it
303 return 1;
304
305 } else {
306 croak("YAML::Tiny failed to classify line '$lines->[0]'");
307 }
308 }
309
310 return 1;
311 }
312
313 # Parse an array
314 sub _read_hash {
315 my ($self, $hash, $indent, $lines) = @_;
316
317 while ( @$lines ) {
318 # Check for a new document
319 if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
320 while ( @$lines and $lines->[0] !~ /^---/ ) {
321 shift @$lines;
322 }
323 return 1;
324 }
325
326 # Check the indent level
327 $lines->[0] =~ /^(\s*)/;
328 if ( length($1) < $indent->[-1] ) {
329 return 1;
330 } elsif ( length($1) > $indent->[-1] ) {
331 croak("YAML::Tiny found bad indenting in line '$lines->[0]'");
332 }
333
334 # Get the key
335 unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+|$)// ) {
336 if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
337 croak("YAML::Tiny does not support a feature in line '$lines->[0]'");
338 }
339 croak("YAML::Tiny failed to classify line '$lines->[0]'");
340 }
341 my $key = $1;
342
343 # Do we have a value?
344 if ( length $lines->[0] ) {
345 # Yes
346 $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
347 } else {
348 # An indent
349 shift @$lines;
350 unless ( @$lines ) {
351 $hash->{$key} = undef;
352 return 1;
353 }
354 if ( $lines->[0] =~ /^(\s*)-/ ) {
355 $hash->{$key} = [];
356 $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
357 } elsif ( $lines->[0] =~ /^(\s*)./ ) {
358 my $indent2 = length("$1");
359 if ( $indent->[-1] >= $indent2 ) {
360 # Null hash entry
361 $hash->{$key} = undef;
362 } else {
363 $hash->{$key} = {};
364 $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
365 }
366 }
367 }
368 }
369
370 return 1;
371 }
372
373 # Save an object to a file
374 sub write {
375 my $self = shift;
376 my $file = shift or return $self->_error('No file name provided');
377
378 # Write it to the file
379 open( CFG, '>' . $file ) or return $self->_error(
380 "Failed to open file '$file' for writing: $!"
381 );
382 print CFG $self->write_string;
383 close CFG;
384
385 return 1;
386 }
387
388 # Save an object to a string
389 sub write_string {
390 my $self = shift;
391 return '' unless @$self;
392
393 # Iterate over the documents
394 my $indent = 0;
395 my @lines = ();
396 foreach my $cursor ( @$self ) {
397 push @lines, '---';
398
399 # An empty document
400 if ( ! defined $cursor ) {
401 # Do nothing
402
403 # A scalar document
404 } elsif ( ! ref $cursor ) {
405 $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
406
407 # A list at the root
408 } elsif ( ref $cursor eq 'ARRAY' ) {
409 unless ( @$cursor ) {
410 $lines[-1] .= ' []';
411 next;
412 }
413 push @lines, $self->_write_array( $cursor, $indent, {} );
414
415 # A hash at the root
416 } elsif ( ref $cursor eq 'HASH' ) {
417 unless ( %$cursor ) {
418 $lines[-1] .= ' {}';
419 next;
420 }
421 push @lines, $self->_write_hash( $cursor, $indent, {} );
422
423 } else {
424 croak("Cannot serialize " . ref($cursor));
425 }
426 }
427
428 join '', map { "$_\n" } @lines;
429 }
430
431 sub _write_scalar {
432 my $string = $_[1];
433 return '~' unless defined $string;
434 return "''" unless length $string;
435 if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
436 $string =~ s/\\/\\\\/g;
437 $string =~ s/"/\\"/g;
438 $string =~ s/\n/\\n/g;
439 $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
440 return qq|"$string"|;
441 }
442 if ( $string =~ /(?:^\W|\s)/ or $QUOTE{$string} ) {
443 return "'$string'";
444 }
445 return $string;
446 }
447
448 sub _write_array {
449 my ($self, $array, $indent, $seen) = @_;
450 if ( $seen->{refaddr($array)}++ ) {
451 die "YAML::Tiny does not support circular references";
452 }
453 my @lines = ();
454 foreach my $el ( @$array ) {
455 my $line = (' ' x $indent) . '-';
456 my $type = ref $el;
457 if ( ! $type ) {
458 $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
459 push @lines, $line;
460
461 } elsif ( $type eq 'ARRAY' ) {
462 if ( @$el ) {
463 push @lines, $line;
464 push @lines, $self->_write_array( $el, $indent + 1, $seen );
465 } else {
466 $line .= ' []';
467 push @lines, $line;
468 }
469
470 } elsif ( $type eq 'HASH' ) {
471 if ( keys %$el ) {
472 push @lines, $line;
473 push @lines, $self->_write_hash( $el, $indent + 1, $seen );
474 } else {
475 $line .= ' {}';
476 push @lines, $line;
477 }
478
479 } else {
480 die "YAML::Tiny does not support $type references";
481 }
482 }
483
484 @lines;
485 }
486
487 sub _write_hash {
488 my ($self, $hash, $indent, $seen) = @_;
489 if ( $seen->{refaddr($hash)}++ ) {
490 die "YAML::Tiny does not support circular references";
491 }
492 my @lines = ();
493 foreach my $name ( sort keys %$hash ) {
494 my $el = $hash->{$name};
495 my $line = (' ' x $indent) . "$name:";
496 my $type = ref $el;
497 if ( ! $type ) {
498 $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
499 push @lines, $line;
500
501 } elsif ( $type eq 'ARRAY' ) {
502 if ( @$el ) {
503 push @lines, $line;
504 push @lines, $self->_write_array( $el, $indent + 1, $seen );
505 } else {
506 $line .= ' []';
507 push @lines, $line;
508 }
509
510 } elsif ( $type eq 'HASH' ) {
511 if ( keys %$el ) {
512 push @lines, $line;
513 push @lines, $self->_write_hash( $el, $indent + 1, $seen );
514 } else {
515 $line .= ' {}';
516 push @lines, $line;
517 }
518
519 } else {
520 die "YAML::Tiny does not support $type references";
521 }
522 }
523
524 @lines;
525 }
526
527 # Set error
528 sub _error {
529 $YAML::Tiny::errstr = $_[1];
530 undef;
531 }
532
533 # Retrieve error
534 sub errstr {
535 $YAML::Tiny::errstr;
536 }
537
538
539
540
541
542 #####################################################################
543 # YAML Compatibility
544
545 sub Dump {
546 YAML::Tiny->new(@_)->write_string;
547 }
548
549 sub Load {
550 my $self = YAML::Tiny->read_string(@_);
551 unless ( $self ) {
552 croak("Failed to load YAML document from string");
553 }
554 if ( wantarray ) {
555 return @$self;
556 } else {
557 # To match YAML.pm, return the last document
558 return $self->[-1];
559 }
560 }
561
562 BEGIN {
563 *freeze = *Dump;
564 *thaw = *Load;
565 }
566
567 sub DumpFile {
568 my $file = shift;
569 YAML::Tiny->new(@_)->write($file);
570 }
571
572 sub LoadFile {
573 my $self = YAML::Tiny->read($_[0]);
574 unless ( $self ) {
575 croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
576 }
577 if ( wantarray ) {
578 return @$self;
579 } else {
580 # Return only the last document to match YAML.pm,
581 return $self->[-1];
582 }
583 }
584
585
586
587
588
589 #####################################################################
590 # Use Scalar::Util if possible, otherwise emulate it
591
592 BEGIN {
593 eval {
594 require Scalar::Util;
595 };
596 if ( $@ ) {
597 # Failed to load Scalar::Util
598 eval <<'END_PERL';
599 sub refaddr {
600 my $pkg = ref($_[0]) or return undef;
601 if (!!UNIVERSAL::can($_[0], 'can')) {
602 bless $_[0], 'Scalar::Util::Fake';
603 } else {
604 $pkg = undef;
605 }
606 "$_[0]" =~ /0x(\w+)/;
607 my $i = do { local $^W; hex $1 };
608 bless $_[0], $pkg if defined $pkg;
609 $i;
610 }
611 END_PERL
612 } else {
613 Scalar::Util->import('refaddr');
614 }
615 }
616
617 1;
618
619 __END__
620
621 #line 1132
+135
-0
lib/PerlX/Maybe.pm less more
0 package PerlX::Maybe;
1
2 use 5.008;
3 use strict;
4
5 our (@EXPORT, @ISA);
6 BEGIN {
7 $PerlX::Maybe::AUTHORITY = 'cpan:TOBYINK';
8 $PerlX::Maybe::VERSION = '0.002';
9
10 require Exporter;
11 @ISA = qw/Exporter/;
12 @EXPORT = qw/maybe/;
13 }
14
15 sub maybe ($$@)
16 {
17 if (defined $_[0] and defined $_[1])
18 {
19 @_
20 }
21 else
22 {
23 (scalar @_ > 1) ? @_[2 .. $#_] : qw()
24 }
25 }
26
27 __FILE__
28 __END__
29
30 =head1 NAME
31
32 PerlX::Maybe - return a pair only if they are both defined
33
34 =head1 SYNOPSIS
35
36 You once wrote:
37
38 my $bob = Person->new(
39 defined $name ? (name => $name) : (),
40 defined $age ? (age => $age) : (),
41 );
42
43 Now you can write:
44
45 my $bob = Person->new(
46 maybe name => $name,
47 maybe age => $age,
48 );
49
50 =head1 DESCRIPTION
51
52 Moose classes (and some other classes) distinguish between an attribute
53 being unset and the attribute being set to undef. Supplying a constructor
54 arguments like this:
55
56 my $bob = Person->new(
57 name => $name,
58 age => $age,
59 );
60
61 Will result in the C<name> and C<age> attributes possibly being set to
62 undef (if the corresponding C<$name> and C<$age> variables are not defined),
63 which may violate the Person class' type constraints.
64
65 (Note: if you are the I<author> of the class in question, you can solve
66 this using L<MooseX::UndefTolerant>. However, some of us are stuck using
67 non-UndefTolerant classes written by third parties.)
68
69 To ensure that the Person constructor does not try to set a name or age
70 at all when they are undefined, ugly looking code like this is often used:
71
72 my $bob = Person->new(
73 defined $name ? (name => $name) : (),
74 defined $age ? (age => $age) : (),
75 );
76
77 or:
78
79 my $bob = Person->new(
80 (name => $name) x!!(defined $name),
81 (age => $age) x!!(defined $age),
82 );
83
84 A slightly more elegant solution is the C<maybe> function:
85
86 =head2 C<< maybe $x => $y, @rest >>
87
88 This function checks that C<< $x >> and C<< $y >> are both defined. If they
89 are, it returns them both as a list; otherwise it returns the empty list.
90
91 If C<< @rest >> is provided, it is unconditionally appended to the end of
92 whatever list is returned.
93
94 The combination of these behaviours allows the following very sugary syntax
95 to "just work".
96
97 my $bob = Person->new(
98 name => $name,
99 address => $addr,
100 maybe phone => $tel,
101 maybe email => $email,
102 unique_id => $id,
103 );
104
105 This function is exported by default.
106
107 =head1 BUGS
108
109 Please report any bugs to
110 L<http://rt.cpan.org/Dist/Display.html?Queue=PerlX-Maybe>.
111
112 =head1 SEE ALSO
113
114 L<Syntax::Feature::Maybe>.
115
116 L<MooseX::UndefTolerant>, L<PerlX::Perform>, L<Exporter>.
117
118 =head1 AUTHOR
119
120 Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
121
122 =head1 COPYRIGHT AND LICENCE
123
124 This software is copyright (c) 2012 by Toby Inkster.
125
126 This is free software; you can redistribute it and/or modify it under
127 the same terms as the Perl 5 programming language system itself.
128
129 =head1 DISCLAIMER OF WARRANTIES
130
131 THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
132 WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
133 MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
134
+60
-0
lib/Syntax/Feature/Maybe.pm less more
0 package Syntax::Feature::Maybe;
1
2 use 5.008;
3 use strict;
4 use PerlX::Maybe qw//;
5
6 BEGIN {
7 $Syntax::Feature::Maybe::AUTHORITY = 'cpan:TOBYINK';
8 $Syntax::Feature::Maybe::VERSION = '0.002';
9 }
10
11 sub install
12 {
13 my ($class, %args) = @_;
14 my $into = delete $args{into};
15
16 foreach my $f (qw/maybe/)
17 {
18 no strict 'refs';
19 *{"$into\::$f"} = \&{"PerlX::Maybe::$f"};
20 }
21 }
22
23 __FILE__
24 __END__
25
26 =head1 NAME
27
28 Syntax::Feature::Maybe - use syntax qw/maybe/
29
30 =head1 DESCRIPTION
31
32 Tiny shim between L<PerlX::Maybe> and L<syntax>.
33
34 =head1 BUGS
35
36 Please report any bugs to
37 L<http://rt.cpan.org/Dist/Display.html?Queue=PerlX-Maybe>.
38
39 =head1 SEE ALSO
40
41 L<PerlX::Maybe>, L<syntax>.
42
43 =head1 AUTHOR
44
45 Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
46
47 =head1 COPYRIGHT AND LICENCE
48
49 This software is copyright (c) 2012 by Toby Inkster.
50
51 This is free software; you can redistribute it and/or modify it under
52 the same terms as the Perl 5 programming language system itself.
53
54 =head1 DISCLAIMER OF WARRANTIES
55
56 THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
57 WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
58 MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
59
+28
-0
meta/changes.ttl less more
0 # This file acts as the project's changelog.
1
2 @prefix : <http://usefulinc.com/ns/doap#> .
3 @prefix dcs: <http://ontologi.es/doap-changeset#> .
4 @prefix dc: <http://purl.org/dc/terms/> .
5 @prefix dist: <http://purl.org/NET/cpan-uri/dist/PerlX-Maybe/> .
6 @prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .
7 @prefix xsd: <http://www.w3.org/2001/XMLSchema#> .
8
9 dist:project :release dist:v_0-001 .
10 dist:v_0-001
11 a :Version ;
12 dc:issued "2012-02-15"^^xsd:date ;
13 :revision "0.001"^^xsd:string ;
14 :file-release <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/PerlX-Maybe-0.001.tar.gz> ;
15 rdfs:label "Initial release" .
16
17 dist:project :release dist:v_0-002 .
18 dist:v_0-002
19 a :Version ;
20 dc:issued "2012-05-03"^^xsd:date ;
21 :revision "0.002"^^xsd:string ;
22 :file-release <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/PerlX-Maybe-0.002.tar.gz> ;
23 dcs:changeset [
24 dcs:versus dist:v_0-001 ;
25 dcs:item [ rdfs:label "Faster implementation. Tested on Perl 5.10.1 on Linux, the new version is 60% faster. (Not that it was slow to begin with - 'maybe' is a pretty simple function.)"@en ] ;
26 ] .
27
+23
-0
meta/doap.ttl less more
0 # This file contains general metadata about the project.
1
2 @prefix : <http://usefulinc.com/ns/doap#> .
3 @prefix dc: <http://purl.org/dc/terms/> .
4 @prefix foaf: <http://xmlns.com/foaf/0.1/> .
5 @prefix rdfs: <http://www.w3.org/2000/01/rdf-schema#> .
6 @prefix xsd: <http://www.w3.org/2001/XMLSchema#> .
7
8 <http://purl.org/NET/cpan-uri/dist/PerlX-Maybe/project>
9 a :Project ;
10 :programming-language "Perl" ;
11 :name "PerlX-Maybe" ;
12 :shortdesc "return a given list only if they are all defined" ;
13 :homepage <https://metacpan.org/release/PerlX-Maybe> ;
14 :download-page <https://metacpan.org/release/PerlX-Maybe> ;
15 :repository [ a :HgRepository ; :browse <https://bitbucket.org/tobyink/p5-perlx-maybe> ] ;
16 :bug-database <http://rt.cpan.org/Dist/Display.html?Queue=PerlX-Maybe> ;
17 :created "2012-02-15"^^xsd:date ;
18 :license <http://dev.perl.org/licenses/> ;
19 :developer [ a foaf:Person ; foaf:name "Toby Inkster" ; foaf:mbox <mailto:tobyink@cpan.org> ] .
20
21 <http://dev.perl.org/licenses/>
22 dc:title "the same terms as the perl 5 programming language system itself" .
+13
-0
meta/makefile.ttl less more
0 # This file provides instructions for packaging.
1
2 @prefix : <http://purl.org/NET/cpan-uri/terms#> .
3
4 <http://purl.org/NET/cpan-uri/dist/PerlX-Maybe/project>
5 :perl_version_from _:main ;
6 :version_from _:main ;
7 :readme_from _:main ;
8 :test_requires "Test::More 0.61" ;
9 :requires "strict","Exporter".
10
11 _:main <http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#fileName> "lib/PerlX/Maybe.pm" .
12
+3
-0
t/01basic.t less more
0 use Test::More tests => 1;
1 BEGIN { use_ok('PerlX::Maybe') };
2
+18
-0
t/02maybe.t less more
0 use Test::More tests => 3;
1 use PerlX::Maybe;
2
3 is_deeply(
4 [ maybe foo => undef, maybe bar => 0, maybe baz => 1, undef ],
5 [ bar => 0, baz => 1, undef ],
6 );
7
8 is_deeply(
9 [ 3, maybe foo => undef, 4, maybe bar => 0, 5, maybe baz => 1 ],
10 [ 3, 4, bar => 0, 5, baz => 1 ],
11 );
12
13 is_deeply(
14 [ 3, maybe foo => {quux=>1}, undef, 4, maybe bar => 0, 5, maybe baz => 1 ],
15 [ 3, foo => {quux=>1}, undef, 4, bar => 0, 5, baz => 1 ],
16 );
17