Codebase list libcatalyst-plugin-session-perl / 183f029
New upstream version 0.43 gregor herrmann 1 year, 10 months ago
41 changed file(s) with 988 addition(s) and 2568 deletion(s). Raw diff Collapse all Expand all
+13
-0
Changes less more
00 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
114
215 0.41 2018-12-05
316 - Don't let an evil session ID supplier have an easy XSS vector (Michael McClimon++)
+374
-0
LICENSE less more
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
+8
-13
MANIFEST less more
00 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
101 lib/Catalyst/Plugin/Session.pm
112 lib/Catalyst/Plugin/Session/State.pm
123 lib/Catalyst/Plugin/Session/Store.pm
134 lib/Catalyst/Plugin/Session/Store/Dummy.pm
145 lib/Catalyst/Plugin/Session/Test/Store.pm
156 lib/Catalyst/Plugin/Session/Tutorial.pod
7 maint/Makefile.PL.include
168 Makefile.PL
179 MANIFEST This list of files
18 META.yml
19 README
2010 t/00_basic_sanity.t
2111 t/01_setup.t
2212 t/03_flash.t
2313 t/05_semi_persistent_flash.t
24 t/author/pod.t
25 t/author/podcoverage.t
2614 t/cat_test.t
2715 t/lib/FlashTestApp.pm
2816 t/lib/FlashTestApp/Controller/Root.pm
17 t/lib/MiniUA.pm
2918 t/lib/SessionExpiry.pm
3019 t/lib/SessionExpiry/Controller/Root.pm
3120 t/lib/SessionTestApp.pm
3928 t/live_verify_address.t
4029 t/live_verify_user_agent.t
4130 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)
+81
-0
META.json less more
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 }
+23
-21
META.yml less more
00 ---
11 abstract: 'Generic Session plugin - ties together server side storage and client side state required to maintain session data.'
22 author:
3 - 'Andy Grundman'
3 - 'Yuval Kogman <nothingmuch@woobling.org>'
44 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'
98 configure_requires:
10 ExtUtils::MakeMaker: 6.59
11 distribution_type: module
9 ExtUtils::MakeMaker: '0'
1210 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'
1412 license: perl
1513 meta-spec:
1614 url: http://module-build.sourceforge.net/META-spec-v1.4.html
17 version: 1.4
15 version: '1.4'
1816 name: Catalyst-Plugin-Session
1917 no_index:
2018 directory:
21 - inc
2219 - t
20 - xt
2321 requires:
2422 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'
3129 Moose: '0.76'
3230 MooseX::Emulate::Class::Accessor::Fast: '0.00801'
33 Object::Signature: 0
31 Object::Signature: '0'
3432 Test::More: '0.88'
35 Tie::RefHash: '1.34'
3633 namespace::clean: '0.10'
37 perl: 5.8.0
34 perl: '5.008'
3835 resources:
36 bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Catalyst-Plugin-Session
3937 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'
+116
-54
Makefile.PL less more
0 use inc::Module::Install 0.87;
1 use Module::Install::AuthorTests;
0 use strict;
1 use warnings;
2 use 5.008;
23
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 );
762
8 is_upgrading_needed();
63 my %MM_ARGS = ();
964
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;
5571 ********** NOTE **********
5672
57 $package must also be updated!
73 $breaks must also be updated!
5874
5975 The currently installed version is *not* compatible with this version of
6076 Catalyst::Plugin::Session!
6379
6480 **************************
6581 WARN
66 }
6782 }
83 }
6884 }
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
-59
inc/Module/Install/AuthorTests.pm less more
0 #line 1
1 package Module::Install::AuthorTests;
2
3 use 5.005;
4 use strict;
5 use Module::Install::Base;
6 use Carp ();
7
8 #line 16
9
10 use vars qw{$VERSION $ISCORE @ISA};
11 BEGIN {
12 $VERSION = '0.002';
13 $ISCORE = 1;
14 @ISA = qw{Module::Install::Base};
15 }
16
17 #line 42
18
19 sub author_tests {
20 my ($self, @dirs) = @_;
21 _add_author_tests($self, \@dirs, 0);
22 }
23
24 #line 56
25
26 sub recursive_author_tests {
27 my ($self, @dirs) = @_;
28 _add_author_tests($self, \@dirs, 1);
29 }
30
31 sub _wanted {
32 my $href = shift;
33 sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 }
34 }
35
36 sub _add_author_tests {
37 my ($self, $dirs, $recurse) = @_;
38 return unless $Module::Install::AUTHOR;
39
40 my @tests = $self->tests ? (split / /, $self->tests) : 't/*.t';
41
42 # XXX: pick a default, later -- rjbs, 2008-02-24
43 my @dirs = @$dirs ? @$dirs : Carp::confess "no dirs given to author_tests";
44 @dirs = grep { -d } @dirs;
45
46 if ($recurse) {
47 require File::Find;
48 my %test_dir;
49 File::Find::find(_wanted(\%test_dir), @dirs);
50 $self->tests( join ' ', @tests, map { "$_/*.t" } sort keys %test_dir );
51 } else {
52 $self->tests( join ' ', @tests, map { "$_/*.t" } sort @dirs );
53 }
54 }
55
56 #line 107
57
58 1;
+0
-83
inc/Module/Install/Base.pm less more
0 #line 1
1 package Module::Install::Base;
2
3 use strict 'vars';
4 use vars qw{$VERSION};
5 BEGIN {
6 $VERSION = '1.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
-163
inc/Module/Install/Can.pm less more
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
-93
inc/Module/Install/Fetch.pm less more
0 #line 1
1 package Module::Install::Fetch;
2
3 use strict;
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.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
-418
inc/Module/Install/Makefile.pm less more
0 #line 1
1 package Module::Install::Makefile;
2
3 use strict 'vars';
4 use ExtUtils::MakeMaker ();
5 use Module::Install::Base ();
6 use Fcntl qw/:flock :seek/;
7
8 use vars qw{$VERSION @ISA $ISCORE};
9 BEGIN {
10 $VERSION = '1.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
-722
inc/Module/Install/Metadata.pm less more
0 #line 1
1 package Module::Install::Metadata;
2
3 use strict 'vars';
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.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
-64
inc/Module/Install/Win32.pm less more
0 #line 1
1 package Module::Install::Win32;
2
3 use strict;
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.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
-63
inc/Module/Install/WriteAll.pm less more
0 #line 1
1 package Module::Install::WriteAll;
2
3 use strict;
4 use Module::Install::Base ();
5
6 use vars qw{$VERSION @ISA $ISCORE};
7 BEGIN {
8 $VERSION = '1.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
-451
inc/Module/Install.pm less more
0 #line 1
1 package Module::Install;
2
3 # For any maintainers:
4 # The load order for Module::Install is a bit magic.
5 # It goes something like this...
6 #
7 # IF ( host has Module::Install installed, creating author mode ) {
8 # 1. Makefile.PL calls "use inc::Module::Install"
9 # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install
10 # 3. The installed version of inc::Module::Install loads
11 # 4. inc::Module::Install calls "require Module::Install"
12 # 5. The ./inc/ version of Module::Install loads
13 # } ELSE {
14 # 1. Makefile.PL calls "use inc::Module::Install"
15 # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install
16 # 3. The ./inc/ version of Module::Install loads
17 # }
18
19 use 5.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.
+4
-3
lib/Catalyst/Plugin/Session/State.pm less more
0 #!/usr/bin/perl
1
20 package Catalyst::Plugin::Session::State;
31
42 use strict;
53 use warnings;
4
5 our $VERSION = '0.43';
6 $VERSION =~ tr/_//d;
67
78 __PACKAGE__;
89
4647 =item finalize
4748
4849 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.
5051
5152 =back
5253
+3
-2
lib/Catalyst/Plugin/Session/Store/Dummy.pm less more
0 #!/usr/bin/perl
1
20 package Catalyst::Plugin::Session::Store::Dummy;
31 use base qw/Catalyst::Plugin::Session::Store/;
42
53 use strict;
64 use warnings;
5
6 our $VERSION = '0.43';
7 $VERSION =~ tr/_//d;
78
89 my %store;
910
+5
-4
lib/Catalyst/Plugin/Session/Store.pm less more
0 #!/usr/bin/perl
1
20 package Catalyst::Plugin::Session::Store;
31
42 use strict;
53 use warnings;
4
5 our $VERSION = '0.43';
6 $VERSION =~ tr/_//d;
67
78 __PACKAGE__;
89
2627 C<Catalyst::Plugin::Session> module sets up it will check to see that
2728 C<< YourApp->isa("Catalyst::Plugin::Session::Store") >>. When you write
2829 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
3031 plugins, not for end users.
3132
3233 =head1 WRITING STORE PLUGINS
6566
6667 $c->store_session_data( $x, $y );
6768
68 for any $x,
69 for any $x,
6970
7071 $y == $c->get_session_data( $x )
7172
+8
-5
lib/Catalyst/Plugin/Session/Test/Store.pm less more
0 #!/usr/bin/perl
1
20 package Catalyst::Plugin::Session::Test::Store;
31
42 use strict;
53 use warnings;
4
5 our $VERSION = '0.43';
6 $VERSION =~ tr/_//d;
67
78 use utf8;
89
5657 use Catalyst qw/Session SessionStateTest/;
5758 push our (@ISA), $m;
5859
59 our $VERSION = "123"; # Do not remove
60 our $VERSION # make unparseable
61 = "123"; # Do not remove
6062
6163 use strict;
6264 use warnings;
104106 use Catalyst qw/Session SessionStateTest/;
105107 push our (@ISA), $m;
106108
107 our $VERSION = "123";
109 our $VERSION # make unparseable
110 = "123";
108111
109112 use Test::More;
110113
149152 use Catalyst::Test "SessionStoreTest";
150153
151154 # idiotic void context warning workaround
152
155
153156 my $x = get("/create_session");
154157 $x = get("/recover_session");
155158 $x = get("/after_session");
+2
-4
lib/Catalyst/Plugin/Session.pm less more
0 #!/usr/bin/perl
1
20 package Catalyst::Plugin::Session;
31
42 use Moose;
1412
1513 use namespace::clean -except => 'meta';
1614
17 our $VERSION = '0.41';
18 $VERSION = eval $VERSION;
15 our $VERSION = '0.43';
16 $VERSION =~ tr/_//d;
1917
2018 my @session_data_accessors; # used in delete_session
2119
+7
-0
maint/Makefile.PL.include less more
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;
+4
-7
t/00_basic_sanity.t less more
0 #!/usr/bin/perl
1
20 use strict;
31 use warnings;
42
5 use Test::More tests => 4;
3 use Test::More;
64
5 use Catalyst::Plugin::Session;
76
8 my $m; BEGIN { use_ok($m = "Catalyst::Plugin::Session") }
7 can_ok('Catalyst::Plugin::Session', qw/sessionid session session_delete_reason/);
98
10 can_ok($m, $_) for qw/sessionid session session_delete_reason/;
11
12
9 done_testing;
+5
-7
t/01_setup.t less more
0 #!/usr/bin/perl
1
20 use strict;
31 use warnings;
42
5 use Test::More tests => 10;
3 use Test::More;
64 use Class::MOP;
75 use Test::Deep;
86
9 my $m;
10 BEGIN { use_ok( $m = "Catalyst::Plugin::Session" ) }
7 use Catalyst::Plugin::Session;
118
129 my %config;
1310 my $log_meta = Class::MOP::Class->create_anon_class(superclasses => ['Moose::Object']);
2118
2219 package MockCxt;
2320 use MRO::Compat;
24 use base $m;
21 use base qw(Catalyst::Plugin::Session);
2522 sub new { bless {}, $_[0] }
2623 sub config { \%config }
2724 sub log { $log }
3330 }
3431 }
3532
36 can_ok( $m, "setup" );
33 can_ok( 'Catalyst::Plugin::Session', "setup" );
3734
3835 eval { MockCxt->new->setup }; # throws OK is not working with NEXT
3936 like(
7370 is( $config{session}{expires},
7471 1234, "user values are not overwritten in config" );
7572
73 done_testing;
+5
-7
t/03_flash.t less more
0 #!/usr/bin/perl
1
20 use strict;
31 use warnings;
42
5 use Test::More tests => 12;
6 use Test::Exception;
3 use Test::More;
74 use Test::Deep;
85
9 my $m;
10 BEGIN { use_ok( $m = "Catalyst::Plugin::Session" ) }
6 use Catalyst::Plugin::Session;
117
128 my $c_meta = Class::MOP::Class->create_anon_class(
13 superclasses => [ $m, 'Moose::Object', ],
9 superclasses => [ 'Catalyst::Plugin::Session', 'Moose::Object', ],
1410 );
1511 my $c = $c_meta->name->new;
1612
7672 $c->prepare_action;
7773
7874 is_deeply( $c->stash, { bar => "gorch" }, "flash copied to stash" );
75
76 done_testing;
+25
-29
t/05_semi_persistent_flash.t less more
0 #!/usr/bin/perl -w
10 use strict;
1 use warnings;
2
3 use Test::Needs {
4 'Catalyst::Plugin::Session::State::Cookie' => '0.03',
5 };
26
37 use Test::More;
48
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";
910
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;
1612
17 plan tests => '10';
13 my $ua = MiniUA->new('FlashTestApp');
1814
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;
2516
2617 # 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";
2921
3022 # 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";
3326
3427 # 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";
3731
3832 # 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";
4236
4337 # 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";
4641
42 done_testing;
+0
-7
t/author/pod.t less more
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
-7
t/author/podcoverage.t less more
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();
+16
-22
t/cat_test.t less more
0 #!/usr/bin/env perl
1
20 use strict;
31 use warnings;
2
3 use Test::Needs {
4 'Catalyst::Plugin::Authentication' => '0',
5 'Catalyst::Plugin::Session::State::Cookie' => '0.03',
6 };
7
48 use Test::More;
9
510 use HTTP::Request::Common;
611
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";
1913
2014 use Catalyst::Test 'SessionTestApp';
21 my ($res, $c);
15 my $res;
2216
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]);
2418 is($res->code, 200, 'succeeded');
2519 my $cookie = $res->header('Set-Cookie');
2620 ok($cookie, 'Have a cookie');
2721
2822 # cookie is changed by the get
2923 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');
3226 my $new_cookie = $res->header('Set-Cookie');
3327 isnt( $cookie, $new_cookie, 'cookie expires has been updated' );
3428
3529 # 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');
3832 $new_cookie = $res->header('Set-Cookie');
3933 ok( ! defined $new_cookie, 'no cookie created' );
4034
4135 # 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);
4337 my $reset_cookie = $res->header('Set-Cookie');
4438 isnt( $cookie, $reset_cookie, 'Cookie has been changed by reset_session' );
4539
4640 # this checks that cookie exists after a logout and redirect
4741 # 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);
4943 is($res->code, 302, 'redirected');
5044 is($res->header('Location'), 'http://localhost/from_logout_redirect', 'Redirected after logout_redirect');
5145 ok($res->header('Set-Cookie'), 'Cookie is there after redirect');
+1
-1
t/lib/FlashTestApp/Controller/Root.pm less more
1212 my ($self, $c) = @_;
1313 $c->session;
1414 }
15
15
1616 sub first : Global {
1717 my ( $self, $c ) = @_;
1818 if ( ! $c->flash->{is_set}) {
+0
-2
t/lib/FlashTestApp.pm less more
0 #!/usr/bin/env perl
1
20 package FlashTestApp;
31 use Catalyst qw/Session Session::Store::Dummy Session::State::Cookie/;
42
+66
-0
t/lib/MiniUA.pm less more
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
-2
t/lib/SessionTestApp.pm less more
0 #!/usr/bin/env perl
1
20 package SessionTestApp;
31 use Catalyst qw/Session Session::Store::Dummy Session::State::Cookie Authentication/;
42
+14
-23
t/live_accessor.t less more
0 #!/usr/bin/perl
1 #
20 use strict;
31 use warnings;
42
3 use Test::Needs {
4 'Catalyst::Plugin::Authentication' => '0',
5 'Catalyst::Plugin::Session::State::Cookie' => '0.03',
6 };
7
58 use Test::More;
69
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";
1111
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;
1813
19 plan tests => 4;
20 }
14 my $ua = MiniUA->new('SessionTestApp');
2115
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';
2418
25 my $ua = Test::WWW::Mechanize::Catalyst->new;
19 like +$res->content, qr{two: 2}, 'k/v list setter works okay';
2620
27 $ua->get_ok("http://localhost/accessor_test", "Set session vars okay");
21 like +$res->content, qr{four: 4}, 'hashref setter works okay';
2822
29 $ua->content_contains("two: 2", "k/v list setter works okay");
23 like +$res->content, qr{five: 5}, 'direct access works okay';
3024
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;
+84
-73
t/live_app.t less more
0 #!/usr/bin/perl
1
20 use strict;
31 use warnings;
42
3 use Test::Needs {
4 'Catalyst::Plugin::Authentication' => '0',
5 'Catalyst::Plugin::Session::State::Cookie' => '0.03',
6 };
7
58 use Test::More;
69
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";
1111
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;
1913
20 use lib "t/lib";
21 use Test::WWW::Mechanize::Catalyst "SessionTestApp";
14 my $ua1 = MiniUA->new('SessionTestApp');
15 my $ua2 = MiniUA->new('SessionTestApp');
2216
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;
2520
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';
2723
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';
3027
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;
3331
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';
3534
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';
3838
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;
4142
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';
4345
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+)$/);
4948
5049 sleep 1;
5150
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;
5354
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';
5657
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+)$/);
5960
6061 cmp_ok( $u1_expires, "<", $u1_expires_updated, "expiry time updated");
6162 cmp_ok( $u2_expires, "<", $u2_expires_updated, "expiry time updated");
6263
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';
6769
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;
6973
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';
7276
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';
7782
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;
7986
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';
8289
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/;
9496
9597
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+)$/);
100112 is( $ua4_expires1, $ua4_expires2, 'expires has not changed' );
101113
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+)$/);
105119 ok( $ua4_expires3 > ( $ua4_expires1 + 30000000), 'expires has been extended' );
106120
107 diag("Testing against Catalyst $Catalyst::VERSION");
108 diag("Testing Catalyst::Plugin::Session $Catalyst::Plugin::Session::VERSION");
109
110121 done_testing;
+8
-18
t/live_expiry_threshold.t less more
0 #!/usr/bin/perl
1
20 use strict;
31 use warnings;
42
3 use Test::Needs {
4 'Catalyst::Plugin::Authentication' => '0',
5 'Catalyst::Plugin::Session::State::Cookie' => '0.03',
6 };
7
58 use Test::More;
69
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";
1111
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;
1913
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');
2415
2516 my $res = $ua->get( "http://localhost/session_data_expires" );
2617 ok($res->is_success, "session_data_expires");
7667 ok($res->is_success, "session_expires");
7768 is($res->decoded_content, $updated, "session_expires == session_data_expires");
7869
79
8070 done_testing;
+31
-45
t/live_session_fixation.t less more
0 #!/usr/bin/perl
1
20 use strict;
31 use warnings;
42
3 use Test::Needs {
4 'Catalyst::Plugin::Authentication' => '0',
5 'Catalyst::Plugin::Session::State::Cookie' => '0.03',
6 };
7
58 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 }
229
2310 use lib "t/lib";
24 use Test::WWW::Mechanize::Catalyst "SessionTestApp";
11
12 use MiniUA;
2513
2614 #try completely random cookie unknown for our application; should be rejected
2715 my $cookie_name = 'sessiontestapp_session';
2917 my ( @injected_cookie ) = ( 1, $cookie_name , $cookie_value ,'/', undef, 0, undef, undef, undef, {} );
3018 my $injected_cookie_str = "${cookie_name}=${cookie_value}";
3119
32 my $ua1 = Test::WWW::Mechanize::Catalyst->new;
20 my $ua1 = MiniUA->new('SessionTestApp');
3321 $ua1->cookie_jar->set_cookie( @injected_cookie );
3422
3523 my $res = $ua1->get( "http://localhost/login" );
3826 ok $cookie1, "Set-Cookie 1";
3927 isnt $cookie1, qr/$injected_cookie_str/, "Logging in generates us a new cookie";
4028
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;
4331
4432 #set session variable var1 before session id change
4533 $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';
4836
4937 #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;
5239
5340 #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');
5643
5744 ok $cookie2, "Set-Cookie 2";
5845 isnt $cookie2, $cookie1, "Cookie changed";
5946
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;
6249 isnt $sid2, $sid1, 'SID changed';
6350
6451 #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;
6753
6854 #set session variable var2 after session id change
6955 $ua1->get( "http://localhost/set_session_variable/var2/set_after_change");
7056
7157 #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';
7662
7763 #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;
8065
8166 #try to use old cookie value (before session_id_change)
82 my $ua2 = Test::WWW::Mechanize::Catalyst->new;
67 my $ua2 = MiniUA->new('SessionTestApp');
8368 $ua2->cookie_jar->set_cookie( @injected_cookie );
8469
8570 #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.';
9075
9176 #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;
+31
-45
t/live_verify_address.t less more
0 #!/usr/bin/perl
1
20 use strict;
31 use warnings;
42
3 use Test::Needs {
4 'Catalyst::Plugin::Authentication' => '0',
5 'Catalyst::Plugin::Session::State::Cookie' => '0.03',
6 };
7
58 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 }
239
2410 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');
3115
3216 # Test without delete __address
3317 local $ENV{REMOTE_ADDR} = "192.168.1.1";
3418
35 $ua->get_ok( "http://localhost/login" );
36 $ua->content_contains('logged in');
19 my $res;
3720
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};
4028
4129
4230 # 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\.};
5135
5236 # Inital Client
5337 local $ENV{REMOTE_ADDR} = "192.168.1.1";
5438
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\)};
5742
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};
6046
6147 # Change Client
6248 local $ENV{REMOTE_ADDR} = "192.168.1.2";
6349
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};
6653
67
68
54 done_testing;
+31
-29
t/live_verify_user_agent.t less more
0 #!/usr/bin/perl
1
20 use strict;
31 use warnings;
42
3 use Test::Needs {
4 'Catalyst::Plugin::Authentication' => '0',
5 'Catalyst::Plugin::Session::State::Cookie' => '0.03',
6 };
7
58 use Test::More;
69
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";
1111
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;
1813
19 plan tests => 12;
20 }
14 my $ua = MiniUA->new('SessionTestApp');
15 $ua->agent('Initial user_agent');
2116
22 use lib "t/lib";
23 use Test::WWW::Mechanize::Catalyst "SessionTestApp";
17 my $res;
2418
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";
2822
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";
3126
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";
3430
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";
3734
3835 $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" );
4136
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;
+15
-22
t/session_valid.t less more
0 #!/usr/bin/perl
1
20 use strict;
31 use warnings;
42
3 use Test::Needs {
4 'Catalyst::Plugin::Session::State::Cookie' => '0.03',
5 };
6
57 use Test::More;
68
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";
1110
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;
1812
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');
2414
25 my $ua = Test::WWW::Mechanize::Catalyst->new;
15 my $res;
2616
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";
2920
3021 sleep 2;
3122
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";
3426
27 done_testing;
+4
-0
xt/pod.t less more
0 use Test::More;
1
2 use Test::Pod 1.14;
3 all_pod_files_ok();
+4
-0
xt/podcoverage.t less more
0 use Test::More;
1
2 use Test::Pod::Coverage 1.04;
3 all_pod_coverage_ok();