Update upstream source from tag 'upstream/0.43'
Update to upstream version '0.43'
with Debian dir 392da409ec2fa0bf334ed71c6284f0e9d039216d
gregor herrmann
1 year, 10 months ago
0 | 0 | Revision history for Perl extension Catalyst::Plugin::Session |
1 | ||
2 | 0.43 - 2022-06-03 | |
3 | - fix tests when Catalyst::Plugin::Authentication is unavailable | |
4 | ||
5 | 0.42 - 2022-05-31 | |
6 | - revised packaging | |
7 | - correctly specify test prerequisites as test prerequisites | |
8 | - drop unused Test::Exception prereq | |
9 | - drop Tie::RefHash prereq that was not used directly | |
10 | - only run pod tests for authors | |
11 | - ensure all optional tests are run by authors | |
12 | - drop use of Test::WWW::Mechanize::PSGI and Test::WWW::Mechanize::Catalyst | |
13 | in favor of a simpler user agent | |
1 | 14 | |
2 | 15 | 0.41 2018-12-05 |
3 | 16 | - Don't let an evil session ID supplier have an easy XSS vector (Michael McClimon++) |
0 | Terms of the Perl programming language system itself | |
1 | ||
2 | a) the GNU General Public License as published by the Free | |
3 | Software Foundation; either version 1, or (at your option) any | |
4 | later version, or | |
5 | b) the "Artistic License" | |
6 | ||
7 | --- The GNU General Public License, Version 1, February 1989 --- | |
8 | ||
9 | This software is Copyright (c) 2022 by Yuval Kogman <nothingmuch@woobling.org>. | |
10 | ||
11 | This is free software, licensed under: | |
12 | ||
13 | The GNU General Public License, Version 1, February 1989 | |
14 | ||
15 | GNU GENERAL PUBLIC LICENSE | |
16 | Version 1, February 1989 | |
17 | ||
18 | Copyright (C) 1989 Free Software Foundation, Inc. | |
19 | 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA | |
20 | ||
21 | Everyone is permitted to copy and distribute verbatim copies | |
22 | of this license document, but changing it is not allowed. | |
23 | ||
24 | Preamble | |
25 | ||
26 | The license agreements of most software companies try to keep users | |
27 | at the mercy of those companies. By contrast, our General Public | |
28 | License is intended to guarantee your freedom to share and change free | |
29 | software--to make sure the software is free for all its users. The | |
30 | General Public License applies to the Free Software Foundation's | |
31 | software and to any other program whose authors commit to using it. | |
32 | You can use it for your programs, too. | |
33 | ||
34 | When we speak of free software, we are referring to freedom, not | |
35 | price. Specifically, the General Public License is designed to make | |
36 | sure that you have the freedom to give away or sell copies of free | |
37 | software, that you receive source code or can get it if you want it, | |
38 | that you can change the software or use pieces of it in new free | |
39 | programs; and that you know you can do these things. | |
40 | ||
41 | To protect your rights, we need to make restrictions that forbid | |
42 | anyone to deny you these rights or to ask you to surrender the rights. | |
43 | These restrictions translate to certain responsibilities for you if you | |
44 | distribute copies of the software, or if you modify it. | |
45 | ||
46 | For example, if you distribute copies of a such a program, whether | |
47 | gratis or for a fee, you must give the recipients all the rights that | |
48 | you have. You must make sure that they, too, receive or can get the | |
49 | source code. And you must tell them their rights. | |
50 | ||
51 | We protect your rights with two steps: (1) copyright the software, and | |
52 | (2) offer you this license which gives you legal permission to copy, | |
53 | distribute and/or modify the software. | |
54 | ||
55 | Also, for each author's protection and ours, we want to make certain | |
56 | that everyone understands that there is no warranty for this free | |
57 | software. If the software is modified by someone else and passed on, we | |
58 | want its recipients to know that what they have is not the original, so | |
59 | that any problems introduced by others will not reflect on the original | |
60 | authors' reputations. | |
61 | ||
62 | The precise terms and conditions for copying, distribution and | |
63 | modification follow. | |
64 | ||
65 | GNU GENERAL PUBLIC LICENSE | |
66 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION | |
67 | ||
68 | 0. This License Agreement applies to any program or other work which | |
69 | contains a notice placed by the copyright holder saying it may be | |
70 | distributed under the terms of this General Public License. The | |
71 | "Program", below, refers to any such program or work, and a "work based | |
72 | on the Program" means either the Program or any work containing the | |
73 | Program or a portion of it, either verbatim or with modifications. Each | |
74 | licensee is addressed as "you". | |
75 | ||
76 | 1. You may copy and distribute verbatim copies of the Program's source | |
77 | code as you receive it, in any medium, provided that you conspicuously and | |
78 | appropriately publish on each copy an appropriate copyright notice and | |
79 | disclaimer of warranty; keep intact all the notices that refer to this | |
80 | General Public License and to the absence of any warranty; and give any | |
81 | other recipients of the Program a copy of this General Public License | |
82 | along with the Program. You may charge a fee for the physical act of | |
83 | transferring a copy. | |
84 | ||
85 | 2. You may modify your copy or copies of the Program or any portion of | |
86 | it, and copy and distribute such modifications under the terms of Paragraph | |
87 | 1 above, provided that you also do the following: | |
88 | ||
89 | a) cause the modified files to carry prominent notices stating that | |
90 | you changed the files and the date of any change; and | |
91 | ||
92 | b) cause the whole of any work that you distribute or publish, that | |
93 | in whole or in part contains the Program or any part thereof, either | |
94 | with or without modifications, to be licensed at no charge to all | |
95 | third parties under the terms of this General Public License (except | |
96 | that you may choose to grant warranty protection to some or all | |
97 | third parties, at your option). | |
98 | ||
99 | c) If the modified program normally reads commands interactively when | |
100 | run, you must cause it, when started running for such interactive use | |
101 | in the simplest and most usual way, to print or display an | |
102 | announcement including an appropriate copyright notice and a notice | |
103 | that there is no warranty (or else, saying that you provide a | |
104 | warranty) and that users may redistribute the program under these | |
105 | conditions, and telling the user how to view a copy of this General | |
106 | Public License. | |
107 | ||
108 | d) You may charge a fee for the physical act of transferring a | |
109 | copy, and you may at your option offer warranty protection in | |
110 | exchange for a fee. | |
111 | ||
112 | Mere aggregation of another independent work with the Program (or its | |
113 | derivative) on a volume of a storage or distribution medium does not bring | |
114 | the other work under the scope of these terms. | |
115 | ||
116 | 3. You may copy and distribute the Program (or a portion or derivative of | |
117 | it, under Paragraph 2) in object code or executable form under the terms of | |
118 | Paragraphs 1 and 2 above provided that you also do one of the following: | |
119 | ||
120 | a) accompany it with the complete corresponding machine-readable | |
121 | source code, which must be distributed under the terms of | |
122 | Paragraphs 1 and 2 above; or, | |
123 | ||
124 | b) accompany it with a written offer, valid for at least three | |
125 | years, to give any third party free (except for a nominal charge | |
126 | for the cost of distribution) a complete machine-readable copy of the | |
127 | corresponding source code, to be distributed under the terms of | |
128 | Paragraphs 1 and 2 above; or, | |
129 | ||
130 | c) accompany it with the information you received as to where the | |
131 | corresponding source code may be obtained. (This alternative is | |
132 | allowed only for noncommercial distribution and only if you | |
133 | received the program in object code or executable form alone.) | |
134 | ||
135 | Source code for a work means the preferred form of the work for making | |
136 | modifications to it. For an executable file, complete source code means | |
137 | all the source code for all modules it contains; but, as a special | |
138 | exception, it need not include source code for modules which are standard | |
139 | libraries that accompany the operating system on which the executable | |
140 | file runs, or for standard header files or definitions files that | |
141 | accompany that operating system. | |
142 | ||
143 | 4. You may not copy, modify, sublicense, distribute or transfer the | |
144 | Program except as expressly provided under this General Public License. | |
145 | Any attempt otherwise to copy, modify, sublicense, distribute or transfer | |
146 | the Program is void, and will automatically terminate your rights to use | |
147 | the Program under this License. However, parties who have received | |
148 | copies, or rights to use copies, from you under this General Public | |
149 | License will not have their licenses terminated so long as such parties | |
150 | remain in full compliance. | |
151 | ||
152 | 5. By copying, distributing or modifying the Program (or any work based | |
153 | on the Program) you indicate your acceptance of this license to do so, | |
154 | and all its terms and conditions. | |
155 | ||
156 | 6. Each time you redistribute the Program (or any work based on the | |
157 | Program), the recipient automatically receives a license from the original | |
158 | licensor to copy, distribute or modify the Program subject to these | |
159 | terms and conditions. You may not impose any further restrictions on the | |
160 | recipients' exercise of the rights granted herein. | |
161 | ||
162 | 7. The Free Software Foundation may publish revised and/or new versions | |
163 | of the General Public License from time to time. Such new versions will | |
164 | be similar in spirit to the present version, but may differ in detail to | |
165 | address new problems or concerns. | |
166 | ||
167 | Each version is given a distinguishing version number. If the Program | |
168 | specifies a version number of the license which applies to it and "any | |
169 | later version", you have the option of following the terms and conditions | |
170 | either of that version or of any later version published by the Free | |
171 | Software Foundation. If the Program does not specify a version number of | |
172 | the license, you may choose any version ever published by the Free Software | |
173 | Foundation. | |
174 | ||
175 | 8. If you wish to incorporate parts of the Program into other free | |
176 | programs whose distribution conditions are different, write to the author | |
177 | to ask for permission. For software which is copyrighted by the Free | |
178 | Software Foundation, write to the Free Software Foundation; we sometimes | |
179 | make exceptions for this. Our decision will be guided by the two goals | |
180 | of preserving the free status of all derivatives of our free software and | |
181 | of promoting the sharing and reuse of software generally. | |
182 | ||
183 | NO WARRANTY | |
184 | ||
185 | 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY | |
186 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN | |
187 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES | |
188 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED | |
189 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF | |
190 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS | |
191 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE | |
192 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, | |
193 | REPAIR OR CORRECTION. | |
194 | ||
195 | 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING | |
196 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR | |
197 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, | |
198 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING | |
199 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED | |
200 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY | |
201 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER | |
202 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE | |
203 | POSSIBILITY OF SUCH DAMAGES. | |
204 | ||
205 | END OF TERMS AND CONDITIONS | |
206 | ||
207 | Appendix: How to Apply These Terms to Your New Programs | |
208 | ||
209 | If you develop a new program, and you want it to be of the greatest | |
210 | possible use to humanity, the best way to achieve this is to make it | |
211 | free software which everyone can redistribute and change under these | |
212 | terms. | |
213 | ||
214 | To do so, attach the following notices to the program. It is safest to | |
215 | attach them to the start of each source file to most effectively convey | |
216 | the exclusion of warranty; and each file should have at least the | |
217 | "copyright" line and a pointer to where the full notice is found. | |
218 | ||
219 | <one line to give the program's name and a brief idea of what it does.> | |
220 | Copyright (C) 19yy <name of author> | |
221 | ||
222 | This program is free software; you can redistribute it and/or modify | |
223 | it under the terms of the GNU General Public License as published by | |
224 | the Free Software Foundation; either version 1, or (at your option) | |
225 | any later version. | |
226 | ||
227 | This program is distributed in the hope that it will be useful, | |
228 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
229 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
230 | GNU General Public License for more details. | |
231 | ||
232 | You should have received a copy of the GNU General Public License | |
233 | along with this program; if not, write to the Free Software | |
234 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA | |
235 | ||
236 | ||
237 | Also add information on how to contact you by electronic and paper mail. | |
238 | ||
239 | If the program is interactive, make it output a short notice like this | |
240 | when it starts in an interactive mode: | |
241 | ||
242 | Gnomovision version 69, Copyright (C) 19xx name of author | |
243 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. | |
244 | This is free software, and you are welcome to redistribute it | |
245 | under certain conditions; type `show c' for details. | |
246 | ||
247 | The hypothetical commands `show w' and `show c' should show the | |
248 | appropriate parts of the General Public License. Of course, the | |
249 | commands you use may be called something other than `show w' and `show | |
250 | c'; they could even be mouse-clicks or menu items--whatever suits your | |
251 | program. | |
252 | ||
253 | You should also get your employer (if you work as a programmer) or your | |
254 | school, if any, to sign a "copyright disclaimer" for the program, if | |
255 | necessary. Here a sample; alter the names: | |
256 | ||
257 | Yoyodyne, Inc., hereby disclaims all copyright interest in the | |
258 | program `Gnomovision' (a program to direct compilers to make passes | |
259 | at assemblers) written by James Hacker. | |
260 | ||
261 | <signature of Ty Coon>, 1 April 1989 | |
262 | Ty Coon, President of Vice | |
263 | ||
264 | That's all there is to it! | |
265 | ||
266 | ||
267 | --- The Artistic License 1.0 --- | |
268 | ||
269 | This software is Copyright (c) 2022 by Yuval Kogman <nothingmuch@woobling.org>. | |
270 | ||
271 | This is free software, licensed under: | |
272 | ||
273 | The Artistic License 1.0 | |
274 | ||
275 | The Artistic License | |
276 | ||
277 | Preamble | |
278 | ||
279 | The intent of this document is to state the conditions under which a Package | |
280 | may be copied, such that the Copyright Holder maintains some semblance of | |
281 | artistic control over the development of the package, while giving the users of | |
282 | the package the right to use and distribute the Package in a more-or-less | |
283 | customary fashion, plus the right to make reasonable modifications. | |
284 | ||
285 | Definitions: | |
286 | ||
287 | - "Package" refers to the collection of files distributed by the Copyright | |
288 | Holder, and derivatives of that collection of files created through | |
289 | textual modification. | |
290 | - "Standard Version" refers to such a Package if it has not been modified, | |
291 | or has been modified in accordance with the wishes of the Copyright | |
292 | Holder. | |
293 | - "Copyright Holder" is whoever is named in the copyright or copyrights for | |
294 | the package. | |
295 | - "You" is you, if you're thinking about copying or distributing this Package. | |
296 | - "Reasonable copying fee" is whatever you can justify on the basis of media | |
297 | cost, duplication charges, time of people involved, and so on. (You will | |
298 | not be required to justify it to the Copyright Holder, but only to the | |
299 | computing community at large as a market that must bear the fee.) | |
300 | - "Freely Available" means that no fee is charged for the item itself, though | |
301 | there may be fees involved in handling the item. It also means that | |
302 | recipients of the item may redistribute it under the same conditions they | |
303 | received it. | |
304 | ||
305 | 1. You may make and give away verbatim copies of the source form of the | |
306 | Standard Version of this Package without restriction, provided that you | |
307 | duplicate all of the original copyright notices and associated disclaimers. | |
308 | ||
309 | 2. You may apply bug fixes, portability fixes and other modifications derived | |
310 | from the Public Domain or from the Copyright Holder. A Package modified in such | |
311 | a way shall still be considered the Standard Version. | |
312 | ||
313 | 3. You may otherwise modify your copy of this Package in any way, provided that | |
314 | you insert a prominent notice in each changed file stating how and when you | |
315 | changed that file, and provided that you do at least ONE of the following: | |
316 | ||
317 | a) place your modifications in the Public Domain or otherwise make them | |
318 | Freely Available, such as by posting said modifications to Usenet or an | |
319 | equivalent medium, or placing the modifications on a major archive site | |
320 | such as ftp.uu.net, or by allowing the Copyright Holder to include your | |
321 | modifications in the Standard Version of the Package. | |
322 | ||
323 | b) use the modified Package only within your corporation or organization. | |
324 | ||
325 | c) rename any non-standard executables so the names do not conflict with | |
326 | standard executables, which must also be provided, and provide a separate | |
327 | manual page for each non-standard executable that clearly documents how it | |
328 | differs from the Standard Version. | |
329 | ||
330 | d) make other distribution arrangements with the Copyright Holder. | |
331 | ||
332 | 4. You may distribute the programs of this Package in object code or executable | |
333 | form, provided that you do at least ONE of the following: | |
334 | ||
335 | a) distribute a Standard Version of the executables and library files, | |
336 | together with instructions (in the manual page or equivalent) on where to | |
337 | get the Standard Version. | |
338 | ||
339 | b) accompany the distribution with the machine-readable source of the Package | |
340 | with your modifications. | |
341 | ||
342 | c) accompany any non-standard executables with their corresponding Standard | |
343 | Version executables, giving the non-standard executables non-standard | |
344 | names, and clearly documenting the differences in manual pages (or | |
345 | equivalent), together with instructions on where to get the Standard | |
346 | Version. | |
347 | ||
348 | d) make other distribution arrangements with the Copyright Holder. | |
349 | ||
350 | 5. You may charge a reasonable copying fee for any distribution of this | |
351 | Package. You may charge any fee you choose for support of this Package. You | |
352 | may not charge a fee for this Package itself. However, you may distribute this | |
353 | Package in aggregate with other (possibly commercial) programs as part of a | |
354 | larger (possibly commercial) software distribution provided that you do not | |
355 | advertise this Package as a product of your own. | |
356 | ||
357 | 6. The scripts and library files supplied as input to or produced as output | |
358 | from the programs of this Package do not automatically fall under the copyright | |
359 | of this Package, but belong to whomever generated them, and may be sold | |
360 | commercially, and may be aggregated with this Package. | |
361 | ||
362 | 7. C or perl subroutines supplied by you and linked into this Package shall not | |
363 | be considered part of this Package. | |
364 | ||
365 | 8. The name of the Copyright Holder may not be used to endorse or promote | |
366 | products derived from this software without specific prior written permission. | |
367 | ||
368 | 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED | |
369 | WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF | |
370 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. | |
371 | ||
372 | The End | |
373 |
0 | 0 | Changes |
1 | inc/Module/Install.pm | |
2 | inc/Module/Install/AuthorTests.pm | |
3 | inc/Module/Install/Base.pm | |
4 | inc/Module/Install/Can.pm | |
5 | inc/Module/Install/Fetch.pm | |
6 | inc/Module/Install/Makefile.pm | |
7 | inc/Module/Install/Metadata.pm | |
8 | inc/Module/Install/Win32.pm | |
9 | inc/Module/Install/WriteAll.pm | |
10 | 1 | lib/Catalyst/Plugin/Session.pm |
11 | 2 | lib/Catalyst/Plugin/Session/State.pm |
12 | 3 | lib/Catalyst/Plugin/Session/Store.pm |
13 | 4 | lib/Catalyst/Plugin/Session/Store/Dummy.pm |
14 | 5 | lib/Catalyst/Plugin/Session/Test/Store.pm |
15 | 6 | lib/Catalyst/Plugin/Session/Tutorial.pod |
7 | maint/Makefile.PL.include | |
16 | 8 | Makefile.PL |
17 | 9 | MANIFEST This list of files |
18 | META.yml | |
19 | README | |
20 | 10 | t/00_basic_sanity.t |
21 | 11 | t/01_setup.t |
22 | 12 | t/03_flash.t |
23 | 13 | t/05_semi_persistent_flash.t |
24 | t/author/pod.t | |
25 | t/author/podcoverage.t | |
26 | 14 | t/cat_test.t |
27 | 15 | t/lib/FlashTestApp.pm |
28 | 16 | t/lib/FlashTestApp/Controller/Root.pm |
17 | t/lib/MiniUA.pm | |
29 | 18 | t/lib/SessionExpiry.pm |
30 | 19 | t/lib/SessionExpiry/Controller/Root.pm |
31 | 20 | t/lib/SessionTestApp.pm |
39 | 28 | t/live_verify_address.t |
40 | 29 | t/live_verify_user_agent.t |
41 | 30 | t/session_valid.t |
31 | xt/pod.t | |
32 | xt/podcoverage.t | |
33 | META.yml Module YAML meta-data (added by MakeMaker) | |
34 | META.json Module JSON meta-data (added by MakeMaker) | |
35 | README README file (added by Distar) | |
36 | LICENSE LICENSE file (added by Distar) |
0 | { | |
1 | "abstract" : "Generic Session plugin - ties together server side storage and client side state required to maintain session data.", | |
2 | "author" : [ | |
3 | "Yuval Kogman <nothingmuch@woobling.org>" | |
4 | ], | |
5 | "dynamic_config" : 1, | |
6 | "generated_by" : "ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010", | |
7 | "license" : [ | |
8 | "perl_5" | |
9 | ], | |
10 | "meta-spec" : { | |
11 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", | |
12 | "version" : 2 | |
13 | }, | |
14 | "name" : "Catalyst-Plugin-Session", | |
15 | "no_index" : { | |
16 | "directory" : [ | |
17 | "t", | |
18 | "xt" | |
19 | ] | |
20 | }, | |
21 | "prereqs" : { | |
22 | "build" : {}, | |
23 | "configure" : { | |
24 | "requires" : { | |
25 | "ExtUtils::MakeMaker" : "0" | |
26 | } | |
27 | }, | |
28 | "develop" : { | |
29 | "requires" : { | |
30 | "Test::Pod" : "0", | |
31 | "Test::Pod::Coverage" : "0" | |
32 | } | |
33 | }, | |
34 | "runtime" : { | |
35 | "requires" : { | |
36 | "Catalyst::Runtime" : "5.71001", | |
37 | "Digest" : "0", | |
38 | "File::Spec" : "0", | |
39 | "File::Temp" : "0", | |
40 | "HTML::Entities" : "0", | |
41 | "List::Util" : "0", | |
42 | "MRO::Compat" : "0", | |
43 | "Moose" : "0.76", | |
44 | "MooseX::Emulate::Class::Accessor::Fast" : "0.00801", | |
45 | "Object::Signature" : "0", | |
46 | "Test::More" : "0.88", | |
47 | "namespace::clean" : "0.10", | |
48 | "perl" : "5.008" | |
49 | } | |
50 | }, | |
51 | "test" : { | |
52 | "requires" : { | |
53 | "Plack::Test" : "0", | |
54 | "Test::Deep" : "0", | |
55 | "Test::Needs" : "0" | |
56 | } | |
57 | } | |
58 | }, | |
59 | "release_status" : "stable", | |
60 | "resources" : { | |
61 | "bugtracker" : { | |
62 | "mailto" : "bug-Catalyst-Plugin-Session@rt.cpan.org", | |
63 | "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Catalyst-Plugin-Session" | |
64 | }, | |
65 | "license" : [ | |
66 | "http://dev.perl.org/licenses/" | |
67 | ], | |
68 | "repository" : { | |
69 | "type" : "git", | |
70 | "url" : "https://github.com/perl-catalyst/Catalyst-Plugin-Session.git", | |
71 | "web" : "https://github.com/perl-catalyst/Catalyst-Plugin-Session" | |
72 | } | |
73 | }, | |
74 | "version" : "0.43", | |
75 | "x_breaks" : { | |
76 | "Catalyst::Plugin::Session::State::Cookie" : "< 0.03", | |
77 | "Catalyst::Plugin::Session::State::URI" : "< 0.02" | |
78 | }, | |
79 | "x_serialization_backend" : "JSON::PP version 4.07" | |
80 | } |
0 | 0 | --- |
1 | 1 | abstract: 'Generic Session plugin - ties together server side storage and client side state required to maintain session data.' |
2 | 2 | author: |
3 | - 'Andy Grundman' | |
3 | - 'Yuval Kogman <nothingmuch@woobling.org>' | |
4 | 4 | build_requires: |
5 | ExtUtils::MakeMaker: 6.59 | |
6 | Test::Deep: 0 | |
7 | Test::Exception: 0 | |
8 | Test::WWW::Mechanize::PSGI: 0 | |
5 | Plack::Test: '0' | |
6 | Test::Deep: '0' | |
7 | Test::Needs: '0' | |
9 | 8 | configure_requires: |
10 | ExtUtils::MakeMaker: 6.59 | |
11 | distribution_type: module | |
9 | ExtUtils::MakeMaker: '0' | |
12 | 10 | dynamic_config: 1 |
13 | generated_by: 'Module::Install version 1.18' | |
11 | generated_by: 'ExtUtils::MakeMaker version 7.64, CPAN::Meta::Converter version 2.150010' | |
14 | 12 | license: perl |
15 | 13 | meta-spec: |
16 | 14 | url: http://module-build.sourceforge.net/META-spec-v1.4.html |
17 | version: 1.4 | |
15 | version: '1.4' | |
18 | 16 | name: Catalyst-Plugin-Session |
19 | 17 | no_index: |
20 | 18 | directory: |
21 | - inc | |
22 | 19 | - t |
20 | - xt | |
23 | 21 | requires: |
24 | 22 | Catalyst::Runtime: '5.71001' |
25 | Digest: 0 | |
26 | File::Spec: 0 | |
27 | File::Temp: 0 | |
28 | HTML::Entities: 0 | |
29 | List::Util: 0 | |
30 | MRO::Compat: 0 | |
23 | Digest: '0' | |
24 | File::Spec: '0' | |
25 | File::Temp: '0' | |
26 | HTML::Entities: '0' | |
27 | List::Util: '0' | |
28 | MRO::Compat: '0' | |
31 | 29 | Moose: '0.76' |
32 | 30 | MooseX::Emulate::Class::Accessor::Fast: '0.00801' |
33 | Object::Signature: 0 | |
31 | Object::Signature: '0' | |
34 | 32 | Test::More: '0.88' |
35 | Tie::RefHash: '1.34' | |
36 | 33 | namespace::clean: '0.10' |
37 | perl: 5.8.0 | |
34 | perl: '5.008' | |
38 | 35 | resources: |
36 | bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Catalyst-Plugin-Session | |
39 | 37 | license: http://dev.perl.org/licenses/ |
40 | repository: git://git.shadowcat.co.uk/catagits/Catalyst-Plugin-Session.git | |
41 | version: '0.41' | |
38 | repository: https://github.com/perl-catalyst/Catalyst-Plugin-Session.git | |
39 | version: '0.43' | |
40 | x_breaks: | |
41 | Catalyst::Plugin::Session::State::Cookie: '< 0.03' | |
42 | Catalyst::Plugin::Session::State::URI: '< 0.02' | |
43 | x_serialization_backend: 'CPAN::Meta::YAML version 0.018' |
0 | use inc::Module::Install 0.87; | |
1 | use Module::Install::AuthorTests; | |
0 | use strict; | |
1 | use warnings; | |
2 | use 5.008; | |
2 | 3 | |
3 | if ( -e 'MANIFEST.SKIP' ) { | |
4 | system( 'pod2text lib/Catalyst/Plugin/Session.pm > README' ) | |
5 | and die("Could not run pod2text on lib/Catalyst/Plugin/Session.pm"); | |
6 | } | |
4 | my %META = ( | |
5 | name => 'Catalyst-Plugin-Session', | |
6 | license => 'perl_5', | |
7 | prereqs => { | |
8 | configure => { requires => { | |
9 | 'ExtUtils::MakeMaker' => 0, | |
10 | } }, | |
11 | test => { | |
12 | requires => { | |
13 | 'Plack::Test' => 0, | |
14 | 'Test::Deep' => 0, | |
15 | 'Test::Needs' => 0, | |
16 | }, | |
17 | }, | |
18 | runtime => { | |
19 | requires => { | |
20 | 'Catalyst::Runtime' => '5.71001', | |
21 | 'namespace::clean' => '0.10', | |
22 | 'Digest' => 0, | |
23 | 'File::Spec' => 0, | |
24 | 'File::Temp' => 0, | |
25 | 'List::Util' => 0, | |
26 | 'Object::Signature' => 0, | |
27 | 'MRO::Compat' => 0, | |
28 | 'MooseX::Emulate::Class::Accessor::Fast' => '0.00801', | |
29 | 'Moose' => '0.76', | |
30 | 'HTML::Entities' => 0, | |
31 | 'Test::More' => '0.88', | |
32 | 'perl' => '5.008', | |
33 | }, | |
34 | }, | |
35 | develop => { | |
36 | requires => { | |
37 | 'Test::Pod' => 0, | |
38 | 'Test::Pod::Coverage' => 0, | |
39 | }, | |
40 | }, | |
41 | }, | |
42 | x_breaks => { | |
43 | 'Catalyst::Plugin::Session::State::Cookie' => '< 0.03', | |
44 | 'Catalyst::Plugin::Session::State::URI' => '< 0.02', | |
45 | }, | |
46 | resources => { | |
47 | repository => { | |
48 | url => 'https://github.com/perl-catalyst/Catalyst-Plugin-Session.git', | |
49 | web => 'https://github.com/perl-catalyst/Catalyst-Plugin-Session', | |
50 | type => 'git', | |
51 | }, | |
52 | bugtracker => { | |
53 | web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Catalyst-Plugin-Session', | |
54 | mailto => 'bug-Catalyst-Plugin-Session@rt.cpan.org', | |
55 | }, | |
56 | license => [ 'http://dev.perl.org/licenses/' ], | |
57 | }, | |
58 | no_index => { | |
59 | directory => [ 't', 'xt' ] | |
60 | }, | |
61 | ); | |
7 | 62 | |
8 | is_upgrading_needed(); | |
63 | my %MM_ARGS = (); | |
9 | 64 | |
10 | perl_version '5.008'; | |
11 | ||
12 | name 'Catalyst-Plugin-Session'; | |
13 | all_from 'lib/Catalyst/Plugin/Session.pm'; | |
14 | ||
15 | requires 'Catalyst::Runtime' => '5.71001'; | |
16 | requires 'namespace::clean' => '0.10'; | |
17 | requires 'Digest'; | |
18 | requires 'File::Spec'; | |
19 | requires 'File::Temp'; | |
20 | requires 'List::Util'; | |
21 | requires 'Object::Signature'; | |
22 | requires 'MRO::Compat'; | |
23 | requires 'MooseX::Emulate::Class::Accessor::Fast' => '0.00801'; | |
24 | requires 'Moose' => '0.76'; | |
25 | requires 'HTML::Entities'; | |
26 | ||
27 | # an indirect dep. needs a certain version. | |
28 | requires 'Tie::RefHash' => '1.34'; | |
29 | ||
30 | # for Test::Store | |
31 | requires 'Test::More' => '0.88'; | |
32 | ||
33 | test_requires 'Test::Deep'; | |
34 | test_requires 'Test::Exception'; | |
35 | test_requires 'Test::WWW::Mechanize::PSGI'; | |
36 | resources repository => 'git://git.shadowcat.co.uk/catagits/Catalyst-Plugin-Session.git'; | |
37 | ||
38 | author_tests 't/author'; | |
39 | ||
40 | WriteAll; | |
41 | ||
42 | sub is_upgrading_needed { | |
43 | my %state = ( | |
44 | Cookie => 0.03, | |
45 | URI => 0.02, | |
46 | ); | |
47 | ||
48 | foreach my $module (keys %state) { | |
49 | my $package = 'Catalyst::Plugin::Session::State::' . $module; | |
50 | ||
51 | next if not eval "require $package;"; | |
52 | ||
53 | if( not eval { $package->VERSION( $state{ $module } ); } ) { | |
54 | warn <<WARN; | |
65 | for my $breaks (sort keys %{ $META{x_breaks} }) { | |
66 | my $version = $META{x_breaks}{$breaks}; | |
67 | $version =~ s{\A<\s+([0-9.]+)\z}{$1} or die "can't handle $version"; | |
68 | if (eval "require $breaks") { | |
69 | if (!eval { $breaks->VERSION($version) }) { | |
70 | warn <<WARN; | |
55 | 71 | ********** NOTE ********** |
56 | 72 | |
57 | $package must also be updated! | |
73 | $breaks must also be updated! | |
58 | 74 | |
59 | 75 | The currently installed version is *not* compatible with this version of |
60 | 76 | Catalyst::Plugin::Session! |
63 | 79 | |
64 | 80 | ************************** |
65 | 81 | WARN |
66 | } | |
67 | 82 | } |
83 | } | |
68 | 84 | } |
85 | ||
86 | ## BOILERPLATE ############################################################### | |
87 | require ExtUtils::MakeMaker; | |
88 | (do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; | |
89 | ||
90 | # have to do this since old EUMM dev releases miss the eval $VERSION line | |
91 | my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; | |
92 | my $mymeta = $eumm_version >= 6.57_02; | |
93 | my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; | |
94 | ||
95 | ($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; | |
96 | ($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; | |
97 | $META{license} = [ $META{license} ] | |
98 | if $META{license} && !ref $META{license}; | |
99 | $MM_ARGS{LICENSE} = $META{license}[0] | |
100 | if $META{license} && $eumm_version >= 6.30; | |
101 | $MM_ARGS{NO_MYMETA} = 1 | |
102 | if $mymeta_broken; | |
103 | $MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } | |
104 | unless -f 'META.yml'; | |
105 | $MM_ARGS{PL_FILES} ||= {}; | |
106 | $MM_ARGS{NORECURS} = 1 | |
107 | if not exists $MM_ARGS{NORECURS}; | |
108 | ||
109 | for (qw(configure build test runtime)) { | |
110 | my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; | |
111 | my $r = $MM_ARGS{$key} = { | |
112 | %{$META{prereqs}{$_}{requires} || {}}, | |
113 | %{delete $MM_ARGS{$key} || {}}, | |
114 | }; | |
115 | defined $r->{$_} or delete $r->{$_} for keys %$r; | |
116 | } | |
117 | ||
118 | $MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0; | |
119 | ||
120 | delete $MM_ARGS{MIN_PERL_VERSION} | |
121 | if $eumm_version < 6.47_01; | |
122 | $MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} | |
123 | if $eumm_version < 6.63_03; | |
124 | $MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} | |
125 | if $eumm_version < 6.55_01; | |
126 | delete $MM_ARGS{CONFIGURE_REQUIRES} | |
127 | if $eumm_version < 6.51_03; | |
128 | ||
129 | ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS); | |
130 | ## END BOILERPLATE ########################################################### |
0 | #line 1 | |
1 | package Module::Install::AuthorTests; | |
2 | ||
3 | use 5.005; | |
4 | use strict; | |
5 | use Module::Install::Base; | |
6 | use Carp (); | |
7 | ||
8 | #line 16 | |
9 | ||
10 | use vars qw{$VERSION $ISCORE @ISA}; | |
11 | BEGIN { | |
12 | $VERSION = '0.002'; | |
13 | $ISCORE = 1; | |
14 | @ISA = qw{Module::Install::Base}; | |
15 | } | |
16 | ||
17 | #line 42 | |
18 | ||
19 | sub author_tests { | |
20 | my ($self, @dirs) = @_; | |
21 | _add_author_tests($self, \@dirs, 0); | |
22 | } | |
23 | ||
24 | #line 56 | |
25 | ||
26 | sub recursive_author_tests { | |
27 | my ($self, @dirs) = @_; | |
28 | _add_author_tests($self, \@dirs, 1); | |
29 | } | |
30 | ||
31 | sub _wanted { | |
32 | my $href = shift; | |
33 | sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } | |
34 | } | |
35 | ||
36 | sub _add_author_tests { | |
37 | my ($self, $dirs, $recurse) = @_; | |
38 | return unless $Module::Install::AUTHOR; | |
39 | ||
40 | my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t'; | |
41 | ||
42 | # XXX: pick a default, later -- rjbs, 2008-02-24 | |
43 | my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests"; | |
44 | @dirs = grep { -d } @dirs; | |
45 | ||
46 | if ($recurse) { | |
47 | require File::Find; | |
48 | my %test_dir; | |
49 | File::Find::find(_wanted(\%test_dir), @dirs); | |
50 | $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir ); | |
51 | } else { | |
52 | $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs ); | |
53 | } | |
54 | } | |
55 | ||
56 | #line 107 | |
57 | ||
58 | 1; |
0 | #line 1 | |
1 | package Module::Install::Base; | |
2 | ||
3 | use strict 'vars'; | |
4 | use vars qw{$VERSION}; | |
5 | BEGIN { | |
6 | $VERSION = '1.18'; | |
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 |
0 | #line 1 | |
1 | package Module::Install::Can; | |
2 | ||
3 | use strict; | |
4 | use Config (); | |
5 | use ExtUtils::MakeMaker (); | |
6 | use Module::Install::Base (); | |
7 | ||
8 | use vars qw{$VERSION @ISA $ISCORE}; | |
9 | BEGIN { | |
10 | $VERSION = '1.18'; | |
11 | @ISA = 'Module::Install::Base'; | |
12 | $ISCORE = 1; | |
13 | } | |
14 | ||
15 | # check if we can load some module | |
16 | ### Upgrade this to not have to load the module if possible | |
17 | sub can_use { | |
18 | my ($self, $mod, $ver) = @_; | |
19 | $mod =~ s{::|\\}{/}g; | |
20 | $mod .= '.pm' unless $mod =~ /\.pm$/i; | |
21 | ||
22 | my $pkg = $mod; | |
23 | $pkg =~ s{/}{::}g; | |
24 | $pkg =~ s{\.pm$}{}i; | |
25 | ||
26 | local $@; | |
27 | eval { require $mod; $pkg->VERSION($ver || 0); 1 }; | |
28 | } | |
29 | ||
30 | # Check if we can run some command | |
31 | sub can_run { | |
32 | my ($self, $cmd) = @_; | |
33 | ||
34 | my $_cmd = $cmd; | |
35 | return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); | |
36 | ||
37 | for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { | |
38 | next if $dir eq ''; | |
39 | require File::Spec; | |
40 | my $abs = File::Spec->catfile($dir, $cmd); | |
41 | return $abs if (-x $abs or $abs = MM->maybe_command($abs)); | |
42 | } | |
43 | ||
44 | return; | |
45 | } | |
46 | ||
47 | # Can our C compiler environment build XS files | |
48 | sub can_xs { | |
49 | my $self = shift; | |
50 | ||
51 | # Ensure we have the CBuilder module | |
52 | $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); | |
53 | ||
54 | # Do we have the configure_requires checker? | |
55 | local $@; | |
56 | eval "require ExtUtils::CBuilder;"; | |
57 | if ( $@ ) { | |
58 | # They don't obey configure_requires, so it is | |
59 | # someone old and delicate. Try to avoid hurting | |
60 | # them by falling back to an older simpler test. | |
61 | return $self->can_cc(); | |
62 | } | |
63 | ||
64 | # Do we have a working C compiler | |
65 | my $builder = ExtUtils::CBuilder->new( | |
66 | quiet => 1, | |
67 | ); | |
68 | unless ( $builder->have_compiler ) { | |
69 | # No working C compiler | |
70 | return 0; | |
71 | } | |
72 | ||
73 | # Write a C file representative of what XS becomes | |
74 | require File::Temp; | |
75 | my ( $FH, $tmpfile ) = File::Temp::tempfile( | |
76 | "compilexs-XXXXX", | |
77 | SUFFIX => '.c', | |
78 | ); | |
79 | binmode $FH; | |
80 | print $FH <<'END_C'; | |
81 | #include "EXTERN.h" | |
82 | #include "perl.h" | |
83 | #include "XSUB.h" | |
84 | ||
85 | int main(int argc, char **argv) { | |
86 | return 0; | |
87 | } | |
88 | ||
89 | int boot_sanexs() { | |
90 | return 1; | |
91 | } | |
92 | ||
93 | END_C | |
94 | close $FH; | |
95 | ||
96 | # Can the C compiler access the same headers XS does | |
97 | my @libs = (); | |
98 | my $object = undef; | |
99 | eval { | |
100 | local $^W = 0; | |
101 | $object = $builder->compile( | |
102 | source => $tmpfile, | |
103 | ); | |
104 | @libs = $builder->link( | |
105 | objects => $object, | |
106 | module_name => 'sanexs', | |
107 | ); | |
108 | }; | |
109 | my $result = $@ ? 0 : 1; | |
110 | ||
111 | # Clean up all the build files | |
112 | foreach ( $tmpfile, $object, @libs ) { | |
113 | next unless defined $_; | |
114 | 1 while unlink; | |
115 | } | |
116 | ||
117 | return $result; | |
118 | } | |
119 | ||
120 | # Can we locate a (the) C compiler | |
121 | sub can_cc { | |
122 | my $self = shift; | |
123 | ||
124 | if ($^O eq 'VMS') { | |
125 | require ExtUtils::CBuilder; | |
126 | my $builder = ExtUtils::CBuilder->new( | |
127 | quiet => 1, | |
128 | ); | |
129 | return $builder->have_compiler; | |
130 | } | |
131 | ||
132 | my @chunks = split(/ /, $Config::Config{cc}) or return; | |
133 | ||
134 | # $Config{cc} may contain args; try to find out the program part | |
135 | while (@chunks) { | |
136 | return $self->can_run("@chunks") || (pop(@chunks), next); | |
137 | } | |
138 | ||
139 | return; | |
140 | } | |
141 | ||
142 | # Fix Cygwin bug on maybe_command(); | |
143 | if ( $^O eq 'cygwin' ) { | |
144 | require ExtUtils::MM_Cygwin; | |
145 | require ExtUtils::MM_Win32; | |
146 | if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { | |
147 | *ExtUtils::MM_Cygwin::maybe_command = sub { | |
148 | my ($self, $file) = @_; | |
149 | if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { | |
150 | ExtUtils::MM_Win32->maybe_command($file); | |
151 | } else { | |
152 | ExtUtils::MM_Unix->maybe_command($file); | |
153 | } | |
154 | } | |
155 | } | |
156 | } | |
157 | ||
158 | 1; | |
159 | ||
160 | __END__ | |
161 | ||
162 | #line 245 |
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.18'; | |
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; |
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.18'; | |
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-separated 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 | # This previous attempted to inherit the version of | |
218 | # ExtUtils::MakeMaker in use by the module author, but this | |
219 | # was found to be untenable as some authors build releases | |
220 | # using future dev versions of EU:MM that nobody else has. | |
221 | # Instead, #toolchain suggests we use 6.59 which is the most | |
222 | # stable version on CPAN at time of writing and is, to quote | |
223 | # ribasushi, "not terminally fucked, > and tested enough". | |
224 | # TODO: We will now need to maintain this over time to push | |
225 | # the version up as new versions are released. | |
226 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); | |
227 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); | |
228 | } else { | |
229 | # Allow legacy-compatibility with 5.005 by depending on the | |
230 | # most recent EU:MM that supported 5.005. | |
231 | $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); | |
232 | $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); | |
233 | } | |
234 | ||
235 | # Generate the MakeMaker params | |
236 | my $args = $self->makemaker_args; | |
237 | $args->{DISTNAME} = $self->name; | |
238 | $args->{NAME} = $self->module_name || $self->name; | |
239 | $args->{NAME} =~ s/-/::/g; | |
240 | $args->{VERSION} = $self->version or die <<'EOT'; | |
241 | ERROR: Can't determine distribution version. Please specify it | |
242 | explicitly via 'version' in Makefile.PL, or set a valid $VERSION | |
243 | in a module, and provide its file path via 'version_from' (or | |
244 | 'all_from' if you prefer) in Makefile.PL. | |
245 | EOT | |
246 | ||
247 | if ( $self->tests ) { | |
248 | my @tests = split ' ', $self->tests; | |
249 | my %seen; | |
250 | $args->{test} = { | |
251 | TESTS => (join ' ', grep {!$seen{$_}++} @tests), | |
252 | }; | |
253 | } elsif ( $Module::Install::ExtraTests::use_extratests ) { | |
254 | # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. | |
255 | # So, just ignore our xt tests here. | |
256 | } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { | |
257 | $args->{test} = { | |
258 | TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), | |
259 | }; | |
260 | } | |
261 | if ( $] >= 5.005 ) { | |
262 | $args->{ABSTRACT} = $self->abstract; | |
263 | $args->{AUTHOR} = join ', ', @{$self->author || []}; | |
264 | } | |
265 | if ( $self->makemaker(6.10) ) { | |
266 | $args->{NO_META} = 1; | |
267 | #$args->{NO_MYMETA} = 1; | |
268 | } | |
269 | if ( $self->makemaker(6.17) and $self->sign ) { | |
270 | $args->{SIGN} = 1; | |
271 | } | |
272 | unless ( $self->is_admin ) { | |
273 | delete $args->{SIGN}; | |
274 | } | |
275 | if ( $self->makemaker(6.31) and $self->license ) { | |
276 | $args->{LICENSE} = $self->license; | |
277 | } | |
278 | ||
279 | my $prereq = ($args->{PREREQ_PM} ||= {}); | |
280 | %$prereq = ( %$prereq, | |
281 | map { @$_ } # flatten [module => version] | |
282 | map { @$_ } | |
283 | grep $_, | |
284 | ($self->requires) | |
285 | ); | |
286 | ||
287 | # Remove any reference to perl, PREREQ_PM doesn't support it | |
288 | delete $args->{PREREQ_PM}->{perl}; | |
289 | ||
290 | # Merge both kinds of requires into BUILD_REQUIRES | |
291 | my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); | |
292 | %$build_prereq = ( %$build_prereq, | |
293 | map { @$_ } # flatten [module => version] | |
294 | map { @$_ } | |
295 | grep $_, | |
296 | ($self->configure_requires, $self->build_requires) | |
297 | ); | |
298 | ||
299 | # Remove any reference to perl, BUILD_REQUIRES doesn't support it | |
300 | delete $args->{BUILD_REQUIRES}->{perl}; | |
301 | ||
302 | # Delete bundled dists from prereq_pm, add it to Makefile DIR | |
303 | my $subdirs = ($args->{DIR} || []); | |
304 | if ($self->bundles) { | |
305 | my %processed; | |
306 | foreach my $bundle (@{ $self->bundles }) { | |
307 | my ($mod_name, $dist_dir) = @$bundle; | |
308 | delete $prereq->{$mod_name}; | |
309 | $dist_dir = File::Basename::basename($dist_dir); # dir for building this module | |
310 | if (not exists $processed{$dist_dir}) { | |
311 | if (-d $dist_dir) { | |
312 | # List as sub-directory to be processed by make | |
313 | push @$subdirs, $dist_dir; | |
314 | } | |
315 | # Else do nothing: the module is already present on the system | |
316 | $processed{$dist_dir} = undef; | |
317 | } | |
318 | } | |
319 | } | |
320 | ||
321 | unless ( $self->makemaker('6.55_03') ) { | |
322 | %$prereq = (%$prereq,%$build_prereq); | |
323 | delete $args->{BUILD_REQUIRES}; | |
324 | } | |
325 | ||
326 | if ( my $perl_version = $self->perl_version ) { | |
327 | eval "use $perl_version; 1" | |
328 | or die "ERROR: perl: Version $] is installed, " | |
329 | . "but we need version >= $perl_version"; | |
330 | ||
331 | if ( $self->makemaker(6.48) ) { | |
332 | $args->{MIN_PERL_VERSION} = $perl_version; | |
333 | } | |
334 | } | |
335 | ||
336 | if ($self->installdirs) { | |
337 | warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; | |
338 | $args->{INSTALLDIRS} = $self->installdirs; | |
339 | } | |
340 | ||
341 | my %args = map { | |
342 | ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) | |
343 | } keys %$args; | |
344 | ||
345 | my $user_preop = delete $args{dist}->{PREOP}; | |
346 | if ( my $preop = $self->admin->preop($user_preop) ) { | |
347 | foreach my $key ( keys %$preop ) { | |
348 | $args{dist}->{$key} = $preop->{$key}; | |
349 | } | |
350 | } | |
351 | ||
352 | my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); | |
353 | $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); | |
354 | } | |
355 | ||
356 | sub fix_up_makefile { | |
357 | my $self = shift; | |
358 | my $makefile_name = shift; | |
359 | my $top_class = ref($self->_top) || ''; | |
360 | my $top_version = $self->_top->VERSION || ''; | |
361 | ||
362 | my $preamble = $self->preamble | |
363 | ? "# Preamble by $top_class $top_version\n" | |
364 | . $self->preamble | |
365 | : ''; | |
366 | my $postamble = "# Postamble by $top_class $top_version\n" | |
367 | . ($self->postamble || ''); | |
368 | ||
369 | local *MAKEFILE; | |
370 | open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; | |
371 | eval { flock MAKEFILE, LOCK_EX }; | |
372 | my $makefile = do { local $/; <MAKEFILE> }; | |
373 | ||
374 | $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; | |
375 | $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; | |
376 | $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; | |
377 | $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; | |
378 | $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; | |
379 | ||
380 | # Module::Install will never be used to build the Core Perl | |
381 | # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks | |
382 | # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist | |
383 | $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; | |
384 | #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; | |
385 | ||
386 | # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. | |
387 | $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; | |
388 | ||
389 | # XXX - This is currently unused; not sure if it breaks other MM-users | |
390 | # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; | |
391 | ||
392 | seek MAKEFILE, 0, SEEK_SET; | |
393 | truncate MAKEFILE, 0; | |
394 | print MAKEFILE "$preamble$makefile$postamble" or die $!; | |
395 | close MAKEFILE or die $!; | |
396 | ||
397 | 1; | |
398 | } | |
399 | ||
400 | sub preamble { | |
401 | my ($self, $text) = @_; | |
402 | $self->{preamble} = $text . $self->{preamble} if defined $text; | |
403 | $self->{preamble}; | |
404 | } | |
405 | ||
406 | sub postamble { | |
407 | my ($self, $text) = @_; | |
408 | $self->{postamble} ||= $self->admin->postamble; | |
409 | $self->{postamble} .= $text if defined $text; | |
410 | $self->{postamble} | |
411 | } | |
412 | ||
413 | 1; | |
414 | ||
415 | __END__ | |
416 | ||
417 | #line 544 |
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.18'; | |
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 | my $value = @_ ? shift : 1; | |
155 | if ( $self->{values}->{dynamic_config} ) { | |
156 | # Once dynamic we never change to static, for safety | |
157 | return 0; | |
158 | } | |
159 | $self->{values}->{dynamic_config} = $value ? 1 : 0; | |
160 | return 1; | |
161 | } | |
162 | ||
163 | # Convenience command | |
164 | sub static_config { | |
165 | shift->dynamic_config(0); | |
166 | } | |
167 | ||
168 | sub perl_version { | |
169 | my $self = shift; | |
170 | return $self->{values}->{perl_version} unless @_; | |
171 | my $version = shift or die( | |
172 | "Did not provide a value to perl_version()" | |
173 | ); | |
174 | ||
175 | # Normalize the version | |
176 | $version = $self->_perl_version($version); | |
177 | ||
178 | # We don't support the really old versions | |
179 | unless ( $version >= 5.005 ) { | |
180 | die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; | |
181 | } | |
182 | ||
183 | $self->{values}->{perl_version} = $version; | |
184 | } | |
185 | ||
186 | sub all_from { | |
187 | my ( $self, $file ) = @_; | |
188 | ||
189 | unless ( defined($file) ) { | |
190 | my $name = $self->name or die( | |
191 | "all_from called with no args without setting name() first" | |
192 | ); | |
193 | $file = join('/', 'lib', split(/-/, $name)) . '.pm'; | |
194 | $file =~ s{.*/}{} unless -e $file; | |
195 | unless ( -e $file ) { | |
196 | die("all_from cannot find $file from $name"); | |
197 | } | |
198 | } | |
199 | unless ( -f $file ) { | |
200 | die("The path '$file' does not exist, or is not a file"); | |
201 | } | |
202 | ||
203 | $self->{values}{all_from} = $file; | |
204 | ||
205 | # Some methods pull from POD instead of code. | |
206 | # If there is a matching .pod, use that instead | |
207 | my $pod = $file; | |
208 | $pod =~ s/\.pm$/.pod/i; | |
209 | $pod = $file unless -e $pod; | |
210 | ||
211 | # Pull the different values | |
212 | $self->name_from($file) unless $self->name; | |
213 | $self->version_from($file) unless $self->version; | |
214 | $self->perl_version_from($file) unless $self->perl_version; | |
215 | $self->author_from($pod) unless @{$self->author || []}; | |
216 | $self->license_from($pod) unless $self->license; | |
217 | $self->abstract_from($pod) unless $self->abstract; | |
218 | ||
219 | return 1; | |
220 | } | |
221 | ||
222 | sub provides { | |
223 | my $self = shift; | |
224 | my $provides = ( $self->{values}->{provides} ||= {} ); | |
225 | %$provides = (%$provides, @_) if @_; | |
226 | return $provides; | |
227 | } | |
228 | ||
229 | sub auto_provides { | |
230 | my $self = shift; | |
231 | return $self unless $self->is_admin; | |
232 | unless (-e 'MANIFEST') { | |
233 | warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; | |
234 | return $self; | |
235 | } | |
236 | # Avoid spurious warnings as we are not checking manifest here. | |
237 | local $SIG{__WARN__} = sub {1}; | |
238 | require ExtUtils::Manifest; | |
239 | local *ExtUtils::Manifest::manicheck = sub { return }; | |
240 | ||
241 | require Module::Build; | |
242 | my $build = Module::Build->new( | |
243 | dist_name => $self->name, | |
244 | dist_version => $self->version, | |
245 | license => $self->license, | |
246 | ); | |
247 | $self->provides( %{ $build->find_dist_packages || {} } ); | |
248 | } | |
249 | ||
250 | sub feature { | |
251 | my $self = shift; | |
252 | my $name = shift; | |
253 | my $features = ( $self->{values}->{features} ||= [] ); | |
254 | my $mods; | |
255 | ||
256 | if ( @_ == 1 and ref( $_[0] ) ) { | |
257 | # The user used ->feature like ->features by passing in the second | |
258 | # argument as a reference. Accomodate for that. | |
259 | $mods = $_[0]; | |
260 | } else { | |
261 | $mods = \@_; | |
262 | } | |
263 | ||
264 | my $count = 0; | |
265 | push @$features, ( | |
266 | $name => [ | |
267 | map { | |
268 | ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ | |
269 | } @$mods | |
270 | ] | |
271 | ); | |
272 | ||
273 | return @$features; | |
274 | } | |
275 | ||
276 | sub features { | |
277 | my $self = shift; | |
278 | while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { | |
279 | $self->feature( $name, @$mods ); | |
280 | } | |
281 | return $self->{values}->{features} | |
282 | ? @{ $self->{values}->{features} } | |
283 | : (); | |
284 | } | |
285 | ||
286 | sub no_index { | |
287 | my $self = shift; | |
288 | my $type = shift; | |
289 | push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; | |
290 | return $self->{values}->{no_index}; | |
291 | } | |
292 | ||
293 | sub read { | |
294 | my $self = shift; | |
295 | $self->include_deps( 'YAML::Tiny', 0 ); | |
296 | ||
297 | require YAML::Tiny; | |
298 | my $data = YAML::Tiny::LoadFile('META.yml'); | |
299 | ||
300 | # Call methods explicitly in case user has already set some values. | |
301 | while ( my ( $key, $value ) = each %$data ) { | |
302 | next unless $self->can($key); | |
303 | if ( ref $value eq 'HASH' ) { | |
304 | while ( my ( $module, $version ) = each %$value ) { | |
305 | $self->can($key)->($self, $module => $version ); | |
306 | } | |
307 | } else { | |
308 | $self->can($key)->($self, $value); | |
309 | } | |
310 | } | |
311 | return $self; | |
312 | } | |
313 | ||
314 | sub write { | |
315 | my $self = shift; | |
316 | return $self unless $self->is_admin; | |
317 | $self->admin->write_meta; | |
318 | return $self; | |
319 | } | |
320 | ||
321 | sub version_from { | |
322 | require ExtUtils::MM_Unix; | |
323 | my ( $self, $file ) = @_; | |
324 | $self->version( ExtUtils::MM_Unix->parse_version($file) ); | |
325 | ||
326 | # for version integrity check | |
327 | $self->makemaker_args( VERSION_FROM => $file ); | |
328 | } | |
329 | ||
330 | sub abstract_from { | |
331 | require ExtUtils::MM_Unix; | |
332 | my ( $self, $file ) = @_; | |
333 | $self->abstract( | |
334 | bless( | |
335 | { DISTNAME => $self->name }, | |
336 | 'ExtUtils::MM_Unix' | |
337 | )->parse_abstract($file) | |
338 | ); | |
339 | } | |
340 | ||
341 | # Add both distribution and module name | |
342 | sub name_from { | |
343 | my ($self, $file) = @_; | |
344 | if ( | |
345 | Module::Install::_read($file) =~ m/ | |
346 | ^ \s* | |
347 | package \s* | |
348 | ([\w:]+) | |
349 | [\s|;]* | |
350 | /ixms | |
351 | ) { | |
352 | my ($name, $module_name) = ($1, $1); | |
353 | $name =~ s{::}{-}g; | |
354 | $self->name($name); | |
355 | unless ( $self->module_name ) { | |
356 | $self->module_name($module_name); | |
357 | } | |
358 | } else { | |
359 | die("Cannot determine name from $file\n"); | |
360 | } | |
361 | } | |
362 | ||
363 | sub _extract_perl_version { | |
364 | if ( | |
365 | $_[0] =~ m/ | |
366 | ^\s* | |
367 | (?:use|require) \s* | |
368 | v? | |
369 | ([\d_\.]+) | |
370 | \s* ; | |
371 | /ixms | |
372 | ) { | |
373 | my $perl_version = $1; | |
374 | $perl_version =~ s{_}{}g; | |
375 | return $perl_version; | |
376 | } else { | |
377 | return; | |
378 | } | |
379 | } | |
380 | ||
381 | sub perl_version_from { | |
382 | my $self = shift; | |
383 | my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); | |
384 | if ($perl_version) { | |
385 | $self->perl_version($perl_version); | |
386 | } else { | |
387 | warn "Cannot determine perl version info from $_[0]\n"; | |
388 | return; | |
389 | } | |
390 | } | |
391 | ||
392 | sub author_from { | |
393 | my $self = shift; | |
394 | my $content = Module::Install::_read($_[0]); | |
395 | if ($content =~ m/ | |
396 | =head \d \s+ (?:authors?)\b \s* | |
397 | ([^\n]*) | |
398 | | | |
399 | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* | |
400 | .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* | |
401 | ([^\n]*) | |
402 | /ixms) { | |
403 | my $author = $1 || $2; | |
404 | ||
405 | # XXX: ugly but should work anyway... | |
406 | if (eval "require Pod::Escapes; 1") { | |
407 | # Pod::Escapes has a mapping table. | |
408 | # It's in core of perl >= 5.9.3, and should be installed | |
409 | # as one of the Pod::Simple's prereqs, which is a prereq | |
410 | # of Pod::Text 3.x (see also below). | |
411 | $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } | |
412 | { | |
413 | defined $2 | |
414 | ? chr($2) | |
415 | : defined $Pod::Escapes::Name2character_number{$1} | |
416 | ? chr($Pod::Escapes::Name2character_number{$1}) | |
417 | : do { | |
418 | warn "Unknown escape: E<$1>"; | |
419 | "E<$1>"; | |
420 | }; | |
421 | }gex; | |
422 | } | |
423 | elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { | |
424 | # Pod::Text < 3.0 has yet another mapping table, | |
425 | # though the table name of 2.x and 1.x are different. | |
426 | # (1.x is in core of Perl < 5.6, 2.x is in core of | |
427 | # Perl < 5.9.3) | |
428 | my $mapping = ($Pod::Text::VERSION < 2) | |
429 | ? \%Pod::Text::HTML_Escapes | |
430 | : \%Pod::Text::ESCAPES; | |
431 | $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } | |
432 | { | |
433 | defined $2 | |
434 | ? chr($2) | |
435 | : defined $mapping->{$1} | |
436 | ? $mapping->{$1} | |
437 | : do { | |
438 | warn "Unknown escape: E<$1>"; | |
439 | "E<$1>"; | |
440 | }; | |
441 | }gex; | |
442 | } | |
443 | else { | |
444 | $author =~ s{E<lt>}{<}g; | |
445 | $author =~ s{E<gt>}{>}g; | |
446 | } | |
447 | $self->author($author); | |
448 | } else { | |
449 | warn "Cannot determine author info from $_[0]\n"; | |
450 | } | |
451 | } | |
452 | ||
453 | #Stolen from M::B | |
454 | my %license_urls = ( | |
455 | perl => 'http://dev.perl.org/licenses/', | |
456 | apache => 'http://apache.org/licenses/LICENSE-2.0', | |
457 | apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', | |
458 | artistic => 'http://opensource.org/licenses/artistic-license.php', | |
459 | artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', | |
460 | lgpl => 'http://opensource.org/licenses/lgpl-license.php', | |
461 | lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', | |
462 | lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', | |
463 | bsd => 'http://opensource.org/licenses/bsd-license.php', | |
464 | gpl => 'http://opensource.org/licenses/gpl-license.php', | |
465 | gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', | |
466 | gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', | |
467 | mit => 'http://opensource.org/licenses/mit-license.php', | |
468 | mozilla => 'http://opensource.org/licenses/mozilla1.1.php', | |
469 | open_source => undef, | |
470 | unrestricted => undef, | |
471 | restrictive => undef, | |
472 | unknown => undef, | |
473 | ); | |
474 | ||
475 | sub license { | |
476 | my $self = shift; | |
477 | return $self->{values}->{license} unless @_; | |
478 | my $license = shift or die( | |
479 | 'Did not provide a value to license()' | |
480 | ); | |
481 | $license = __extract_license($license) || lc $license; | |
482 | $self->{values}->{license} = $license; | |
483 | ||
484 | # Automatically fill in license URLs | |
485 | if ( $license_urls{$license} ) { | |
486 | $self->resources( license => $license_urls{$license} ); | |
487 | } | |
488 | ||
489 | return 1; | |
490 | } | |
491 | ||
492 | sub _extract_license { | |
493 | my $pod = shift; | |
494 | my $matched; | |
495 | return __extract_license( | |
496 | ($matched) = $pod =~ m/ | |
497 | (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) | |
498 | (=head \d.*|=cut.*|)\z | |
499 | /xms | |
500 | ) || __extract_license( | |
501 | ($matched) = $pod =~ m/ | |
502 | (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) | |
503 | (=head \d.*|=cut.*|)\z | |
504 | /xms | |
505 | ); | |
506 | } | |
507 | ||
508 | sub __extract_license { | |
509 | my $license_text = shift or return; | |
510 | my @phrases = ( | |
511 | '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, | |
512 | '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, | |
513 | 'Artistic and GPL' => 'perl', 1, | |
514 | 'GNU general public license' => 'gpl', 1, | |
515 | 'GNU public license' => 'gpl', 1, | |
516 | 'GNU lesser general public license' => 'lgpl', 1, | |
517 | 'GNU lesser public license' => 'lgpl', 1, | |
518 | 'GNU library general public license' => 'lgpl', 1, | |
519 | 'GNU library public license' => 'lgpl', 1, | |
520 | 'GNU Free Documentation license' => 'unrestricted', 1, | |
521 | 'GNU Affero General Public License' => 'open_source', 1, | |
522 | '(?:Free)?BSD license' => 'bsd', 1, | |
523 | 'Artistic license 2\.0' => 'artistic_2', 1, | |
524 | 'Artistic license' => 'artistic', 1, | |
525 | 'Apache (?:Software )?license' => 'apache', 1, | |
526 | 'GPL' => 'gpl', 1, | |
527 | 'LGPL' => 'lgpl', 1, | |
528 | 'BSD' => 'bsd', 1, | |
529 | 'Artistic' => 'artistic', 1, | |
530 | 'MIT' => 'mit', 1, | |
531 | 'Mozilla Public License' => 'mozilla', 1, | |
532 | 'Q Public License' => 'open_source', 1, | |
533 | 'OpenSSL License' => 'unrestricted', 1, | |
534 | 'SSLeay License' => 'unrestricted', 1, | |
535 | 'zlib License' => 'open_source', 1, | |
536 | 'proprietary' => 'proprietary', 0, | |
537 | ); | |
538 | while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { | |
539 | $pattern =~ s#\s+#\\s+#gs; | |
540 | if ( $license_text =~ /\b$pattern\b/i ) { | |
541 | return $license; | |
542 | } | |
543 | } | |
544 | return ''; | |
545 | } | |
546 | ||
547 | sub license_from { | |
548 | my $self = shift; | |
549 | if (my $license=_extract_license(Module::Install::_read($_[0]))) { | |
550 | $self->license($license); | |
551 | } else { | |
552 | warn "Cannot determine license info from $_[0]\n"; | |
553 | return 'unknown'; | |
554 | } | |
555 | } | |
556 | ||
557 | sub _extract_bugtracker { | |
558 | my @links = $_[0] =~ m#L<( | |
559 | https?\Q://rt.cpan.org/\E[^>]+| | |
560 | https?\Q://github.com/\E[\w_]+/[\w_]+/issues| | |
561 | https?\Q://code.google.com/p/\E[\w_\-]+/issues/list | |
562 | )>#gx; | |
563 | my %links; | |
564 | @links{@links}=(); | |
565 | @links=keys %links; | |
566 | return @links; | |
567 | } | |
568 | ||
569 | sub bugtracker_from { | |
570 | my $self = shift; | |
571 | my $content = Module::Install::_read($_[0]); | |
572 | my @links = _extract_bugtracker($content); | |
573 | unless ( @links ) { | |
574 | warn "Cannot determine bugtracker info from $_[0]\n"; | |
575 | return 0; | |
576 | } | |
577 | if ( @links > 1 ) { | |
578 | warn "Found more than one bugtracker link in $_[0]\n"; | |
579 | return 0; | |
580 | } | |
581 | ||
582 | # Set the bugtracker | |
583 | bugtracker( $links[0] ); | |
584 | return 1; | |
585 | } | |
586 | ||
587 | sub requires_from { | |
588 | my $self = shift; | |
589 | my $content = Module::Install::_readperl($_[0]); | |
590 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; | |
591 | while ( @requires ) { | |
592 | my $module = shift @requires; | |
593 | my $version = shift @requires; | |
594 | $self->requires( $module => $version ); | |
595 | } | |
596 | } | |
597 | ||
598 | sub test_requires_from { | |
599 | my $self = shift; | |
600 | my $content = Module::Install::_readperl($_[0]); | |
601 | my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; | |
602 | while ( @requires ) { | |
603 | my $module = shift @requires; | |
604 | my $version = shift @requires; | |
605 | $self->test_requires( $module => $version ); | |
606 | } | |
607 | } | |
608 | ||
609 | # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to | |
610 | # numbers (eg, 5.006001 or 5.008009). | |
611 | # Also, convert double-part versions (eg, 5.8) | |
612 | sub _perl_version { | |
613 | my $v = $_[-1]; | |
614 | $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; | |
615 | $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; | |
616 | $v =~ s/(\.\d\d\d)000$/$1/; | |
617 | $v =~ s/_.+$//; | |
618 | if ( ref($v) ) { | |
619 | # Numify | |
620 | $v = $v + 0; | |
621 | } | |
622 | return $v; | |
623 | } | |
624 | ||
625 | sub add_metadata { | |
626 | my $self = shift; | |
627 | my %hash = @_; | |
628 | for my $key (keys %hash) { | |
629 | warn "add_metadata: $key is not prefixed with 'x_'.\n" . | |
630 | "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; | |
631 | $self->{values}->{$key} = $hash{$key}; | |
632 | } | |
633 | } | |
634 | ||
635 | ||
636 | ###################################################################### | |
637 | # MYMETA Support | |
638 | ||
639 | sub WriteMyMeta { | |
640 | die "WriteMyMeta has been deprecated"; | |
641 | } | |
642 | ||
643 | sub write_mymeta_yaml { | |
644 | my $self = shift; | |
645 | ||
646 | # We need YAML::Tiny to write the MYMETA.yml file | |
647 | unless ( eval { require YAML::Tiny; 1; } ) { | |
648 | return 1; | |
649 | } | |
650 | ||
651 | # Generate the data | |
652 | my $meta = $self->_write_mymeta_data or return 1; | |
653 | ||
654 | # Save as the MYMETA.yml file | |
655 | print "Writing MYMETA.yml\n"; | |
656 | YAML::Tiny::DumpFile('MYMETA.yml', $meta); | |
657 | } | |
658 | ||
659 | sub write_mymeta_json { | |
660 | my $self = shift; | |
661 | ||
662 | # We need JSON to write the MYMETA.json file | |
663 | unless ( eval { require JSON; 1; } ) { | |
664 | return 1; | |
665 | } | |
666 | ||
667 | # Generate the data | |
668 | my $meta = $self->_write_mymeta_data or return 1; | |
669 | ||
670 | # Save as the MYMETA.yml file | |
671 | print "Writing MYMETA.json\n"; | |
672 | Module::Install::_write( | |
673 | 'MYMETA.json', | |
674 | JSON->new->pretty(1)->canonical->encode($meta), | |
675 | ); | |
676 | } | |
677 | ||
678 | sub _write_mymeta_data { | |
679 | my $self = shift; | |
680 | ||
681 | # If there's no existing META.yml there is nothing we can do | |
682 | return undef unless -f 'META.yml'; | |
683 | ||
684 | # We need Parse::CPAN::Meta to load the file | |
685 | unless ( eval { require Parse::CPAN::Meta; 1; } ) { | |
686 | return undef; | |
687 | } | |
688 | ||
689 | # Merge the perl version into the dependencies | |
690 | my $val = $self->Meta->{values}; | |
691 | my $perl = delete $val->{perl_version}; | |
692 | if ( $perl ) { | |
693 | $val->{requires} ||= []; | |
694 | my $requires = $val->{requires}; | |
695 | ||
696 | # Canonize to three-dot version after Perl 5.6 | |
697 | if ( $perl >= 5.006 ) { | |
698 | $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e | |
699 | } | |
700 | unshift @$requires, [ perl => $perl ]; | |
701 | } | |
702 | ||
703 | # Load the advisory META.yml file | |
704 | my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); | |
705 | my $meta = $yaml[0]; | |
706 | ||
707 | # Overwrite the non-configure dependency hashes | |
708 | delete $meta->{requires}; | |
709 | delete $meta->{build_requires}; | |
710 | delete $meta->{recommends}; | |
711 | if ( exists $val->{requires} ) { | |
712 | $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; | |
713 | } | |
714 | if ( exists $val->{build_requires} ) { | |
715 | $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; | |
716 | } | |
717 | ||
718 | return $meta; | |
719 | } | |
720 | ||
721 | 1; |
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.18'; | |
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; |
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.18'; | |
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; |
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.006; | |
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.18'; | |
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::getcwd(); | |
159 | my $sym = "${who}::AUTOLOAD"; | |
160 | $sym->{$cwd} = sub { | |
161 | my $pwd = Cwd::getcwd(); | |
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::getcwd()) eq $base_path ) { | |
242 | delete $args{prefix}; | |
243 | } | |
244 | return $args{_self} if $args{_self}; | |
245 | ||
246 | $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; | |
247 | ||
248 | $args{dispatch} ||= 'Admin'; | |
249 | $args{prefix} ||= 'inc'; | |
250 | $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); | |
251 | $args{bundle} ||= 'inc/BUNDLES'; | |
252 | $args{base} ||= $base_path; | |
253 | $class =~ s/^\Q$args{prefix}\E:://; | |
254 | $args{name} ||= $class; | |
255 | $args{version} ||= $class->VERSION; | |
256 | unless ( $args{path} ) { | |
257 | $args{path} = $args{name}; | |
258 | $args{path} =~ s!::!/!g; | |
259 | } | |
260 | $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; | |
261 | $args{wrote} = 0; | |
262 | ||
263 | bless( \%args, $class ); | |
264 | } | |
265 | ||
266 | sub call { | |
267 | my ($self, $method) = @_; | |
268 | my $obj = $self->load($method) or return; | |
269 | splice(@_, 0, 2, $obj); | |
270 | goto &{$obj->can($method)}; | |
271 | } | |
272 | ||
273 | sub load { | |
274 | my ($self, $method) = @_; | |
275 | ||
276 | $self->load_extensions( | |
277 | "$self->{prefix}/$self->{path}", $self | |
278 | ) unless $self->{extensions}; | |
279 | ||
280 | foreach my $obj (@{$self->{extensions}}) { | |
281 | return $obj if $obj->can($method); | |
282 | } | |
283 | ||
284 | my $admin = $self->{admin} or die <<"END_DIE"; | |
285 | The '$method' method does not exist in the '$self->{prefix}' path! | |
286 | Please remove the '$self->{prefix}' directory and run $0 again to load it. | |
287 | END_DIE | |
288 | ||
289 | my $obj = $admin->load($method, 1); | |
290 | push @{$self->{extensions}}, $obj; | |
291 | ||
292 | $obj; | |
293 | } | |
294 | ||
295 | sub load_extensions { | |
296 | my ($self, $path, $top) = @_; | |
297 | ||
298 | my $should_reload = 0; | |
299 | unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { | |
300 | unshift @INC, $self->{prefix}; | |
301 | $should_reload = 1; | |
302 | } | |
303 | ||
304 | foreach my $rv ( $self->find_extensions($path) ) { | |
305 | my ($file, $pkg) = @{$rv}; | |
306 | next if $self->{pathnames}{$pkg}; | |
307 | ||
308 | local $@; | |
309 | my $new = eval { local $^W; require $file; $pkg->can('new') }; | |
310 | unless ( $new ) { | |
311 | warn $@ if $@; | |
312 | next; | |
313 | } | |
314 | $self->{pathnames}{$pkg} = | |
315 | $should_reload ? delete $INC{$file} : $INC{$file}; | |
316 | push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); | |
317 | } | |
318 | ||
319 | $self->{extensions} ||= []; | |
320 | } | |
321 | ||
322 | sub find_extensions { | |
323 | my ($self, $path) = @_; | |
324 | ||
325 | my @found; | |
326 | File::Find::find( {no_chdir => 1, wanted => sub { | |
327 | my $file = $File::Find::name; | |
328 | return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; | |
329 | my $subpath = $1; | |
330 | return if lc($subpath) eq lc($self->{dispatch}); | |
331 | ||
332 | $file = "$self->{path}/$subpath.pm"; | |
333 | my $pkg = "$self->{name}::$subpath"; | |
334 | $pkg =~ s!/!::!g; | |
335 | ||
336 | # If we have a mixed-case package name, assume case has been preserved | |
337 | # correctly. Otherwise, root through the file to locate the case-preserved | |
338 | # version of the package name. | |
339 | if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { | |
340 | my $content = Module::Install::_read($File::Find::name); | |
341 | my $in_pod = 0; | |
342 | foreach ( split /\n/, $content ) { | |
343 | $in_pod = 1 if /^=\w/; | |
344 | $in_pod = 0 if /^=cut/; | |
345 | next if ($in_pod || /^=cut/); # skip pod text | |
346 | next if /^\s*#/; # and comments | |
347 | if ( m/^\s*package\s+($pkg)\s*;/i ) { | |
348 | $pkg = $1; | |
349 | last; | |
350 | } | |
351 | } | |
352 | } | |
353 | ||
354 | push @found, [ $file, $pkg ]; | |
355 | }}, $path ) if -d $path; | |
356 | ||
357 | @found; | |
358 | } | |
359 | ||
360 | ||
361 | ||
362 | ||
363 | ||
364 | ##################################################################### | |
365 | # Common Utility Functions | |
366 | ||
367 | sub _caller { | |
368 | my $depth = 0; | |
369 | my $call = caller($depth); | |
370 | while ( $call eq __PACKAGE__ ) { | |
371 | $depth++; | |
372 | $call = caller($depth); | |
373 | } | |
374 | return $call; | |
375 | } | |
376 | ||
377 | sub _read { | |
378 | local *FH; | |
379 | open( FH, '<', $_[0] ) or die "open($_[0]): $!"; | |
380 | binmode FH; | |
381 | my $string = do { local $/; <FH> }; | |
382 | close FH or die "close($_[0]): $!"; | |
383 | return $string; | |
384 | } | |
385 | ||
386 | sub _readperl { | |
387 | my $string = Module::Install::_read($_[0]); | |
388 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; | |
389 | $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; | |
390 | $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; | |
391 | return $string; | |
392 | } | |
393 | ||
394 | sub _readpod { | |
395 | my $string = Module::Install::_read($_[0]); | |
396 | $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; | |
397 | return $string if $_[0] =~ /\.pod\z/; | |
398 | $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; | |
399 | $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; | |
400 | $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; | |
401 | $string =~ s/^\n+//s; | |
402 | return $string; | |
403 | } | |
404 | ||
405 | sub _write { | |
406 | local *FH; | |
407 | open( FH, '>', $_[0] ) or die "open($_[0]): $!"; | |
408 | binmode FH; | |
409 | foreach ( 1 .. $#_ ) { | |
410 | print FH $_[$_] or die "print($_[0]): $!"; | |
411 | } | |
412 | close FH or die "close($_[0]): $!"; | |
413 | } | |
414 | ||
415 | # _version is for processing module versions (eg, 1.03_05) not | |
416 | # Perl versions (eg, 5.8.1). | |
417 | sub _version { | |
418 | my $s = shift || 0; | |
419 | my $d =()= $s =~ /(\.)/g; | |
420 | if ( $d >= 2 ) { | |
421 | # Normalise multipart versions | |
422 | $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; | |
423 | } | |
424 | $s =~ s/^(\d+)\.?//; | |
425 | my $l = $1 || 0; | |
426 | my @v = map { | |
427 | $_ . '0' x (3 - length $_) | |
428 | } $s =~ /(\d{1,3})\D?/g; | |
429 | $l = $l . '.' . join '', @v if @v; | |
430 | return $l + 0; | |
431 | } | |
432 | ||
433 | sub _cmp { | |
434 | _version($_[1]) <=> _version($_[2]); | |
435 | } | |
436 | ||
437 | # Cloned from Params::Util::_CLASS | |
438 | sub _CLASS { | |
439 | ( | |
440 | defined $_[0] | |
441 | and | |
442 | ! ref $_[0] | |
443 | and | |
444 | $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s | |
445 | ) ? $_[0] : undef; | |
446 | } | |
447 | ||
448 | 1; | |
449 | ||
450 | # Copyright 2008 - 2012 Adam Kennedy. |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | package Catalyst::Plugin::Session::State; |
3 | 1 | |
4 | 2 | use strict; |
5 | 3 | use warnings; |
4 | ||
5 | our $VERSION = '0.43'; | |
6 | $VERSION =~ tr/_//d; | |
6 | 7 | |
7 | 8 | __PACKAGE__; |
8 | 9 | |
46 | 47 | =item finalize |
47 | 48 | |
48 | 49 | Modify the response at to include the session ID if C<sessionid> is defined, |
49 | using whatever scheme you use. For example, set a cookie, | |
50 | using whatever scheme you use. For example, set a cookie. | |
50 | 51 | |
51 | 52 | =back |
52 | 53 |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | package Catalyst::Plugin::Session::Store::Dummy; |
3 | 1 | use base qw/Catalyst::Plugin::Session::Store/; |
4 | 2 | |
5 | 3 | use strict; |
6 | 4 | use warnings; |
5 | ||
6 | our $VERSION = '0.43'; | |
7 | $VERSION =~ tr/_//d; | |
7 | 8 | |
8 | 9 | my %store; |
9 | 10 |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | package Catalyst::Plugin::Session::Store; |
3 | 1 | |
4 | 2 | use strict; |
5 | 3 | use warnings; |
4 | ||
5 | our $VERSION = '0.43'; | |
6 | $VERSION =~ tr/_//d; | |
6 | 7 | |
7 | 8 | __PACKAGE__; |
8 | 9 | |
26 | 27 | C<Catalyst::Plugin::Session> module sets up it will check to see that |
27 | 28 | C<< YourApp->isa("Catalyst::Plugin::Session::Store") >>. When you write |
28 | 29 | a session storage plugin you should subclass this module for this |
29 | reason. This documentation is intended for authors of session storage | |
30 | reason. This documentation is intended for authors of session storage | |
30 | 31 | plugins, not for end users. |
31 | 32 | |
32 | 33 | =head1 WRITING STORE PLUGINS |
65 | 66 | |
66 | 67 | $c->store_session_data( $x, $y ); |
67 | 68 | |
68 | for any $x, | |
69 | for any $x, | |
69 | 70 | |
70 | 71 | $y == $c->get_session_data( $x ) |
71 | 72 |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | package Catalyst::Plugin::Session::Test::Store; |
3 | 1 | |
4 | 2 | use strict; |
5 | 3 | use warnings; |
4 | ||
5 | our $VERSION = '0.43'; | |
6 | $VERSION =~ tr/_//d; | |
6 | 7 | |
7 | 8 | use utf8; |
8 | 9 | |
56 | 57 | use Catalyst qw/Session SessionStateTest/; |
57 | 58 | push our (@ISA), $m; |
58 | 59 | |
59 | our $VERSION = "123"; # Do not remove | |
60 | our $VERSION # make unparseable | |
61 | = "123"; # Do not remove | |
60 | 62 | |
61 | 63 | use strict; |
62 | 64 | use warnings; |
104 | 106 | use Catalyst qw/Session SessionStateTest/; |
105 | 107 | push our (@ISA), $m; |
106 | 108 | |
107 | our $VERSION = "123"; | |
109 | our $VERSION # make unparseable | |
110 | = "123"; | |
108 | 111 | |
109 | 112 | use Test::More; |
110 | 113 | |
149 | 152 | use Catalyst::Test "SessionStoreTest"; |
150 | 153 | |
151 | 154 | # idiotic void context warning workaround |
152 | ||
155 | ||
153 | 156 | my $x = get("/create_session"); |
154 | 157 | $x = get("/recover_session"); |
155 | 158 | $x = get("/after_session"); |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | package Catalyst::Plugin::Session; |
3 | 1 | |
4 | 2 | use Moose; |
14 | 12 | |
15 | 13 | use namespace::clean -except => 'meta'; |
16 | 14 | |
17 | our $VERSION = '0.41'; | |
18 | $VERSION = eval $VERSION; | |
15 | our $VERSION = '0.43'; | |
16 | $VERSION =~ tr/_//d; | |
19 | 17 | |
20 | 18 | my @session_data_accessors; # used in delete_session |
21 | 19 |
0 | BEGIN { -e 'Distar' or system qw(git clone https://github.com/p5sagit/Distar.git) } | |
1 | use lib 'Distar/lib'; | |
2 | use Distar 0.001; | |
3 | ||
4 | author 'Yuval Kogman <nothingmuch@woobling.org>'; | |
5 | ||
6 | 1; |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
5 | use Test::More tests => 4; | |
3 | use Test::More; | |
6 | 4 | |
5 | use Catalyst::Plugin::Session; | |
7 | 6 | |
8 | my $m; BEGIN { use_ok($m = "Catalyst::Plugin::Session") } | |
7 | can_ok('Catalyst::Plugin::Session', qw/sessionid session session_delete_reason/); | |
9 | 8 | |
10 | can_ok($m, $_) for qw/sessionid session session_delete_reason/; | |
11 | ||
12 | ||
9 | done_testing; |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
5 | use Test::More tests => 10; | |
3 | use Test::More; | |
6 | 4 | use Class::MOP; |
7 | 5 | use Test::Deep; |
8 | 6 | |
9 | my $m; | |
10 | BEGIN { use_ok( $m = "Catalyst::Plugin::Session" ) } | |
7 | use Catalyst::Plugin::Session; | |
11 | 8 | |
12 | 9 | my %config; |
13 | 10 | my $log_meta = Class::MOP::Class->create_anon_class(superclasses => ['Moose::Object']); |
21 | 18 | |
22 | 19 | package MockCxt; |
23 | 20 | use MRO::Compat; |
24 | use base $m; | |
21 | use base qw(Catalyst::Plugin::Session); | |
25 | 22 | sub new { bless {}, $_[0] } |
26 | 23 | sub config { \%config } |
27 | 24 | sub log { $log } |
33 | 30 | } |
34 | 31 | } |
35 | 32 | |
36 | can_ok( $m, "setup" ); | |
33 | can_ok( 'Catalyst::Plugin::Session', "setup" ); | |
37 | 34 | |
38 | 35 | eval { MockCxt->new->setup }; # throws OK is not working with NEXT |
39 | 36 | like( |
73 | 70 | is( $config{session}{expires}, |
74 | 71 | 1234, "user values are not overwritten in config" ); |
75 | 72 | |
73 | done_testing; |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
5 | use Test::More tests => 12; | |
6 | use Test::Exception; | |
3 | use Test::More; | |
7 | 4 | use Test::Deep; |
8 | 5 | |
9 | my $m; | |
10 | BEGIN { use_ok( $m = "Catalyst::Plugin::Session" ) } | |
6 | use Catalyst::Plugin::Session; | |
11 | 7 | |
12 | 8 | my $c_meta = Class::MOP::Class->create_anon_class( |
13 | superclasses => [ $m, 'Moose::Object', ], | |
9 | superclasses => [ 'Catalyst::Plugin::Session', 'Moose::Object', ], | |
14 | 10 | ); |
15 | 11 | my $c = $c_meta->name->new; |
16 | 12 | |
76 | 72 | $c->prepare_action; |
77 | 73 | |
78 | 74 | is_deeply( $c->stash, { bar => "gorch" }, "flash copied to stash" ); |
75 | ||
76 | done_testing; |
0 | #!/usr/bin/perl -w | |
1 | 0 | use strict; |
1 | use warnings; | |
2 | ||
3 | use Test::Needs { | |
4 | 'Catalyst::Plugin::Session::State::Cookie' => '0.03', | |
5 | }; | |
2 | 6 | |
3 | 7 | use Test::More; |
4 | 8 | |
5 | BEGIN { | |
6 | eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } | |
7 | or plan skip_all => | |
8 | "Catalyst::Plugin::Session::State::Cookie version 0.03 or higher is required for this test"; | |
9 | use lib "t/lib"; | |
9 | 10 | |
10 | eval { | |
11 | require Test::WWW::Mechanize::Catalyst; | |
12 | Test::WWW::Mechanize::Catalyst->VERSION(0.51); | |
13 | } | |
14 | or plan skip_all => | |
15 | 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; | |
11 | use MiniUA; | |
16 | 12 | |
17 | plan tests => '10'; | |
13 | my $ua = MiniUA->new('FlashTestApp'); | |
18 | 14 | |
19 | } | |
20 | ||
21 | use lib "t/lib"; | |
22 | use Test::WWW::Mechanize::Catalyst 'FlashTestApp'; | |
23 | ||
24 | my $ua = Test::WWW::Mechanize::Catalyst->new; | |
15 | my $res; | |
25 | 16 | |
26 | 17 | # flash absent for initial request |
27 | $ua->get_ok( "http://localhost/first"); | |
28 | $ua->content_contains( "flash is not set", "not set"); | |
18 | $res = $ua->get( "http://localhost/first" ); | |
19 | ok +$res->is_success; | |
20 | like +$res->content, qr{flash is not set}, "not set"; | |
29 | 21 | |
30 | 22 | # present for 1st req. |
31 | $ua->get_ok( "http://localhost/second"); | |
32 | $ua->content_contains( "flash set first time", "set first"); | |
23 | $res = $ua->get( "http://localhost/second"); | |
24 | ok +$res->is_success; | |
25 | like +$res->content, qr{flash set first time}, "set first"; | |
33 | 26 | |
34 | 27 | # should be the same 2nd req. |
35 | $ua->get_ok( "http://localhost/third"); | |
36 | $ua->content_contains( "flash set second time", "set second"); | |
28 | $res = $ua->get( "http://localhost/third"); | |
29 | ok +$res->is_success; | |
30 | like +$res->content, qr{flash set second time}, "set second"; | |
37 | 31 | |
38 | 32 | # and the third request, flash->{is_set} has the same value as 2nd. |
39 | $ua->get_ok( "http://localhost/fourth"); | |
40 | $ua->content_contains( "flash set 3rd time, same val as prev.", "set third"); | |
41 | ||
33 | $res = $ua->get( "http://localhost/fourth"); | |
34 | ok +$res->is_success; | |
35 | like +$res->content, qr{flash set 3rd time, same val as prev.}, "set third"; | |
42 | 36 | |
43 | 37 | # and should be absent again for the 4th req. |
44 | $ua->get_ok( "http://localhost/fifth"); | |
45 | $ua->content_contains( "flash is not", "flash has gone"); | |
38 | $res = $ua->get( "http://localhost/fifth"); | |
39 | ok +$res->is_success; | |
40 | like +$res->content, qr{flash is not}, "flash has gone"; | |
46 | 41 | |
42 | done_testing; |
0 | use Test::More; | |
1 | ||
2 | eval "use Test::Pod 1.14"; | |
3 | plan skip_all => 'Test::Pod 1.14 required' if $@; | |
4 | plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; | |
5 | ||
6 | all_pod_files_ok(); |
0 | use Test::More; | |
1 | ||
2 | eval "use Test::Pod::Coverage 1.04"; | |
3 | plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@; | |
4 | plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD}; | |
5 | ||
6 | all_pod_coverage_ok(); |
0 | #!/usr/bin/env perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
2 | ||
3 | use Test::Needs { | |
4 | 'Catalyst::Plugin::Authentication' => '0', | |
5 | 'Catalyst::Plugin::Session::State::Cookie' => '0.03', | |
6 | }; | |
7 | ||
4 | 8 | use Test::More; |
9 | ||
5 | 10 | use HTTP::Request::Common; |
6 | 11 | |
7 | # setup library path | |
8 | use FindBin qw($Bin); | |
9 | use lib "$Bin/lib"; | |
10 | ||
11 | # this test was copied from CatalystX::SimpleLogin | |
12 | ||
13 | BEGIN { | |
14 | plan skip_all => "Need Catalyst::Plugin::Session::State::Cookie" | |
15 | unless do { local $@; eval { require Catalyst::Plugin::Session::State::Cookie; } }; | |
16 | plan skip_all => "Need Catalyst::Plugin::Authentication" | |
17 | unless do { local $@; eval { require Catalyst::Plugin::Authentication; } }; | |
18 | } | |
12 | use lib "t/lib"; | |
19 | 13 | |
20 | 14 | use Catalyst::Test 'SessionTestApp'; |
21 | my ($res, $c); | |
15 | my $res; | |
22 | 16 | |
23 | ($res, $c) = ctx_request(POST 'http://localhost/login', [username => 'bob', password => 's00p3r', remember => 1]); | |
17 | $res = request(POST 'http://localhost/login', [username => 'bob', password => 's00p3r', remember => 1]); | |
24 | 18 | is($res->code, 200, 'succeeded'); |
25 | 19 | my $cookie = $res->header('Set-Cookie'); |
26 | 20 | ok($cookie, 'Have a cookie'); |
27 | 21 | |
28 | 22 | # cookie is changed by the get |
29 | 23 | sleep(1); |
30 | ($res, $c) = ctx_request(GET 'http://localhost/page', Cookie => $cookie); | |
31 | like($c->res->body, qr/logged in/, 'logged in'); | |
24 | $res = request(GET 'http://localhost/page', Cookie => $cookie); | |
25 | like($res->content, qr/logged in/, 'logged in'); | |
32 | 26 | my $new_cookie = $res->header('Set-Cookie'); |
33 | 27 | isnt( $cookie, $new_cookie, 'cookie expires has been updated' ); |
34 | 28 | |
35 | 29 | # request with no cookie |
36 | ($res, $c) = ctx_request(GET 'http://localhost/page' ); | |
37 | like($c->res->body, qr/please login/, 'not logged in'); | |
30 | $res = request(GET 'http://localhost/page' ); | |
31 | like($res->content, qr/please login/, 'not logged in'); | |
38 | 32 | $new_cookie = $res->header('Set-Cookie'); |
39 | 33 | ok( ! defined $new_cookie, 'no cookie created' ); |
40 | 34 | |
41 | 35 | # check that cookie is reset by reset_session_expires |
42 | ($res, $c) = ctx_request(GET 'http://localhost/reset_session_expires', Cookie => $cookie); | |
36 | $res = request(GET 'http://localhost/reset_session_expires', Cookie => $cookie); | |
43 | 37 | my $reset_cookie = $res->header('Set-Cookie'); |
44 | 38 | isnt( $cookie, $reset_cookie, 'Cookie has been changed by reset_session' ); |
45 | 39 | |
46 | 40 | # this checks that cookie exists after a logout and redirect |
47 | 41 | # Catalyst::Plugin::Authentication removes the user session (remove_persisted_user) |
48 | ($res, $c) = ctx_request(GET 'http://localhost/logout_redirect', Cookie => $cookie); | |
42 | $res = request(GET 'http://localhost/logout_redirect', Cookie => $cookie); | |
49 | 43 | is($res->code, 302, 'redirected'); |
50 | 44 | is($res->header('Location'), 'http://localhost/from_logout_redirect', 'Redirected after logout_redirect'); |
51 | 45 | ok($res->header('Set-Cookie'), 'Cookie is there after redirect'); |
12 | 12 | my ($self, $c) = @_; |
13 | 13 | $c->session; |
14 | 14 | } |
15 | ||
15 | ||
16 | 16 | sub first : Global { |
17 | 17 | my ( $self, $c ) = @_; |
18 | 18 | if ( ! $c->flash->{is_set}) { |
0 | #!/usr/bin/env perl | |
1 | ||
2 | 0 | package FlashTestApp; |
3 | 1 | use Catalyst qw/Session Session::Store::Dummy Session::State::Cookie/; |
4 | 2 |
0 | package MiniUA; | |
1 | use strict; | |
2 | use warnings; | |
3 | use Plack::Test (); | |
4 | use HTTP::Cookies; | |
5 | use HTTP::Request::Common; | |
6 | ||
7 | sub new { | |
8 | my ($class, $app, $opts) = @_; | |
9 | my $psgi | |
10 | = ref $app eq 'CODE' ? $app | |
11 | : do { | |
12 | eval "require $app;" or die $@; | |
13 | $app->psgi_app; | |
14 | }; | |
15 | $opts ||= {}; | |
16 | ||
17 | my $self = bless { | |
18 | psgi => $psgi, | |
19 | plack_test => Plack::Test->create($psgi), | |
20 | cookie_jar => HTTP::Cookies->new(hide_cookie2 => 1), | |
21 | headers => $opts, | |
22 | }, $class; | |
23 | return $self; | |
24 | } | |
25 | ||
26 | sub agent { | |
27 | my $self = shift; | |
28 | if (@_) { | |
29 | return $self->{headers}{'User-Agent'} = shift; | |
30 | } | |
31 | return $self->{headers}{'User-Agent'}; | |
32 | } | |
33 | ||
34 | sub cookie_jar { | |
35 | my $self = shift; | |
36 | return $self->{cookie_jar}; | |
37 | } | |
38 | ||
39 | sub request { | |
40 | my ($self, $req) = @_; | |
41 | my $pt = $self->{plack_test}; | |
42 | my $jar = $self->cookie_jar; | |
43 | my $headers = $self->{headers}; | |
44 | ||
45 | my $uri = $req->uri; | |
46 | $uri->scheme('http') unless defined $uri->scheme; | |
47 | $uri->host('localhost') unless defined $uri->host; | |
48 | ||
49 | $req->header(%$headers) | |
50 | if %$headers; | |
51 | ||
52 | $jar->add_cookie_header($req); | |
53 | ||
54 | my $res = $pt->request($req); | |
55 | $jar->extract_cookies($res); | |
56 | ||
57 | return $res; | |
58 | } | |
59 | ||
60 | sub get { | |
61 | my ($self, $url) = @_; | |
62 | $self->request(GET $url); | |
63 | } | |
64 | ||
65 | 1; |
0 | #!/usr/bin/env perl | |
1 | ||
2 | 0 | package SessionTestApp; |
3 | 1 | use Catalyst qw/Session Session::Store::Dummy Session::State::Cookie Authentication/; |
4 | 2 |
0 | #!/usr/bin/perl | |
1 | # | |
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
3 | use Test::Needs { | |
4 | 'Catalyst::Plugin::Authentication' => '0', | |
5 | 'Catalyst::Plugin::Session::State::Cookie' => '0.03', | |
6 | }; | |
7 | ||
5 | 8 | use Test::More; |
6 | 9 | |
7 | BEGIN { | |
8 | eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } | |
9 | or plan skip_all => | |
10 | "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; | |
10 | use lib "t/lib"; | |
11 | 11 | |
12 | eval { | |
13 | require Test::WWW::Mechanize::Catalyst; | |
14 | Test::WWW::Mechanize::Catalyst->VERSION(0.51); | |
15 | } | |
16 | or plan skip_all => | |
17 | 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; | |
12 | use MiniUA; | |
18 | 13 | |
19 | plan tests => 4; | |
20 | } | |
14 | my $ua = MiniUA->new('SessionTestApp'); | |
21 | 15 | |
22 | use lib "t/lib"; | |
23 | use Test::WWW::Mechanize::Catalyst "SessionTestApp"; | |
16 | my $res = $ua->get( '/accessor_test'); | |
17 | ok +$res->is_success, 'Set session vars okay'; | |
24 | 18 | |
25 | my $ua = Test::WWW::Mechanize::Catalyst->new; | |
19 | like +$res->content, qr{two: 2}, 'k/v list setter works okay'; | |
26 | 20 | |
27 | $ua->get_ok("http://localhost/accessor_test", "Set session vars okay"); | |
21 | like +$res->content, qr{four: 4}, 'hashref setter works okay'; | |
28 | 22 | |
29 | $ua->content_contains("two: 2", "k/v list setter works okay"); | |
23 | like +$res->content, qr{five: 5}, 'direct access works okay'; | |
30 | 24 | |
31 | $ua->content_contains("four: 4", "hashref setter works okay"); | |
32 | ||
33 | $ua->content_contains("five: 5", "direct access works okay"); | |
34 | ||
25 | done_testing; |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
3 | use Test::Needs { | |
4 | 'Catalyst::Plugin::Authentication' => '0', | |
5 | 'Catalyst::Plugin::Session::State::Cookie' => '0.03', | |
6 | }; | |
7 | ||
5 | 8 | use Test::More; |
6 | 9 | |
7 | BEGIN { | |
8 | eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } | |
9 | or plan skip_all => | |
10 | "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; | |
10 | use lib "t/lib"; | |
11 | 11 | |
12 | eval { | |
13 | require Test::WWW::Mechanize::Catalyst; | |
14 | Test::WWW::Mechanize::Catalyst->VERSION(0.51); | |
15 | } | |
16 | or plan skip_all => | |
17 | 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; | |
18 | } | |
12 | use MiniUA; | |
19 | 13 | |
20 | use lib "t/lib"; | |
21 | use Test::WWW::Mechanize::Catalyst "SessionTestApp"; | |
14 | my $ua1 = MiniUA->new('SessionTestApp'); | |
15 | my $ua2 = MiniUA->new('SessionTestApp'); | |
22 | 16 | |
23 | my $ua1 = Test::WWW::Mechanize::Catalyst->new; | |
24 | my $ua2 = Test::WWW::Mechanize::Catalyst->new; | |
17 | my $res1 = $ua1->get( 'http://localhost/page'); | |
18 | my $res2 = $ua2->get( 'http://localhost/page'); | |
19 | ok $_->is_success, 'initial get' for $res1, $res2; | |
25 | 20 | |
26 | $_->get_ok( "http://localhost/page", "initial get" ) for $ua1, $ua2; | |
21 | like $res1->content, qr/please login/, 'ua1 not logged in'; | |
22 | like $res2->content, qr/please login/, 'ua2 not logged in'; | |
27 | 23 | |
28 | $ua1->content_contains( "please login", "ua1 not logged in" ); | |
29 | $ua2->content_contains( "please login", "ua2 not logged in" ); | |
24 | $res1 = $ua1->get( 'http://localhost/login'); | |
25 | ok $res1->is_success, 'log ua1 in'; | |
26 | like $res1->content, qr/logged in/, 'ua1 logged in'; | |
30 | 27 | |
31 | $ua1->get_ok( "http://localhost/login", "log ua1 in" ); | |
32 | $ua1->content_contains( "logged in", "ua1 logged in" ); | |
28 | $res1 = $ua1->get( 'http://localhost/page'); | |
29 | $res2 = $ua2->get( 'http://localhost/page'); | |
30 | ok $_->is_success, 'get main page' for $res1, $res2; | |
33 | 31 | |
34 | $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; | |
32 | like $res1->content, qr/you are logged in/, 'ua1 logged in'; | |
33 | like $res2->content, qr/please login/, 'ua2 not logged in'; | |
35 | 34 | |
36 | $ua1->content_contains( "you are logged in", "ua1 logged in" ); | |
37 | $ua2->content_contains( "please login", "ua2 not logged in" ); | |
35 | $res2 = $ua2->get( 'http://localhost/login'); | |
36 | ok $res2->is_success, 'log ua2 in'; | |
37 | like $res2->content, qr/logged in/, 'ua2 logged in'; | |
38 | 38 | |
39 | $ua2->get_ok( "http://localhost/login", "get main page" ); | |
40 | $ua2->content_contains( "logged in", "log ua2 in" ); | |
39 | $res1 = $ua1->get( 'http://localhost/page'); | |
40 | $res2 = $ua2->get( 'http://localhost/page'); | |
41 | ok $_->is_success, 'get main page' for $res1, $res2; | |
41 | 42 | |
42 | $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; | |
43 | like $res1->content, qr/you are logged in/, 'ua1 logged in'; | |
44 | like $res2->content, qr/you are logged in/, 'ua2 logged in'; | |
43 | 45 | |
44 | $ua1->content_contains( "you are logged in", "ua1 logged in" ); | |
45 | $ua2->content_contains( "you are logged in", "ua2 logged in" ); | |
46 | ||
47 | my ( $u1_expires ) = ($ua1->content =~ /(\d+)$/); | |
48 | my ( $u2_expires ) = ($ua2->content =~ /(\d+)$/); | |
46 | my ( $u1_expires ) = ($res1->content =~ /(\d+)$/); | |
47 | my ( $u2_expires ) = ($res2->content =~ /(\d+)$/); | |
49 | 48 | |
50 | 49 | sleep 1; |
51 | 50 | |
52 | $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; | |
51 | $res1 = $ua1->get( 'http://localhost/page'); | |
52 | $res2 = $ua2->get( 'http://localhost/page'); | |
53 | ok $_->is_success, 'get main page' for $res1, $res2; | |
53 | 54 | |
54 | $ua1->content_contains( "you are logged in", "ua1 logged in" ); | |
55 | $ua2->content_contains( "you are logged in", "ua2 logged in" ); | |
55 | like $res1->content, qr/you are logged in/, 'ua1 logged in'; | |
56 | like $res2->content, qr/you are logged in/, 'ua2 logged in'; | |
56 | 57 | |
57 | my ( $u1_expires_updated ) = ($ua1->content =~ /(\d+)$/); | |
58 | my ( $u2_expires_updated ) = ($ua2->content =~ /(\d+)$/); | |
58 | my ( $u1_expires_updated ) = ($res1->content =~ /(\d+)$/); | |
59 | my ( $u2_expires_updated ) = ($res2->content =~ /(\d+)$/); | |
59 | 60 | |
60 | 61 | cmp_ok( $u1_expires, "<", $u1_expires_updated, "expiry time updated"); |
61 | 62 | cmp_ok( $u2_expires, "<", $u2_expires_updated, "expiry time updated"); |
62 | 63 | |
63 | $ua2->get_ok( "http://localhost/logout", "log ua2 out" ); | |
64 | $ua2->content_like( qr/logged out/, "ua2 logged out" ); | |
65 | $ua2->content_like( qr/after 2 request/, | |
66 | "ua2 made 2 requests for page in the session" ); | |
64 | $res2 = $ua2->get( 'http://localhost/logout'); | |
65 | ok $res2->is_success, 'log ua2 out'; | |
66 | like $res2->content, qr/logged out/, 'ua2 logged out'; | |
67 | like $res2->content, qr/after 2 requests/, | |
68 | 'ua2 made 2 requests for page in the session'; | |
67 | 69 | |
68 | $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; | |
70 | $res1 = $ua1->get( 'http://localhost/page'); | |
71 | $res2 = $ua2->get( 'http://localhost/page'); | |
72 | ok $_->is_success, 'get main page' for $res1, $res2; | |
69 | 73 | |
70 | $ua1->content_contains( "you are logged in", "ua1 logged in" ); | |
71 | $ua2->content_contains( "please login", "ua2 not logged in" ); | |
74 | like $res1->content, qr/you are logged in/, 'ua1 logged in'; | |
75 | like $res2->content, qr/please login/, 'ua2 not logged in'; | |
72 | 76 | |
73 | $ua1->get_ok( "http://localhost/logout", "log ua1 out" ); | |
74 | $ua1->content_like( qr/logged out/, "ua1 logged out" ); | |
75 | $ua1->content_like( qr/after 4 requests/, | |
76 | "ua1 made 4 request for page in the session" ); | |
77 | $res1 = $ua1->get( 'http://localhost/logout'); | |
78 | ok $res1->is_success, 'log ua1 out'; | |
79 | like $res1->content, qr/logged out/, 'ua1 logged out'; | |
80 | like $res1->content, qr/after 4 requests/, | |
81 | 'ua1 made 4 requests for page in the session'; | |
77 | 82 | |
78 | $_->get_ok( "http://localhost/page", "get main page" ) for $ua1, $ua2; | |
83 | $res1 = $ua1->get( 'http://localhost/page'); | |
84 | $res2 = $ua2->get( 'http://localhost/page'); | |
85 | ok $_->is_success, 'get main page' for $res1, $res2; | |
79 | 86 | |
80 | $ua1->content_contains( "please login", "ua1 not logged in" ); | |
81 | $ua2->content_contains( "please login", "ua2 not logged in" ); | |
87 | like $res1->content, qr/please login/, 'ua1 not logged in'; | |
88 | like $res2->content, qr/please login/, 'ua2 not logged in'; | |
82 | 89 | |
83 | my $ua3 = Test::WWW::Mechanize::Catalyst->new; | |
84 | $ua3->get_ok( "http://localhost/login", "log ua3 in" ); | |
85 | $ua3->get_ok( "http://localhost/dump_these_loads_session"); | |
86 | $ua3->content_contains('NOT'); | |
87 | ||
88 | my $ua4 = Test::WWW::Mechanize::Catalyst->new; | |
89 | $ua4->get_ok( "http://localhost/page", "initial get" ); | |
90 | $ua4->content_contains( "please login", "ua4 not logged in" ); | |
91 | ||
92 | $ua4->get_ok( "http://localhost/login", "log ua4 in" ); | |
93 | $ua4->content_contains( "logged in", "ua4 logged in" ); | |
90 | my $ua3 = MiniUA->new('SessionTestApp'); | |
91 | my $res3 = $ua3->get( 'http://localhost/login'); | |
92 | ok $res3->is_success, 'log ua3 in'; | |
93 | $res3 = $ua3->get( 'http://localhost/dump_these_loads_session'); | |
94 | ok $res3->is_success; | |
95 | like $res3->content, qr/NOT/; | |
94 | 96 | |
95 | 97 | |
96 | $ua4->get( "http://localhost/page", "get page" ); | |
97 | my ( $ua4_expires1 ) = ($ua4->content =~ /(\d+)$/); | |
98 | $ua4->get( "http://localhost/page", "get page" ); | |
99 | my ( $ua4_expires2 ) = ($ua4->content =~ /(\d+)$/); | |
98 | my $ua4 = MiniUA->new('SessionTestApp'); | |
99 | my $res4 = $ua4->get( 'http://localhost/page'); | |
100 | ok $res4->is_success, 'initial get'; | |
101 | like $res4->content, qr/please login/, 'ua4 not logged in'; | |
102 | $res4 = $ua4->get( 'http://localhost/login'); | |
103 | ok $res4->is_success, 'log ua4 in'; | |
104 | like $res4->content, qr/logged in/, 'ua4 logged in'; | |
105 | ||
106 | $res4 = $ua4->get( "http://localhost/page"); | |
107 | ok +$res4->is_success, "get page"; | |
108 | my ( $ua4_expires1 ) = ($res4->content =~ /(\d+)$/); | |
109 | $res4 = $ua4->get( "http://localhost/page"); | |
110 | ok +$res4->is_success, "get page"; | |
111 | my ( $ua4_expires2 ) = ($res4->content =~ /(\d+)$/); | |
100 | 112 | is( $ua4_expires1, $ua4_expires2, 'expires has not changed' ); |
101 | 113 | |
102 | $ua4->get( "http://localhost/change_session_expires", "get page" ); | |
103 | $ua4->get( "http://localhost/page", "get page" ); | |
104 | my ( $ua4_expires3 ) = ($ua4->content =~ /(\d+)$/); | |
114 | $res4 = $ua4->get( "http://localhost/change_session_expires"); | |
115 | ok +$res4->is_success, "get page"; | |
116 | $res4 = $ua4->get( "http://localhost/page" ); | |
117 | ok +$res4->is_success, "get page"; | |
118 | my ( $ua4_expires3 ) = ($res4->content =~ /(\d+)$/); | |
105 | 119 | ok( $ua4_expires3 > ( $ua4_expires1 + 30000000), 'expires has been extended' ); |
106 | 120 | |
107 | diag("Testing against Catalyst $Catalyst::VERSION"); | |
108 | diag("Testing Catalyst::Plugin::Session $Catalyst::Plugin::Session::VERSION"); | |
109 | ||
110 | 121 | done_testing; |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
3 | use Test::Needs { | |
4 | 'Catalyst::Plugin::Authentication' => '0', | |
5 | 'Catalyst::Plugin::Session::State::Cookie' => '0.03', | |
6 | }; | |
7 | ||
5 | 8 | use Test::More; |
6 | 9 | |
7 | BEGIN { | |
8 | eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } | |
9 | or plan skip_all => | |
10 | "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; | |
10 | use lib "t/lib"; | |
11 | 11 | |
12 | eval { | |
13 | require Test::WWW::Mechanize::Catalyst; | |
14 | Test::WWW::Mechanize::Catalyst->VERSION(0.51); | |
15 | } | |
16 | or plan skip_all => | |
17 | 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; | |
18 | } | |
12 | use MiniUA; | |
19 | 13 | |
20 | use lib "t/lib"; | |
21 | use Test::WWW::Mechanize::Catalyst "SessionExpiry"; | |
22 | ||
23 | my $ua = Test::WWW::Mechanize::Catalyst->new; | |
14 | my $ua = MiniUA->new('SessionExpiry'); | |
24 | 15 | |
25 | 16 | my $res = $ua->get( "http://localhost/session_data_expires" ); |
26 | 17 | ok($res->is_success, "session_data_expires"); |
76 | 67 | ok($res->is_success, "session_expires"); |
77 | 68 | is($res->decoded_content, $updated, "session_expires == session_data_expires"); |
78 | 69 | |
79 | ||
80 | 70 | done_testing; |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
3 | use Test::Needs { | |
4 | 'Catalyst::Plugin::Authentication' => '0', | |
5 | 'Catalyst::Plugin::Session::State::Cookie' => '0.03', | |
6 | }; | |
7 | ||
5 | 8 | use Test::More; |
6 | use Data::Dumper; | |
7 | ||
8 | BEGIN { | |
9 | eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } | |
10 | or plan skip_all => | |
11 | "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; | |
12 | ||
13 | eval { | |
14 | require Test::WWW::Mechanize::Catalyst; | |
15 | Test::WWW::Mechanize::Catalyst->VERSION(0.51); | |
16 | } | |
17 | or plan skip_all => | |
18 | 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; | |
19 | ||
20 | plan tests => 10; | |
21 | } | |
22 | 9 | |
23 | 10 | use lib "t/lib"; |
24 | use Test::WWW::Mechanize::Catalyst "SessionTestApp"; | |
11 | ||
12 | use MiniUA; | |
25 | 13 | |
26 | 14 | #try completely random cookie unknown for our application; should be rejected |
27 | 15 | my $cookie_name = 'sessiontestapp_session'; |
29 | 17 | my ( @injected_cookie ) = ( 1, $cookie_name , $cookie_value ,'/', undef, 0, undef, undef, undef, {} ); |
30 | 18 | my $injected_cookie_str = "${cookie_name}=${cookie_value}"; |
31 | 19 | |
32 | my $ua1 = Test::WWW::Mechanize::Catalyst->new; | |
20 | my $ua1 = MiniUA->new('SessionTestApp'); | |
33 | 21 | $ua1->cookie_jar->set_cookie( @injected_cookie ); |
34 | 22 | |
35 | 23 | my $res = $ua1->get( "http://localhost/login" ); |
38 | 26 | ok $cookie1, "Set-Cookie 1"; |
39 | 27 | isnt $cookie1, qr/$injected_cookie_str/, "Logging in generates us a new cookie"; |
40 | 28 | |
41 | $ua1->get( "http://localhost/get_sessid" ); | |
42 | my $sid1 = $ua1->content; | |
29 | $res = $ua1->get( "http://localhost/get_sessid" ); | |
30 | my $sid1 = $res->content; | |
43 | 31 | |
44 | 32 | #set session variable var1 before session id change |
45 | 33 | $ua1->get( "http://localhost/set_session_variable/var1/set_before_change"); |
46 | $ua1->get( "http://localhost/get_session_variable/var1"); | |
47 | $ua1->content_is("VAR_var1=set_before_change"); | |
34 | $res = $ua1->get( "http://localhost/get_session_variable/var1"); | |
35 | is +$res->content, 'VAR_var1=set_before_change'; | |
48 | 36 | |
49 | 37 | #just diagnostic dump |
50 | $ua1->get( "http://localhost/dump_session" ); | |
51 | #diag "Before-change:".$ua1->content; | |
38 | #diag "Before-change:".$ua1->get( "http://localhost/dump_session" )->content; | |
52 | 39 | |
53 | 40 | #change session id; all session data should be kept; old session id invalidated |
54 | my $res2 = $ua1->get( "http://localhost/change_sessid" ); | |
55 | my $cookie2 = $res2->header('Set-Cookie'); | |
41 | $res = $ua1->get( "http://localhost/change_sessid" ); | |
42 | my $cookie2 = $res->header('Set-Cookie'); | |
56 | 43 | |
57 | 44 | ok $cookie2, "Set-Cookie 2"; |
58 | 45 | isnt $cookie2, $cookie1, "Cookie changed"; |
59 | 46 | |
60 | $ua1->get( "http://localhost/get_sessid" ); | |
61 | my $sid2 = $ua1->content; | |
47 | $res = $ua1->get( "http://localhost/get_sessid" ); | |
48 | my $sid2 = $res->content; | |
62 | 49 | isnt $sid2, $sid1, 'SID changed'; |
63 | 50 | |
64 | 51 | #just diagnostic dump |
65 | $ua1->get( "http://localhost/dump_session" ); | |
66 | #diag "After-change:".$ua1->content; | |
52 | #diag "After-change:".$ua1->get( "http://localhost/dump_session" )->content; | |
67 | 53 | |
68 | 54 | #set session variable var2 after session id change |
69 | 55 | $ua1->get( "http://localhost/set_session_variable/var2/set_after_change"); |
70 | 56 | |
71 | 57 | #check if var1 and var2 contain expected values |
72 | $ua1->get( "http://localhost/get_session_variable/var1"); | |
73 | $ua1->content_is("VAR_var1=set_before_change"); | |
74 | $ua1->get( "http://localhost/get_session_variable/var2"); | |
75 | $ua1->content_is("VAR_var2=set_after_change"); | |
58 | $res = $ua1->get( "http://localhost/get_session_variable/var1"); | |
59 | is +$res->content, 'VAR_var1=set_before_change'; | |
60 | $res = $ua1->get( "http://localhost/get_session_variable/var2"); | |
61 | is +$res->content, 'VAR_var2=set_after_change'; | |
76 | 62 | |
77 | 63 | #just diagnostic dump |
78 | $ua1->get( "http://localhost/dump_session" ); | |
79 | #diag "End1:".$ua1->content; | |
64 | #diag "End1".$ua1->get( "http://localhost/dump_session" )->content; | |
80 | 65 | |
81 | 66 | #try to use old cookie value (before session_id_change) |
82 | my $ua2 = Test::WWW::Mechanize::Catalyst->new; | |
67 | my $ua2 = MiniUA->new('SessionTestApp'); | |
83 | 68 | $ua2->cookie_jar->set_cookie( @injected_cookie ); |
84 | 69 | |
85 | 70 | #if we take old cookie we should not be able to get any old session data |
86 | $ua2->get( "http://localhost/get_session_variable/var1"); | |
87 | $ua2->content_is("VAR_var1=n.a."); | |
88 | $ua2->get( "http://localhost/get_session_variable/var2"); | |
89 | $ua2->content_is("VAR_var2=n.a."); | |
71 | $res = $ua2->get( "http://localhost/get_session_variable/var1"); | |
72 | is +$res->content, 'VAR_var1=n.a.'; | |
73 | $res = $ua2->get( "http://localhost/get_session_variable/var2"); | |
74 | is +$res->content, 'VAR_var2=n.a.'; | |
90 | 75 | |
91 | 76 | #just diagnostic dump |
92 | $ua2->get( "http://localhost/dump_session" ); | |
93 | #diag "End2:".$ua2->content; | |
77 | #diag "End2".$ua1->get( "http://localhost/dump_session" )->content; | |
78 | ||
79 | done_testing; |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
3 | use Test::Needs { | |
4 | 'Catalyst::Plugin::Authentication' => '0', | |
5 | 'Catalyst::Plugin::Session::State::Cookie' => '0.03', | |
6 | }; | |
7 | ||
5 | 8 | use Test::More; |
6 | BEGIN { | |
7 | eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } | |
8 | or plan skip_all => | |
9 | "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; | |
10 | ||
11 | eval { | |
12 | require Test::WWW::Mechanize::PSGI; | |
13 | #Test::WWW::Mechanize::Catalyst->VERSION(0.51); | |
14 | } | |
15 | or plan skip_all => | |
16 | 'Test::WWW::Mechanize::PSGI is required for this test'; | |
17 | ||
18 | eval { require Catalyst::Plugin::Authentication; 1 } | |
19 | or plan skip_all => "Catalyst::Plugin::Authentication is required for this test"; | |
20 | ||
21 | plan tests => 12; | |
22 | } | |
23 | 9 | |
24 | 10 | use lib "t/lib"; |
25 | use Test::WWW::Mechanize::PSGI; | |
26 | use SessionTestApp; | |
27 | my $ua = Test::WWW::Mechanize::PSGI->new( | |
28 | app => SessionTestApp->psgi_app(@_), | |
29 | cookie_jar => {} | |
30 | ); | |
11 | ||
12 | use MiniUA; | |
13 | ||
14 | my $ua = MiniUA->new('SessionTestApp'); | |
31 | 15 | |
32 | 16 | # Test without delete __address |
33 | 17 | local $ENV{REMOTE_ADDR} = "192.168.1.1"; |
34 | 18 | |
35 | $ua->get_ok( "http://localhost/login" ); | |
36 | $ua->content_contains('logged in'); | |
19 | my $res; | |
37 | 20 | |
38 | $ua->get_ok( "http://localhost/set_session_variable/logged/in" ); | |
39 | $ua->content_contains('session variable set'); | |
21 | $res = $ua->get( "http://localhost/login" ); | |
22 | ok +$res->is_success; | |
23 | like +$res->content, qr{logged in}; | |
24 | ||
25 | $res = $ua->get( "http://localhost/set_session_variable/logged/in" ); | |
26 | ok +$res->is_success; | |
27 | like +$res->content, qr{session variable set}; | |
40 | 28 | |
41 | 29 | |
42 | 30 | # Change Client |
43 | use Plack::Builder; | |
44 | my $app = SessionTestApp->psgi_app(@_); | |
45 | my $ua2 = Test::WWW::Mechanize::PSGI->new( | |
46 | app => $app, | |
47 | cookie_jar => {} | |
48 | ); | |
49 | $ua2->get_ok( "http://localhost/get_session_variable/logged"); | |
50 | $ua2->content_contains('VAR_logged=n.a.'); | |
31 | my $ua2 = MiniUA->new('SessionTestApp'); | |
32 | $res = $ua2->get( "http://localhost/get_session_variable/logged" ); | |
33 | ok +$res->is_success; | |
34 | like +$res->content, qr{VAR_logged=n\.a\.}; | |
51 | 35 | |
52 | 36 | # Inital Client |
53 | 37 | local $ENV{REMOTE_ADDR} = "192.168.1.1"; |
54 | 38 | |
55 | $ua->get_ok( "http://localhost/login_without_address" ); | |
56 | $ua->content_contains('logged in (without address)'); | |
39 | $res = $ua->get( "http://localhost/login_without_address" ); | |
40 | ok +$res->is_success; | |
41 | like +$res->content, qr{logged in \(without address\)}; | |
57 | 42 | |
58 | $ua->get_ok( "http://localhost/set_session_variable/logged/in" ); | |
59 | $ua->content_contains('session variable set'); | |
43 | $res = $ua->get( "http://localhost/set_session_variable/logged/in" ); | |
44 | ok +$res->is_success; | |
45 | like +$res->content, qr{session variable set}; | |
60 | 46 | |
61 | 47 | # Change Client |
62 | 48 | local $ENV{REMOTE_ADDR} = "192.168.1.2"; |
63 | 49 | |
64 | $ua->get_ok( "http://localhost/get_session_variable/logged" ); | |
65 | $ua->content_contains('VAR_logged=in'); | |
50 | $res = $ua->get( "http://localhost/get_session_variable/logged" ); | |
51 | ok +$res->is_success; | |
52 | like +$res->content, qr{VAR_logged=in}; | |
66 | 53 | |
67 | ||
68 | ||
54 | done_testing; |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
3 | use Test::Needs { | |
4 | 'Catalyst::Plugin::Authentication' => '0', | |
5 | 'Catalyst::Plugin::Session::State::Cookie' => '0.03', | |
6 | }; | |
7 | ||
5 | 8 | use Test::More; |
6 | 9 | |
7 | BEGIN { | |
8 | eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } | |
9 | or plan skip_all => | |
10 | "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; | |
10 | use lib "t/lib"; | |
11 | 11 | |
12 | eval { | |
13 | require Test::WWW::Mechanize::Catalyst; | |
14 | Test::WWW::Mechanize::Catalyst->VERSION(0.51); | |
15 | } | |
16 | or plan skip_all => | |
17 | 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; | |
12 | use MiniUA; | |
18 | 13 | |
19 | plan tests => 12; | |
20 | } | |
14 | my $ua = MiniUA->new('SessionTestApp'); | |
15 | $ua->agent('Initial user_agent'); | |
21 | 16 | |
22 | use lib "t/lib"; | |
23 | use Test::WWW::Mechanize::Catalyst "SessionTestApp"; | |
17 | my $res; | |
24 | 18 | |
25 | my $ua = Test::WWW::Mechanize::Catalyst->new( { agent => 'Initial user_agent'} ); | |
26 | $ua->get_ok( "http://localhost/user_agent", "get initial user_agent" ); | |
27 | $ua->content_contains( "UA=Initial user_agent", "test initial user_agent" ); | |
19 | $res = $ua->get( "http://localhost/user_agent" ); | |
20 | ok +$res->is_success, "get initial user_agent"; | |
21 | like +$res->content, qr{UA=Initial user_agent}, "test initial user_agent"; | |
28 | 22 | |
29 | $ua->get_ok( "http://localhost/page", "initial get main page" ); | |
30 | $ua->content_contains( "please login", "ua not logged in" ); | |
23 | $res = $ua->get( "http://localhost/page" ); | |
24 | ok +$res->is_success, "initial get main page"; | |
25 | like +$res->content, qr{please login}, "ua not logged in"; | |
31 | 26 | |
32 | $ua->get_ok( "http://localhost/login", "log ua in" ); | |
33 | $ua->content_contains( "logged in", "ua logged in" ); | |
27 | $res = $ua->get( "http://localhost/login" ); | |
28 | ok +$res->is_success, "log ua in"; | |
29 | like +$res->content, qr{logged in}, "ua logged in"; | |
34 | 30 | |
35 | $ua->get_ok( "http://localhost/page", "get main page" ); | |
36 | $ua->content_contains( "you are logged in", "ua logged in" ); | |
31 | $res = $ua->get( "http://localhost/page" ); | |
32 | ok +$res->is_success, "get main page"; | |
33 | like +$res->content, qr{you are logged in}, "ua logged in"; | |
37 | 34 | |
38 | 35 | $ua->agent('Changed user_agent'); |
39 | $ua->get_ok( "http://localhost/user_agent", "get changed user_agent" ); | |
40 | $ua->content_contains( "UA=Changed user_agent", "test changed user_agent" ); | |
41 | 36 | |
42 | $ua->get_ok( "http://localhost/page", "test deleted session" ); | |
43 | $ua->content_contains( "please login", "ua not logged in" ); | |
37 | $res = $ua->get( "http://localhost/user_agent" ); | |
38 | ok +$res->is_success, "get changed user_agent"; | |
39 | like +$res->content, qr{UA=Changed user_agent}, "test changed user_agent"; | |
40 | ||
41 | $res = $ua->get( "http://localhost/page" ); | |
42 | ok +$res->is_success, "test deleted session"; | |
43 | like +$res->content, qr{please login}, "ua not logged in"; | |
44 | ||
45 | done_testing; |
0 | #!/usr/bin/perl | |
1 | ||
2 | 0 | use strict; |
3 | 1 | use warnings; |
4 | 2 | |
3 | use Test::Needs { | |
4 | 'Catalyst::Plugin::Session::State::Cookie' => '0.03', | |
5 | }; | |
6 | ||
5 | 7 | use Test::More; |
6 | 8 | |
7 | BEGIN { | |
8 | eval { require Catalyst::Plugin::Session::State::Cookie; Catalyst::Plugin::Session::State::Cookie->VERSION(0.03) } | |
9 | or plan skip_all => | |
10 | "Catalyst::Plugin::Session::State::Cookie 0.03 or higher is required for this test"; | |
9 | use lib "t/lib"; | |
11 | 10 | |
12 | eval { | |
13 | require Test::WWW::Mechanize::Catalyst; | |
14 | Test::WWW::Mechanize::Catalyst->VERSION(0.51); | |
15 | } | |
16 | or plan skip_all => | |
17 | 'Test::WWW::Mechanize::Catalyst >= 0.51 is required for this test'; | |
11 | use MiniUA; | |
18 | 12 | |
19 | plan tests => 4; | |
20 | } | |
21 | use FindBin qw/$Bin/; | |
22 | use lib "$Bin/lib"; | |
23 | use Test::WWW::Mechanize::Catalyst "SessionValid"; | |
13 | my $ua = MiniUA->new('SessionValid'); | |
24 | 14 | |
25 | my $ua = Test::WWW::Mechanize::Catalyst->new; | |
15 | my $res; | |
26 | 16 | |
27 | $ua->get_ok( "http://localhost/", "initial get" ); | |
28 | $ua->content_contains( "value set", "page contains expected value" ); | |
17 | $res = $ua->get( "http://localhost/" ); | |
18 | ok +$res->is_success, "initial get"; | |
19 | like +$res->content, qr{value set}, "page contains expected value"; | |
29 | 20 | |
30 | 21 | sleep 2; |
31 | 22 | |
32 | $ua->get_ok( "http://localhost/", "grab the page again, after the session has expired" ); | |
33 | $ua->content_contains( "value set", "page contains expected value" ); | |
23 | $res = $ua->get( "http://localhost/" ); | |
24 | ok +$res->is_success, "grab the page again, after the session has expired"; | |
25 | like +$res->content, qr{value set}, "page contains expected value"; | |
34 | 26 | |
27 | done_testing; |