CGI-Application-Plugin-Authentication-0.24000755001750001750 014546072342 17301 5ustar00weswes000000000000README100644001750001750 10364714546072342 20315 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24NAME CGI::Application::Plugin::Authentication - Authentication framework for CGI::Application SYNOPSIS package MyCGIApp; use base qw(CGI::Application); # make sure this occurs before you load the plugin use CGI::Application::Plugin::Authentication; MyCGIApp->authen->config( DRIVER => [ 'Generic', { user1 => '123' } ], ); MyCGIApp->authen->protected_runmodes('myrunmode'); sub myrunmode { my $self = shift; # The user should be logged in if we got here my $username = $self->authen->username; } DESCRIPTION CGI::Application::Plugin::Authentication adds the ability to authenticate users in your CGI::Application modules. It imports one method called 'authen' into your CGI::Application module. Through the authen method you can call all the methods of the CGI::Application::Plugin::Authentication plugin. There are two main decisions that you need to make when using this module. How will the usernames and password be verified (i.e. from a database, LDAP, etc...), and how can we keep the knowledge that a user has already logged in persistent, so that they will not have to enter their credentials again on the next request (i.e. how do we 'Store' the authentication information across requests). Choosing a Driver There are three drivers that are included with the distribution. Also, there is built in support for all of the Authen::Simple modules (search CPAN for Authen::Simple for more information). This should be enough to cover everyone's needs. If you need to authenticate against a source that is not provided, you can use the Generic driver which will accept either a hash of username/password pairs, or an array of arrays of credentials, or a subroutine reference that can verify the credentials. So through the Generic driver you should be able to write your own verification system. There is also a Dummy driver, which blindly accepts any credentials (useful for testing). See the CGI::Application::Plugin::Authentication::Driver::Generic, CGI::Application::Plugin::Authentication::Driver::DBI and, CGI::Application::Plugin::Authentication::Driver::Dummy docs for more information on how to use these drivers. And see the Authen::Simple suite of modules for information on those drivers. Choosing a Store The Store modules keep information about the authentication status of the user persistent across multiple requests. The information that is stored in the store include the username, and the expiry time of the login. There are two Store modules included with this distribution. A Session based store, and a Cookie based store. If your application is already using Sessions (through the CGI::Application::Plugin::Session module), then I would recommend that you use the Session store for authentication. If you are not using the Session plugin, then you can use the Cookie store. The Cookie store keeps all the authentication in a cookie, which contains a checksum to ensure that users can not change the information. If you do not specify which Store module you wish to use, the plugin will try to determine the best one for you. Login page The Authentication plugin comes with a default login page that can be used if you do not want to create a custom login page. This login form will automatically be used if you do not provide either a LOGIN_URL or LOGIN_RUNMODE parameter in the configuration. If you plan to create your own login page, I would recommend that you start with the HTML code for the default login page, so that your login page will contain the correct form fields and hidden fields. Ticket based authentication This Authentication plugin can handle ticket based authentication systems as well. All that is required of you is to write a Store module that can understand the contents of the ticket. The Authentication plugin will require at least the 'username' to be retrieved from the ticket. A Ticket based authentication scheme will not need a Driver module at all, since the actual verification of credentials is done by an external authentication system, possibly even on a different host. You will need to specify the location of the login page using the LOGIN_URL configuration variable, and unauthenticated users will automatically be redirected to your ticket authentication login page. EXPORTED METHODS authen This is the only method exported from this module. Everything is controlled through this method call, which will return a CGI::Application::Plugin::Authentication object, or just the class name if called as a class method. When using the plugin, you will always first call $self->authen or __PACKAGE__->authen and then the method you wish to invoke. For example: __PACKAGE__->authen->config( LOGIN_RUNMODE => 'login', ); - or - $self->authen->protected_runmodes(qw(one two)); METHODS config This method is used to configure the CGI::Application::Plugin::Authentication module. It can be called as an object method, or as a class method. Calling this function, will not itself generate cookies or session ids. The following parameters are accepted: DRIVER Here you can choose which authentication module(s) you want to use to perform the authentication. For simplicity, you can leave off the CGI::Application::Plugin::Authentication::Driver:: part when specifying the DRIVER name If this module requires extra parameters, you can pass an array reference that contains as the first parameter the name of the module, and the rest of the values in the array will be considered options for the driver. You can provide multiple drivers which will be used, in order, to check the credentials until a valid response is received. DRIVER => 'Dummy' # let anyone in regardless of the password - or - DRIVER => [ 'DBI', DBH => $self->dbh, TABLE => 'user', CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__', 'MD5:user.password' => '__CREDENTIAL_2__' }, ], - or - DRIVER => [ [ 'Generic', { user1 => '123' } ], [ 'Generic', sub { my ($u, $p) = @_; is_prime($p) ? 1 : 0 } ] ], - or - DRIVER => [ 'Authen::Simple::LDAP', host => 'ldap.company.com', basedn => 'ou=People,dc=company,dc=net' ], STORE Here you can choose how we store the authenticated information after a user has successfully logged in. We need to store the username so that on the next request we can tell the user has already logged in, and we do not have to present them with another login form. If you do not provide the STORE option, then the plugin will look to see if you are using the CGI::Application::Plugin::Session module and based on that info use either the Session module, or fall back on the Cookie module. If the module requires extra parameters, you can pass an array reference that contains as the first parameter the name of the module, and the rest of the array should contain key value pairs of options for this module. These storage modules generally live under the CGI::Application::Plugin::Authentication::Store:: name-space, and this part of the package name can be left off when specifying the STORE parameter. STORE => 'Session' - or - STORE => ['Cookie', NAME => 'MYAuthCookie', SECRET => 'FortyTwo', EXPIRY => '1d', ] POST_LOGIN_RUNMODE Here you can specify a runmode that the user will be redirected to if they successfully login. POST_LOGIN_RUNMODE => 'welcome' POST_LOGIN_URL Here you can specify a URL that the user will be redirected to if they successfully login. If both POST_LOGIN_URL and POST_LOGIN_RUNMODE are specified, then the latter will take precedence. POST_LOGIN_URL => 'http://example.com/start.cgi' POST_LOGIN_CALLBACK A code reference that is executed after login processing but before POST_LOGIN_RUNMODE or redirecting to POST_LOGIN_URL. This is normally a method in your CGI::Application application and as such the CGI::Application object is passed as a parameter. POST_LOGIN_CALLBACK => \&update_login_date and later in your code: sub update_login_date { my $self = shift; return unless($self->authen->is_authenticated); ... } LOGIN_RUNMODE Here you can specify a runmode that the user will be redirected to if they need to login. LOGIN_RUNMODE => 'login' LOGIN_URL If your login page is external to this module, then you can use this option to specify a URL that the user will be redirected to when they need to login. If both LOGIN_URL and LOGIN_RUNMODE are specified, then the latter will take precedence. LOGIN_URL => 'http://example.com/login.cgi' LOGOUT_RUNMODE Here you can specify a runmode that the user will be redirected to if they ask to logout. LOGOUT_RUNMODE => 'logout' LOGOUT_URL If your logout page is external to this module, then you can use this option to specify a URL that the user will be redirected to when they ask to logout. If both LOGOUT_URL and LOGOUT_RUNMODE are specified, then the latter will take precedence. LOGIN_URL => 'http://example.com/logout.html' DETAINT_URL_REGEXP This is a regular expression used to detaint URLs used in the login form. By default it will be set to ^([\w\_\%\?\&\;\-\/\@\.\+\$\=\#\:\!\*\"\'\(\)\,]+)$ This regular expression is based upon the document http://www.w3.org/Addressing/URL/url-spec.txt. You could set it to a more specific regular expression to limit the domains to which users could be directed. DETAINT_USERNAME_REGEXP This is a regular expression used to detaint the username parameter used in the login form. By default it will be set to ^([\w\_]+)$ CREDENTIALS Set this to the list of form fields where the user will type in their username and password. By default this is set to ['authen_username', 'authen_password']. The form field names should be set to a value that you are not likely to use in any other forms. This is important because this plugin will automatically look for query parameters that match these values on every request to see if a user is trying to log in. So if you use the same parameter names on a user management page, you may inadvertently perform a login when that was not intended. Most of the Driver modules will return the first CREDENTIAL as the username, so make sure that you list the username field first. This option can be ignored if you use the built in login box CREDENTIALS => 'authen_password' - or - CREDENTIALS => [ 'authen_username', 'authen_domain', 'authen_password' ] LOGIN_SESSION_TIMEOUT This option can be used to tell the system when to force the user to re-authenticate. There are a few different possibilities that can all be used concurrently: IDLE_FOR If this value is set, a re-authentication will be forced if the user was idle for more then x amount of time. EVERY If this value is set, a re-authentication will be forced every x amount of time. CUSTOM This value can be set to a subroutine reference that returns true if the session should be timed out, and false if it is still active. This can allow you to be very selective about how the timeout system works. The authen object will be passed in as the only parameter. Time values are specified in seconds. You can also specify the time by using a number with the following suffixes (m h d w), which represent minutes, hours, days and weeks. The default is 0 which means the login will never timeout. Note that the login is also dependent on the type of STORE that is used. If the Session store is used, and the session expires, then the login will also automatically expire. The same goes for the Cookie store. For backwards compatibility, if you set LOGIN_SESSION_TIMEOUT to a time value instead of a hashref, it will be treated as an IDLE_FOR time out. # force re-authentication if idle for more than 15 minutes LOGIN_SESSION_TIMEOUT => '15m' # Everyone must re-authentication if idle for more than 30 minutes # also, everyone must re-authentication at least once a day # and root must re-authentication if idle for more than 5 minutes LOGIN_SESSION_TIMEOUT => { IDLE_FOR => '30m', EVERY => '1d', CUSTOM => sub { my $authen = shift; return ($authen->username eq 'root' && (time() - $authen->last_access) > 300) ? 1 : 0; } } RENDER_LOGIN This value can be set to a subroutine reference that returns the HTML of a login form. The subroutine reference overrides the default call to login_box. The subroutine is normally a method in your CGI::Application application and as such the CGI::Application object is passed as the first parameter. RENDER_LOGIN => \&login_form and later in your code: sub login_form { my $self = shift; ... return $html } LOGIN_FORM You can set this option to customize the login form that is created when a user needs to be authenticated. If you wish to replace the entire login form with a completely custom version, then just set LOGIN_RUNMODE to point to your custom runmode. All of the parameters listed below are optional, and a reasonable default will be used if left blank: DISPLAY_CLASS (default: Classic) the class used to display the login form. The alternative is "Basic" which aims for XHTML compliance and leaving style to CSS. See CGI::Application::Plugin::Authentication::Display for more details. TITLE (default: Sign In) the heading at the top of the login box USERNAME_LABEL (default: User Name) the label for the user name input PASSWORD_LABEL (default: Password) the label for the password input SUBMIT_LABEL (default: Sign In) the label for the submit button COMMENT (default: Please enter your username and password in the fields below.) a message provided on the first login attempt REMEMBERUSER_OPTION (default: 1) provide a checkbox to offer to remember the users name in a cookie so that their user name will be pre-filled the next time they log in REMEMBERUSER_LABEL (default: Remember User Name) the label for the remember user name checkbox REMEMBERUSER_COOKIENAME (default: CAPAUTHTOKEN) the name of the cookie where the user name will be saved REGISTER_URL (default: ) the URL for the register new account link REGISTER_LABEL (default: Register Now!) the label for the register new account link FORGOTPASSWORD_URL (default: ) the URL for the forgot password link FORGOTPASSWORD_LABEL (default: Forgot Password?) the label for the forgot password link INVALIDPASSWORD_MESSAGE (default: Invalid username or password
(login attempt %d) a message given when a login failed INCLUDE_STYLESHEET (default: 1) use this to disable the built in style-sheet for the login box so you can provide your own custom styles FORM_SUBMIT_METHOD (default: post) use this to get the form to submit using 'get' instead of 'post' FOCUS_FORM_ONLOAD (default: 1) use this to automatically focus the login form when the page loads so a user can start typing right away. BASE_COLOUR (default: #445588) This is the base colour that will be used in the included login box. All other colours are automatically calculated based on this colour (unless you hardcode the colour values). In order to calculate other colours, you will need the Color::Calc module. If you do not have the Color::Calc module, then you will need to use fixed values for all of the colour options. All colour values besides the BASE_COLOUR can be simple percentage values (including the % sign). For example if you set the LIGHTER_COLOUR option to 80%, then the calculated colour will be 80% lighter than the BASE_COLOUR. LIGHT_COLOUR (default: 50% or #a2aac4) A colour that is lighter than the base colour. LIGHTER_COLOUR (default: 75% or #d0d5e1) A colour that is another step lighter than the light colour. DARK_COLOUR (default: 30% or #303c5f) A colour that is darker than the base colour. DARKER_COLOUR (default: 60% or #1b2236) A colour that is another step darker than the dark colour. GREY_COLOUR (default: #565656) A grey colour that is calculated by desaturating the base colour. protected_runmodes This method takes a list of runmodes that are to be protected by authentication. If a user tries to access one of these runmodes, then they will be redirected to a login page unless they are properly logged in. The runmode names can be a list of simple strings, regular expressions, or special directives that start with a colon. This method is cumulative, so if it is called multiple times, the new values are added to existing entries. It returns a list of all entries that have been saved so far. Calling this function, will not itself generate cookies or session ids. :all - All runmodes in this module will require authentication # match all runmodes __PACKAGE__->authen->protected_runmodes(':all'); # only protect runmodes one two and three __PACKAGE__->authen->protected_runmodes(qw(one two three)); # protect only runmodes that start with auth_ __PACKAGE__->authen->protected_runmodes(qr/^auth_/); # protect all runmodes that *do not* start with public_ __PACKAGE__->authen->protected_runmodes(qr/^(?!public_)/); is_protected_runmode This method accepts the name of a runmode, and will tell you if that runmode is a protected runmode (i.e. does a user need to be authenticated to access this runmode). Calling this function, will not itself generate cookies or session ids. redirect_after_login This method is be called during the prerun stage to redirect the user to the page that has been configured as the destination after a successful login. The location is determined as follows: POST_LOGIN_RUNMODE If the POST_LOGIN_RUNMODE config parameter is set, that run mode will be the chosen location. POST_LOGIN_URL If the above fails and the POST_LOGIN_URL config parameter is set, then there will be a 302 redirection to that location. destination If the above fails and there is a destination query parameter, which must a taint check against the DETAINT_URL_REGEXP config parameter, then there will be a 302 redirection to that location. original destination If all the above fail then there the originally requested page will be delivered. redirect_to_login This method is be called during the prerun stage if the current user is not logged in, and they are trying to access a protected runmode. It will redirect to the page that has been configured as the login page, based on the value of LOGIN_RUNMODE or LOGIN_URL If nothing is configured a simple login page will be automatically provided. redirect_to_logout This method is called during the prerun stage if the user has requested to be logged out. It will redirect to the page that has been configured as the logout page, based on the value of LOGOUT_RUNMODE or LOGOUT_URL If nothing is configured, the page will redirect to the website homepage. setup_runmodes This method is called during the prerun stage to register some custom runmodes that the Authentication plugin requires in order to function. Calling this function, will not itself generate cookies or session ids. last_login This will return return the time of the last login for this user my $last_login = $self->authen->last_login; This function will initiate a session or cookie if one has not been created already. last_access This will return return the time of the last access for this user my $last_access = $self->authen->last_access; This function will initiate a session or cookie if one has not been created already. is_login_timeout This will return true or false depending on whether the users login status just timed out $self->add_message('login session timed out') if $self->authen->is_login_timeout; This function will initiate a session or cookie if one has not been created already. is_authenticated This will return true or false depending on the login status of this user assert($self->authen->is_authenticated); # The user should be logged in if we got here This function will initiate a session or cookie if one has not been created already. login_attempts This method will return the number of failed login attempts have been made by this user since the last successful login. This is not a number that can be trusted, as it is dependent on the underlying store to be able to return the correct value for this user. For example, if the store uses a cookie based session, the user trying to login could delete their cookies, and hence get a new session which will not have any login attempts listed. The number will be cleared upon a successful login. This function will initiate a session or cookie if one has not been created already. username This will return the username of the currently logged in user, or undef if no user is currently logged in. my $username = $self->authen->username; This function will initiate a session or cookie if one has not been created already. is_new_login This will return true or false depending on if this is a fresh login $self->log->info("New Login") if $self->authen->is_new_login; This function will initiate a session or cookie if one has not been created already. credentials This method will return the names of the form parameters that will be looked for during a login. By default they are authen_username and authen_password, but these values can be changed by supplying the CREDENTIALS parameters in the configuration. Calling this function, will not itself generate cookies or session ids. logout This will attempt to logout the user. If during a request the Authentication module sees a parameter called 'authen_logout', it will automatically call this method to log out the user. $self->authen->logout(); This function will initiate a session or cookie if one has not been created already. drivers This method will return a list of driver objects that are used for verifying the login credentials. Calling this function, will not itself generate cookies or session ids. store This method will return a store object that is used to store information about the status of the authentication across multiple requests. This function will initiate a session or cookie if one has not been created already. initialize This does most of the heavy lifting for the Authentication plugin. It will check to see if the user is currently attempting to login by looking for the credential form fields in the query object. It will load the required driver objects and authenticate the user. It is OK to call this method multiple times as it checks to see if it has already been executed and will just return without doing anything if called multiple times. This allows us to call initialize as late as possible in the request so that no unnecessary work is done. The user will be logged out by calling the "logout()" method if the login session has been idle for too long, if it has been too long since the last login, or if the login has timed out. If you need to know if a user was logged out because of a time out, you can call the "is_login_timeout" method. If all goes well, a true value will be returned, although it is usually not necessary to check. This function will initiate a session or cookie if one has not been created already. display This method will return the CGI::Application::Plugin::Authentication::Display object, creating and caching it if necessary. login_box This method will return the HTML for a login box that can be embedded into another page. This is the same login box that is used in the default authen_login runmode that the plugin provides. This function will initiate a session or cookie if one has not been created already. new This method creates a new CGI::Application::Plugin::Authentication object. It requires as it's only parameter a CGI::Application object. This method should never be called directly, since the 'authen' method that is imported into the CGI::Application module will take care of creating the CGI::Application::Plugin::Authentication object when it is required. Calling this function, will not itself generate cookies or session ids. instance This method works the same way as 'new', except that it returns the same Authentication object for the duration of the request. This method should never be called directly, since the 'authen' method that is imported into the CGI::Application module will take care of creating the CGI::Application::Plugin::Authentication object when it is required. Calling this function, will not itself generate cookies or session ids. CGI::Application CALLBACKS prerun_callback This method is a CGI::Application prerun callback that will be automatically registered for you if you are using CGI::Application 4.0 or greater. If you are using an older version of CGI::Application you will have to create your own cgiapp_prerun method and make sure you call this method from there. sub cgiapp_prerun { my $self = shift; $self->CGI::Application::Plugin::Authentication::prerun_callback(); } CGI::Application RUNMODES authen_login_runmode This runmode is provided if you do not want to create your own login runmode. It will display a simple login form for the user, which can be replaced by assigning RENDER_LOGIN a coderef that returns the HTML. authen_dummy_redirect This runmode is provided for convenience when an external redirect needs to be done. It just returns an empty string. EXAMPLE In a CGI::Application module: use base qw(CGI::Application); use CGI::Application::Plugin::AutoRunmode; use CGI::Application::Plugin::Session; use CGI::Application::Plugin::Authentication; __PACKAGE__->authen->config( DRIVER => [ 'Generic', { user1 => '123' } ], STORE => 'Session', LOGOUT_RUNMODE => 'start', ); __PACKAGE__->authen->protected_runmodes(qr/^auth_/, 'one'); sub start : RunMode { my $self = shift; } sub one : RunMode { my $self = shift; # The user will only get here if they are logged in } sub auth_two : RunMode { my $self = shift; # This is also protected because of the # regexp call to protected_runmodes above } COMPATIBILITY WITH CGI::Application::Plugin::ActionDispatch The prerun callback has been modified so that it will check for the presence of a prerun mode. This is for compatibility with CGI::Application::Plugin::ActionDispatch. This change should be considered experimental. It is necessary to load the ActionDispatch module so that the two prerun callbacks will be called in the correct order. RECOMMENDED USAGE CSS The best practice nowadays is generally considered to be to not have CSS embedded in HTML. Thus it should be best to set LOGIN_FORM -> DISPLAY_CLASS to 'Basic'. Post login destination Of the various means of selecting a post login destination the most secure would seem to be POST_LOGIN_URL. The "destination" parameter could potentially be hijacked by hackers. The POST_LOGIN_RUNMODE parameter requires a hidden parameter that could potentially be hijacked. Taint mode Do run your code under taint mode. It should help protect your application against a number of attacks. URL and username checking Please set the "DETAINT_URL_REGEXP" and "DETAINT_USERNAME_REGEXP" parameters as tightly as possible. In particular you should prevent the destination parameter being used to redirect authenticated users to external sites; unless of course that is what you want in which case that site should be the only possible external site. The login form The HTML currently generated does not seem to be standards compliant as per RT bug 58023. Also the default login form includes hidden forms which could conceivably be hijacked. Set LOGIN_FORM -> DISPLAY_CLASS to 'Basic' to fix this. TODO There are lots of things that can still be done to improve this plugin. If anyone else is interested in helping out feel free to dig right in. Many of these things don't need my input, but if you want to avoid duplicated efforts, send me a note, and I'll let you know of anyone else is working in the same area. review the code for security bugs and report complete the separation of presentation and logic write a tutorial build more Drivers (Class::DBI, LDAP, Radius, etc...) Add support for method attributes to identify runmodes that require authentication finish the test suite provide more example code clean up the documentation build a DB driver that builds it's own table structure. This can be used by people that don't have their own user database to work with, and could include a simple user management application. BUGS This is alpha software and as such, the features and interface are subject to change. So please check the Changes file when upgrading. Some of the test scripts appear to be incompatible with versions of Devel::Cover later than 0.65. SEE ALSO CGI::Application, perl(1) AUTHOR Author: Cees Hek ; Co-maintainer: Nicholas Bamber . CREDITS Thanks to SiteSuite for funding the development of this plugin and for releasing it to the world. Thanks to Christian Walde for suggesting changes to fix the incompatibility with CGI::Application::Plugin::ActionDispatch and for help with github. Thanks to Alexandr Ciornii for pointing out some typos. LICENCE AND COPYRIGHT Copyright (c) 2005, SiteSuite. All rights reserved. Copyright (c) 2010, Nicholas Bamber. (Portions of the code). This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The background images in the default login forms are used courtesy of www.famfamfam.com . Those icons are issued under the Creative Commons Attribution 3.0 License . Those icons are copyrighted 2006 by Mark James DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. Changes100644001750001750 2440114546072342 20676 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24Revision history for CGI-Application-Plugin-Authentication 0.24 2024-01-05 15:30:08-06:00 America/Chicago Fix tests failing on CGI.pm >= 4.58 (Gregor Herrmann and Debian Perl) 0.23 2018-03-05 13:15:54-06:00 America/Chicago Support SQLite 3.22.0 in tests (thanks to Gregor Herrmann and Debian Perl) 0.22 2018-02-07 14:24:30-06:00 America/Chicago Fix failing tests on Win32 0.21 2017-03-15 22:54:23-05:00 America/Chicago Fix list-context calls to CGI::param(). Fix failing tests with newer CGI versions. 0.20 Fri 29 Apr 2011 Use Test::ConsistentVersion rather than Test::CheckVersion Fixed spelling errors and added descriptions - Closes #rt63839 Removed now unused login_styles method from core module Added more tests completing test coverage for the Cookie module. Changed from using the Digest::SHA1 module to usuing Digest::SHA instead - Closes #rt67840 0.19 Wed 24 Nov 2010 Incoporated developer changes. Made pod tests only run when TEST_AUTHOR=1. Automatically generate README. 0.18_2 Mon 20 Jul 2010 Separate out display code and provide Basic and Classic alternatives to the login form. Added more examples. Implementd typo fix reported by Alexandr Ciornii. Added copyright declaration for icons in the login form. 0.18_1 Thu Jun 25 2010 Put OS dependent guards in certain tests. Removed deprecated *_DESTINATION parameters. Added first test for devpopup and fixed undefined variable therein. Cannot use Test::More 0.92 as that has an issue with subtests. 0.18 Mon Jun 23 2010 Completed test coverage for Driver and below TABLES parameter was not made mandatory in DBI driver. Fixed dependency on Test::More - must be at least version 0.90. Fixed handling of custom filters - now they must have a $param and a $value. Incorporated Christian Walde's suggested changes for compatibility with CGI::Application::Plugin::ActionDispatch. Adding tests around the HTML generated by the login_box function and verifying that it is taint free. Upped requiredment on CGI to 3.16 as that seems to cause unusual behaviour in returning self referring urls and further upped requirement on CGI to 3.16 as 3.15 has an unusual interpretation of redirection headers. Fixed regular expressions in destination test to respect HTTP header CRLF conventions. 0.17 Thu Jan 21 19:16 GMT 2010 Bug Fixes rt53533 - During initialization deferred checking the users credentials to the last possible moment. This ensures that sessions are not created unless actually required. Also attempted to document which functions add session/cookie state. Build Fixes rt35030 - Upped the requirement on Apache::Htpasswd to 1.8 as this simplifies our dependency management. 0.16 Mon Jan 18 22:18 GMT 2010 Release dedicated to improving CPAN readiness - see RT:50670. Fixed spelling mistakes and added a test script that uses Test::Spelling. Fixed dependency on Test::Exception and added a test script that uses Test::Prereq::Build. Added test scripts to validate the MANIFEST file and Changes file. Removed files that are generated during './Build dist' from repository. 0.15 Tue Jan 12 15:42 GMT 2010 Redist to fix tar format issues RT:45155 & 23705 0.14 Sun Oct 18 02:48:10 EST 2009 Bug Fixes - Make sure the 'action' attribute of the login_box includes the path_info in the URL (resolves RT:38049 patch by Alex Becker) New Features - Add options for LIMIT and ORDER_BY to DBI driver (requested by tbone) - Add FORM_SUBMIT_METHOD option to the login box which allows you to change the form method to GET instead of the default POST. (resolves RT:34198 requested by jaldhar) - Add hooks for devpopup (resolves RT:35989 patch by Alexandr Ciornii) 0.13 Mon Mar 30 23:58:25 EST 2009 Build fixes - There are no code changes to this release, just fixes in the build and test systems to solve some outstanding test failures - unit tests now skip tests where optional modules are not installed (gtermars@cpan.org) - remove build dependency on Test::Exception, replacing it with hand-rolled equivalent methods. Newer Perls have been seen to fail our tests with "Bizarre copy of HASH in sassign..." when using Test::Exception. Cause of the issue may be far lower/internal than Test::Exception, but replacing these methods eliminates the issue for us. (gtermars@cpan.org) - cleanup prerequisites and build files (Alexandr Ciornii) 0.12 Bug Fixes - when issuing a redirect, remember to set header_type to 'redirect' (reported by Graham TerMarsch) Other updates - Fix inconsistency in doc example (reported by POLETTIX) 0.11 Wed Jul 26 11:16:12 EDT 2006 - suppress warning about missing Color::Calc unless the user is actually trying to use it (reported by Ron Savage) - explicitly load CGI.pm since some users may be using CGI::Simple (reported by Ron Savage) - Fixed bug in Cookie store where the expiry time of the cookie was ignored (patch by POLETTIX) 0.10 Thu May 18 22:59:56 EDT 2006 - Add support for Authen::Simple (all Authen::Simple modules can be used directly as Drivers) - Made the login page much more customizable: - change any of the text - customize the colours - provide one base colour and lighter and darker shades are automatically generated (requires Color::Calc) - offer to remember the users username in a cookie for the next time they login - add option for a 'forgotten password' URL - add option for a 'register new account' URL - add option to supress the stylesheet so you can provide your own 0.09 Thu Jan 26 20:56:29 EST 2006 API Changes - Added option to provide your own HTML for the login box through a callback (Shawn Sorichetti) - Added POST_LOGIN_RUNMODE callback (Shawn Sorichetti) 0.08 Wed Nov 23 20:20:24 EST 2005 API Changes - Removed ability to configure the DBI driver with a DSN and username/password. CGI::Application::Plugin::DBH should be used for that instead (Mark Stosberg) - DBI driver defaults to $self->dbh() if DBH not provided (Mark Stosberg) Bug Fixes - Made MIME::Base64, Digest::SHA1 and CGI::Cookie mandatory requirements and load them at compile time instead of runtime in the Cookie store. (fixes problem reported by Richard Jones) Other updates - Added Driver that can authenticate against htpasswd files - Fixed typo in examples/sample.cgi - Fixed typo in lc filter example (Mark Stosberg) - Updated docs for initialize(), and made it return true value (Mark Stosberg) 0.07 Sat Oct 29 17:08:48 EDT 2005 API Changes - Config parameters ending in _DESTINATION have been renamed to _URL for clarity. (Mark Stosberg) Bug Fixes - DBI Driver was incorrectly using DBH option when it should have used the DSN option (patch from Jim McQuillan) - Tests were failing if certain modules were not installed. (fixed by Shawn Sorichetti) Other updates - add negative regexp example for the 'protected_runmodes' method (suggested by Larry Leszczynski) 0.06 Fri Oct 14 14:05:52 EDT 2005 Bug Fixes - fix autorunmode test so it doesn't fail if the AutoRunmode plugin is not installed 0.05 Fri Oct 14 13:15:23 EDT 2005 New Stuff - add ability to timeout logins based on last successful login, or with a custom callback (as well as the original last access timeout) - add 'last_access' and 'last_login' methods - add 'is_login_timeout' to show when a login request is caused by an idle login session - added lots more tests Bug Fixes - login timeouts were not working properly - the Cookie Store was not honouring the EXPIRY option - using :all in protected_runmodes now works - fix test failure when Test::Warn not installed (fixed by Shawn Sorichetti) Experimental - subroutine attributes: you can specify that a runmode should be protected with a subroutine attribute. example: sub my_rm :Authen { ... } This conflicts with the AutoRunmode plugin right now 0.04 Thu Sep 22 21:06:54 EDT 2005 API Changes - renamed 'encoders' to 'filters' - This should only affect driver writers and not end users New Stuff - filters (formerly encoders) can now be chained (See docs) - filters can take a param (See docs) - added filters for uc, lc and trim - added a simple sample application - more docs (based on suggestions from Ron Savage) 0.03 Mon Sep 19 14:57:47 EDT 2005 API Changes - renamed the 'auth' method to 'authen' to make it easier to distinguish from the upcoming 'authz' plugin. There is also an alias to 'authentication' for those who like clarity over brevity. - For the DBI driver, changed credential identifiers from cred_1 to __CREDENTIAL_1__ New Drivers - Dummy Driver - accepts any credentials as valid New Stuff - Added little icons to the default login and password fields (only works in Mozilla based browsers) - if STORE config is not given, the plugin will detect if you are already using the Session plugin, and use the Session Store instead of the Cookie Store. - Added a lot of new documentation Bug Fixes - 'run_modes' method was incorrectly being used in the test suite (reported by Ron Savage) 0.02 Fri Sep 16 00:19:10 EDT 2005 New Drivers - DBI Driver New Stores - Cookie store (requires no server side storage) New Stuff - Added field encoding support for datastores that keep passwords in an encoded format, like Unix crypt, or MD5. - Added encoders for crypt, MD5 and SHA1 - Added some more methods to Driver.pm that can simplify the building of new Driver modules (find_option, encode, check_encoded, strip_field_names) - Added lots more tests to the test suite (Cees and Shawn Sorichetti) Bug Fixes - Fixed Generic Driver when using array of arrays method. - Options no longer get clobbered by the modules. (reported by Shawn Sorichetti) 0.01 Fri Sep 9 00:44:17 EDT 2005 - original version LICENSE100644001750001750 2151614546072342 20414 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24This software is Copyright (c) 2005 by SiteSuite. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) The Artistic License 2.0 Copyright (c) 2000-2006, The Perl Foundation. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble This license establishes the terms under which a given free software Package may be copied, modified, distributed, and/or redistributed. The intent is that the Copyright Holder maintains some artistic control over the development of that Package while still keeping the Package available as open source and free software. You are always permitted to make arrangements wholly outside of this license directly with the Copyright Holder of a given Package. If the terms of this license do not permit the full use that you propose to make of the Package, you should contact the Copyright Holder and seek a different licensing arrangement. Definitions "Copyright Holder" means the individual(s) or organization(s) named in the copyright notice for the entire Package. "Contributor" means any party that has contributed code or other material to the Package, in accordance with the Copyright Holder's procedures. "You" and "your" means any person who would like to copy, distribute, or modify the Package. "Package" means the collection of files distributed by the Copyright Holder, and derivatives of that collection and/or of those files. A given Package may consist of either the Standard Version, or a Modified Version. "Distribute" means providing a copy of the Package or making it accessible to anyone else, or in the case of a company or organization, to others outside of your company or organization. "Distributor Fee" means any fee that you charge for Distributing this Package or providing support for this Package to another party. It does not mean licensing fees. "Standard Version" refers to the Package if it has not been modified, or has been modified only in ways explicitly requested by the Copyright Holder. "Modified Version" means the Package, if it has been changed, and such changes were not explicitly requested by the Copyright Holder. "Original License" means this Artistic License as Distributed with the Standard Version of the Package, in its current version or as it may be modified by The Perl Foundation in the future. "Source" form means the source code, documentation source, and configuration files for the Package. "Compiled" form means the compiled bytecode, object code, binary, or any other form resulting from mechanical transformation or translation of the Source form. Permission for Use and Modification Without Distribution (1) You are permitted to use the Standard Version and create and use Modified Versions for any purpose without restriction, provided that you do not Distribute the Modified Version. Permissions for Redistribution of the Standard Version (2) You may Distribute verbatim copies of the Source form of the Standard Version of this Package in any medium without restriction, either gratis or for a Distributor Fee, provided that you duplicate all of the original copyright notices and associated disclaimers. At your discretion, such verbatim copies may or may not include a Compiled form of the Package. (3) You may apply any bug fixes, portability changes, and other modifications made available from the Copyright Holder. The resulting Package will still be considered the Standard Version, and as such will be subject to the Original License. Distribution of Modified Versions of the Package as Source (4) You may Distribute your Modified Version as Source (either gratis or for a Distributor Fee, and with or without a Compiled form of the Modified Version) provided that you clearly document how it differs from the Standard Version, including, but not limited to, documenting any non-standard features, executables, or modules, and provided that you do at least ONE of the following: (a) make the Modified Version available to the Copyright Holder of the Standard Version, under the Original License, so that the Copyright Holder may include your modifications in the Standard Version. (b) ensure that installation of your Modified Version does not prevent the user installing or running the Standard Version. In addition, the Modified Version must bear a name that is different from the name of the Standard Version. (c) allow anyone who receives a copy of the Modified Version to make the Source form of the Modified Version available to others under (i) the Original License or (ii) a license that permits the licensee to freely copy, modify and redistribute the Modified Version using the same licensing terms that apply to the copy that the licensee received, and requires that the Source form of the Modified Version, and of any works derived from it, be made freely available in that license fees are prohibited but Distributor Fees are allowed. Distribution of Compiled Forms of the Standard Version or Modified Versions without the Source (5) You may Distribute Compiled forms of the Standard Version without the Source, provided that you include complete instructions on how to get the Source of the Standard Version. Such instructions must be valid at the time of your distribution. If these instructions, at any time while you are carrying out such distribution, become invalid, you must provide new instructions on demand or cease further distribution. If you provide valid instructions or cease distribution within thirty days after you become aware that the instructions are invalid, then you do not forfeit any of your rights under this license. (6) You may Distribute a Modified Version in Compiled form without the Source, provided that you comply with Section 4 with respect to the Source of the Modified Version. Aggregating or Linking the Package (7) You may aggregate the Package (either the Standard Version or Modified Version) with other packages and Distribute the resulting aggregation provided that you do not charge a licensing fee for the Package. Distributor Fees are permitted, and licensing fees for other components in the aggregation are permitted. The terms of this license apply to the use and Distribution of the Standard or Modified Versions as included in the aggregation. (8) You are permitted to link Modified and Standard Versions with other works, to embed the Package in a larger work of your own, or to build stand-alone binary or bytecode versions of applications that include the Package, and Distribute the result without restriction, provided the result does not expose a direct interface to the Package. Items That are Not Considered Part of a Modified Version (9) Works (including, but not limited to, modules and scripts) that merely extend or make use of the Package, do not, by themselves, cause the Package to be a Modified Version. In addition, such works are not considered parts of the Package itself, and are not subject to the terms of this license. General Provisions (10) Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. (11) If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. (12) This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. (13) This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cpanfile100644001750001750 146414546072342 21073 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24requires 'perl' => '5.008'; requires 'Attribute::Handlers'; requires 'CGI' => '3.16'; requires 'CGI::Application' => 4; requires 'Class::ISA'; requires 'Digest::SHA'; requires 'MIME::Base64'; requires 'Scalar::Util'; requires 'UNIVERSAL::require'; recommends 'Apache::Htpasswd' => '1.8'; recommends 'CGI::Application::Plugin::Session'; recommends 'Color::Calc' => '0.12'; recommends 'Digest::MD5'; on 'test' => sub { requires 'Readonly'; requires 'Test::Exception'; requires 'Test::MockObject'; requires 'Test::More' => '1.302015'; requires 'Test::NoWarnings'; requires 'Test::Regression'; # login_box generates a lot of HTML to verify requires 'Test::Taint'; requires 'Test::Warn' => '0.11'; # older versions may have problems with fresh Sub::Uplevel requires 'Test::Without::Module'; }; dist.ini100644001750001750 100414546072342 21021 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24name = CGI-Application-Plugin-Authentication version = 0.24 author = Cees Hek author = Nicholas Bamber author = Wes Malone license = Artistic_2_0 copyright_holder = SiteSuite copyright_year = 2005 [NextRelease] [@Git] [GithubMeta] issues = 1 [@Filter] -bundle = @Basic -remove = Readme [MetaJSON] [PkgVersion] [Pod2Readme] [PodSyntaxTests] [Prereqs::FromCPANfile] [Test::ChangesHasContent] META.yml100644001750001750 266214546072342 20641 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24--- abstract: 'Authentication framework for CGI::Application' author: - 'Cees Hek ' - 'Nicholas Bamber ' - 'Wes Malone ' build_requires: Readonly: '0' Test::Exception: '0' Test::MockObject: '0' Test::More: '1.302015' Test::NoWarnings: '0' Test::Regression: '0' Test::Taint: '0' Test::Warn: '0.11' Test::Without::Module: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.031, CPAN::Meta::Converter version 2.150010' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: CGI-Application-Plugin-Authentication recommends: Apache::Htpasswd: '1.8' CGI::Application::Plugin::Session: '0' Color::Calc: '0.12' Digest::MD5: '0' requires: Attribute::Handlers: '0' CGI: '3.16' CGI::Application: '4' Class::ISA: '0' Digest::SHA: '0' MIME::Base64: '0' Scalar::Util: '0' UNIVERSAL::require: '0' perl: '5.008' resources: bugtracker: https://github.com/MicroTechnology-Services/cgi-application-plugin-authentication/issues homepage: https://github.com/MicroTechnology-Services/cgi-application-plugin-authentication repository: https://github.com/MicroTechnology-Services/cgi-application-plugin-authentication.git version: '0.24' x_generated_by_perl: v5.32.1 x_serialization_backend: 'YAML::Tiny version 1.74' x_spdx_expression: Artistic-2.0 MANIFEST100644001750001750 1067314546072342 20542 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.031. Changes LICENSE MANIFEST META.json META.yml Makefile.PL README _build/auto_features _build/build_params _build/cleanup _build/config_data _build/features _build/magicnum _build/notes _build/prereqs _build/runtime_params cpanfile dist.ini example/basic.cgi example/httpdocs/css/ieonly.css example/httpdocs/css/ieonly6.css example/httpdocs/css/template.css example/httpdocs/js/focus.js example/sample.cgi example/template.cgi example/templates/login.tmpl example/templates/one.tmpl example/templates/two.tmpl lib/CGI/Application/Plugin/Authentication.pm lib/CGI/Application/Plugin/Authentication/Display.pm lib/CGI/Application/Plugin/Authentication/Display/Basic.pm lib/CGI/Application/Plugin/Authentication/Display/Classic.pm lib/CGI/Application/Plugin/Authentication/Driver.pm lib/CGI/Application/Plugin/Authentication/Driver/Authen/Simple.pm lib/CGI/Application/Plugin/Authentication/Driver/DBI.pm lib/CGI/Application/Plugin/Authentication/Driver/Dummy.pm lib/CGI/Application/Plugin/Authentication/Driver/Filter/crypt.pm lib/CGI/Application/Plugin/Authentication/Driver/Filter/lc.pm lib/CGI/Application/Plugin/Authentication/Driver/Filter/md5.pm lib/CGI/Application/Plugin/Authentication/Driver/Filter/sha1.pm lib/CGI/Application/Plugin/Authentication/Driver/Filter/strip.pm lib/CGI/Application/Plugin/Authentication/Driver/Filter/uc.pm lib/CGI/Application/Plugin/Authentication/Driver/Generic.pm lib/CGI/Application/Plugin/Authentication/Driver/HTPasswd.pm lib/CGI/Application/Plugin/Authentication/Store.pm lib/CGI/Application/Plugin/Authentication/Store/Cookie.pm lib/CGI/Application/Plugin/Authentication/Store/Session.pm local/lib/perl5/Module/Build/API.pod local/lib/perl5/Module/Build/Authoring.pod local/lib/perl5/Module/Build/Base.pm local/lib/perl5/Module/Build/Bundling.pod local/lib/perl5/Module/Build/Compat.pm local/lib/perl5/Module/Build/Config.pm local/lib/perl5/Module/Build/ConfigData.pm local/lib/perl5/Module/Build/Cookbook.pm local/lib/perl5/Module/Build/Dumper.pm local/lib/perl5/Module/Build/Notes.pm local/lib/perl5/Module/Build/PPMMaker.pm local/lib/perl5/Module/Build/Platform/Default.pm local/lib/perl5/Module/Build/Platform/MacOS.pm local/lib/perl5/Module/Build/Platform/Unix.pm local/lib/perl5/Module/Build/Platform/VMS.pm local/lib/perl5/Module/Build/Platform/VOS.pm local/lib/perl5/Module/Build/Platform/Windows.pm local/lib/perl5/Module/Build/Platform/aix.pm local/lib/perl5/Module/Build/Platform/cygwin.pm local/lib/perl5/Module/Build/Platform/darwin.pm local/lib/perl5/Module/Build/Platform/os2.pm local/lib/perl5/Module/Build/PodParser.pm local/lib/perl5/Module/Build/Tiny.pm t/01_basic.t t/02_config.t t/03_authenticate.t t/03_destination.t t/03_login_box.t t/03_login_box_basic.t t/03_login_box_other.t t/03_missing_color.t t/04_attributes.t t/05_autorunmode.t t/06_timeout.t t/07_protected_runmodes.t t/40_encoder_crypt.t t/40_encoder_lc.t t/40_encoder_md5.t t/40_encoder_sha1.t t/40_encoder_strip.t t/40_encoder_uc.t t/50_driver_missing_modules.t t/50_driver_undefined.t t/51_driver_dummy.t t/52_driver_generic.t t/53_driver_dbi.t t/53_driver_dbi_bad.t t/53_driver_dbi_die.t t/53_driver_dbi_syntax.t t/54_driver_htpasswd.t t/55_driver_authensimple.t t/55_driver_authensimple_die.t t/55_driver_missing_authensimple.t t/60_parsimony.t t/60_store.t t/60_store_cookie.t t/60_store_session.t t/61_cookie_badargs.t t/61_store_cookie_noexpiry.t t/61_store_cookie_other.t t/70_action_dispatch.t t/80_devpopup.t t/98_pod.t t/99_pod_coverage.t t/Authen/Simple/Dummy.pm t/CGI/Application/Plugin/Authentication/Display/Null.pm t/CGI/Application/Plugin/Authentication/Driver/Die.pm t/CGI/Application/Plugin/Authentication/Driver/Silly.pm t/Store/Dummy.pm t/TestAppDriver.pm t/TestAppParsimony.pm t/TestAppStore.pm t/author-pod-syntax.t t/changes.t t/htpasswd t/htpasswd2 t/manifest.t t/out/basic_login_box t/out/basic_login_box_options t/out/cosmetic t/out/crlf t/out/default t/out/frontpage t/out/frontpage-dev t/out/generic_login t/out/green t/out/grey t/out/grey2 t/out/grey_extra t/out/grey_extra2 t/out/login t/out/login-dev t/out/loginurl t/out/logout t/out/missing_color t/out/names_of_colours t/out/names_of_colours_2 t/out/names_of_colours_3 t/out/other_permutations t/out/percentage t/out/red t/out/redirect t/out/redirection_failure t/out/redirection_failure_basic t/out/restricted t/out/runmode t/out/success t/out/success-dev t/out/username t/out/username-basic t/podspell.t t/prereq.t t/release-changes_has_content.t out000755001750001750 014546072342 20274 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tred100644001750001750 1327614546072342 21162 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/out
META.json100644001750001750 462514546072342 21012 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24{ "abstract" : "Authentication framework for CGI::Application", "author" : [ "Cees Hek ", "Nicholas Bamber ", "Wes Malone " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.031, CPAN::Meta::Converter version 2.150010", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "CGI-Application-Plugin-Authentication", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Test::Pod" : "1.41" } }, "runtime" : { "recommends" : { "Apache::Htpasswd" : "1.8", "CGI::Application::Plugin::Session" : "0", "Color::Calc" : "0.12", "Digest::MD5" : "0" }, "requires" : { "Attribute::Handlers" : "0", "CGI" : "3.16", "CGI::Application" : "4", "Class::ISA" : "0", "Digest::SHA" : "0", "MIME::Base64" : "0", "Scalar::Util" : "0", "UNIVERSAL::require" : "0", "perl" : "5.008" } }, "test" : { "requires" : { "Readonly" : "0", "Test::Exception" : "0", "Test::MockObject" : "0", "Test::More" : "1.302015", "Test::NoWarnings" : "0", "Test::Regression" : "0", "Test::Taint" : "0", "Test::Warn" : "0.11", "Test::Without::Module" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/MicroTechnology-Services/cgi-application-plugin-authentication/issues" }, "homepage" : "https://github.com/MicroTechnology-Services/cgi-application-plugin-authentication", "repository" : { "type" : "git", "url" : "https://github.com/MicroTechnology-Services/cgi-application-plugin-authentication.git", "web" : "https://github.com/MicroTechnology-Services/cgi-application-plugin-authentication" } }, "version" : "0.24", "x_generated_by_perl" : "v5.32.1", "x_serialization_backend" : "Cpanel::JSON::XS version 4.26", "x_spdx_expression" : "Artistic-2.0" } t000755001750001750 014546072342 17465 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24prereq.t100644001750001750 102414546072342 21305 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tuse strict; use warnings; use Test::More; if ( not $ENV{TEST_PREREQ} ) { my $msg = 'Author test. Set $ENV{TEST_PREREQ} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Prereq::Build; }; if ( $@) { my $msg = 'Test::Prereq required to criticise code'; plan( skip_all => $msg ); } Test::Prereq::Build::prereq_ok(undef, 'prereq', ['Params::Validate', 'Test::CheckChanges', 'Test::CheckManifest', 'Test::Spelling', 'Test::Prereq', 'Test::Prereq::Build', 'Color::Calc','Apache::Htpasswd']); htpasswd100644001750001750 17414546072342 21367 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tuser1:E56EEScnmcTO2 user2:Ux85jxU8F45gU user3:$apr1$igjJA...$XDyNFHnD879UQGZyMCng60 user4:{SHA}QL0AFWMIX8NRZTKeof9cXsvbvu8= 98_pod.t100644001750001750 41714546072342 21076 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tuse Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); grey100644001750001750 1361714546072342 21355 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
crlf100644001750001750 20014546072342 21255 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outSet-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Content-Type: text/html; charset=ISO-8859-1 TWOhtpasswd2100644001750001750 2414546072342 21423 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tuser5:gp7/wfxeqCqXw changes.t100644001750001750 61114546072342 21400 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tuse strict; use warnings; use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::ConsistentVersion; }; if ( $@ ) { my $msg = 'Test::ConsistentVersion required to check Changes'; plan( skip_all => $msg ); } Test::ConsistentVersion::check_consistent_versions(); login100644001750001750 1367214546072342 21520 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
grey2100644001750001750 1364414546072342 21437 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
green100644001750001750 1327614546072342 21510 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/out
Makefile.PL100644001750001750 367214546072342 21344 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.031. use strict; use warnings; use 5.008; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Authentication framework for CGI::Application", "AUTHOR" => "Cees Hek , Nicholas Bamber , Wes Malone ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "CGI-Application-Plugin-Authentication", "LICENSE" => "artistic_2", "MIN_PERL_VERSION" => "5.008", "NAME" => "CGI::Application::Plugin::Authentication", "PREREQ_PM" => { "Attribute::Handlers" => 0, "CGI" => "3.16", "CGI::Application" => 4, "Class::ISA" => 0, "Digest::SHA" => 0, "MIME::Base64" => 0, "Scalar::Util" => 0, "UNIVERSAL::require" => 0 }, "TEST_REQUIRES" => { "Readonly" => 0, "Test::Exception" => 0, "Test::MockObject" => 0, "Test::More" => "1.302015", "Test::NoWarnings" => 0, "Test::Regression" => 0, "Test::Taint" => 0, "Test::Warn" => "0.11", "Test::Without::Module" => 0 }, "VERSION" => "0.24", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Attribute::Handlers" => 0, "CGI" => "3.16", "CGI::Application" => 4, "Class::ISA" => 0, "Digest::SHA" => 0, "MIME::Base64" => 0, "Readonly" => 0, "Scalar::Util" => 0, "Test::Exception" => 0, "Test::MockObject" => 0, "Test::More" => "1.302015", "Test::NoWarnings" => 0, "Test::Regression" => 0, "Test::Taint" => 0, "Test::Warn" => "0.11", "Test::Without::Module" => 0, "UNIVERSAL::require" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); 01_basic.t100644001750001750 400614546072342 21373 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -T use Test::More tests => 9; use Test::Exception; use Scalar::Util; BEGIN { require_ok('CGI::Application::Plugin::Authentication') }; use lib './t'; use strict; use warnings; { package TestAppBasic; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; } { package TestAppBasicNOTCA; use Test::More; sub new { return bless {}, 'TestAppBasicNOTCA'; } SKIP: { eval "use Test::Warn"; skip "Test::Warn required for this test", 1 if $@; warning_like( sub { CGI::Application::Plugin::Authentication->import() }, qr/Calling package is not a CGI::Application module so not setting up the prerun hook/, "warning when the plugin is used in a non-CGIApp module"); }; { local $SIG{__WARN__} = sub {}; # supress all warnings for the next line CGI::Application::Plugin::Authentication->import(); }; Test::Exception::throws_ok( sub { TestAppBasicNOTCA->new->authen }, qr/CGI::Application::Plugin::Authentication->instance must be called with a CGI::Application object/, "instance dies when called passed non CGI::App module" ); } is(TestAppBasic->authen, "CGI::Application::Plugin::Authentication", "->authen called as a class method works"); my $t1_obj = TestAppBasic->new(); my $authen = $t1_obj->authen; my $authen_again = $t1_obj->authen; isa_ok($authen, 'CGI::Application::Plugin::Authentication'); my $t2_obj = TestAppBasic->new(); my $authen2 = $t2_obj->authen; isa_ok($authen2, 'CGI::Application::Plugin::Authentication'); ok(Scalar::Util::refaddr($authen) != Scalar::Util::refaddr($authen2), "Objects have same different address"); is(Scalar::Util::refaddr($authen), Scalar::Util::refaddr($authen_again), "Objects have same address"); throws_ok(sub { CGI::Application::Plugin::Authentication->instance }, qr/CGI::Application::Plugin::Authentication->instance must be called with a CGI::Application object/, "instance dies when called incorrectly"); 60_store.t100644001750001750 324014546072342 21452 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use strict; use warnings; use lib qw(t); use CGI::Util; use Test::More; use Test::Exception; plan tests => 17; our %STORAGE; { package TestAppStoreDummy; use base qw(TestAppStore); __PACKAGE__->authen->config( DRIVER => [ 'Generic', { 'test' => '123' } ], STORE => [ 'Store::Dummy', \%STORAGE ], CREDENTIALS => [qw(auth_username auth_password)], ); sub get_store_entries { return %STORAGE ? \%STORAGE : undef; } #-------------------------------------------------- # sub maintain_state { # my $class = shift; # my $old_cgiapp = shift; # my $old_results = shift; # my $new_query = shift; # } #-------------------------------------------------- sub clear_state { my $class = shift; my $old_cgiapp = shift; my $old_results = shift; delete $STORAGE{$_} foreach keys %STORAGE; } } TestAppStoreDummy->run_store_tests; # Test some methods that should never be called my $store = TestAppStoreDummy->new->authen->store; throws_ok { $store->CGI::Application::Plugin::Authentication::Store::fetch('username') } qr/fetch must be implemented in the/, 'Store dies when fetch is called without being overridden in the subclass'; throws_ok { $store->CGI::Application::Plugin::Authentication::Store::save(username => 'test1') } qr/save must be implemented in the/, 'Store dies when save is called without being overridden in the subclass'; throws_ok { $store->CGI::Application::Plugin::Authentication::Store::delete('username') } qr/delete must be implemented in the/, 'Store dies when delete is called without being overridden in the subclass'; podspell.t100644001750001750 531314546072342 21636 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tuse strict; use warnings; use English qw(-no_match_vars); use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::Spelling; }; if ( $EVAL_ERROR ) { my $msg = 'Test::Spelling required to criticise code'; plan( skip_all => $msg ); } Test::Spelling::add_stopwords(qw( ActionDispatch Walde CPAN Bamber Cees Hek github AnnoCPAN RT API SiteSuite crypted SHA CRC DBD DBH SQL DBI username usernames CALLBACKS CALLBACKS HTML LDAP RUNMODES TODO URL CAPAUTHTOKEN webserver Hardcode hardcode everytime initialize authen customizations runmode runmodes prerun pre callback callbacks checkbox customize customized desaturating Alexandr Ciornii www famfamfam com gmail XHTML detaint URLs)); Test::Spelling::all_pod_files_spelling_ok(); manifest.t100644001750001750 75714546072342 21611 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tuse strict; use warnings; use Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval { require Test::CheckManifest; }; if ( $@ ) { my $msg = 'Test::CheckManifest required to check manifest'; plan( skip_all => $msg ); } Test::CheckManifest::ok_manifest({filter=>[qr/\/cover_db/,qr/\/\.git/,qr/\/\.dotest/,qr/\.bak$/,qr/\.old$/,qr/t\/dbfile$/,qr/\.tar\.gz$/,qr/Makefile(?:\.PL)$/]}); logout100644001750001750 12614546072342 21647 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outStatus: 302 Found Set-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Location: / _build000755001750001750 014546072342 20460 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24notes100644001750001750 2514546072342 21630 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/_builddo{ my $x = {}; $x; }02_config.t100644001750001750 3065014546072342 21604 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -T use Test::More tests => 69; use Test::Warn; use Scalar::Util; use CGI; use strict; use warnings; use lib qw(t); ############################################################################### # FAKE our own versions of these methods; newer Perls fail when we use the # versions from Test::Exception, throwing "Bizarre copy of HASH in sassign...". sub lives_ok(&;$) { my ($coderef, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my $rc = eval { $coderef->() }; ok !$@, $name; } sub throws_ok(&$;$) { my ($coderef, $expecting, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my $rc = eval { $coderef->() }; like $@, $expecting, $name; } # END FAKE ############################################################################### { package TestAppConfig; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; } my %config = ( DRIVER => [ 'Generic', { user1 => '123', user2 => '123'} ], STORE => 'Store::Dummy', LOGIN_RUNMODE => 'login', LOGOUT_RUNMODE => 'logout', POST_LOGIN_RUNMODE => 'start', CREDENTIALS => ['authen_username', 'authen_password'], LOGIN_SESSION_TIMEOUT => '1h', ); my $cgiapp=TestAppConfig->new; lives_ok { $cgiapp->authen->config(%config) } 'All config parameters accepted'; is_deeply( $cgiapp->authen->credentials,[qw/authen_username authen_password/],'credentials set'); isa_ok($cgiapp->authen->drivers,'CGI::Application::Plugin::Authentication::Driver::Generic'); isa_ok($cgiapp->authen->store,'Store::Dummy'); %config = ( DRIVER => [ 'HTPassword', file => 't/htpasswd' ], STORE => 'Store::Dummy', LOGIN_URL => '/login.cgi', LOGOUT_URL => '/', POST_LOGIN_URL => '/protected/', CREDENTIALS => ['authen_username', 'authen_password'], LOGIN_SESSION_TIMEOUT => '1h', ); lives_ok { TestAppConfig->new->authen->config(%config) } 'All config parameters accepted'; # test DRIVER throws_ok { TestAppConfig->new->authen->config(DRIVER => { }) } qr/parameter DRIVER is not a string or arrayref/, 'config dies when DRIVER is passed a hashref'; lives_ok { TestAppConfig->new->authen->config(DRIVER => 'MODULE' ) } 'config accepts single DRIVER without options'; lives_ok { TestAppConfig->new->authen->config(DRIVER => [ 'MODULE', option => 'parameter' ] ) } 'config accepts single DRIVER with options'; lives_ok { TestAppConfig->new->authen->config(DRIVER => [ [ 'MODULE', option => 'parameter' ], [ 'MODULE', option => 'parameter' ] ] ) } 'config accepts multiple DRIVERs'; # test STORE throws_ok { TestAppConfig->new->authen->config(STORE => { }) } qr/parameter STORE is not a string or arrayref/, 'config dies when STORE is passed a hashref'; lives_ok { TestAppConfig->new->authen->config(STORE => 'MODULE' ) } 'config accepts STORE without options'; lives_ok { TestAppConfig->new->authen->config(STORE => [ 'MODULE', option => 'parameter' ] ) } 'config accepts STORE with options'; # test LOGIN_RUNMODE throws_ok { TestAppConfig->new->authen->config(LOGIN_RUNMODE => { }) } qr/parameter LOGIN_RUNMODE is not a string/, 'config dies when LOGIN_RUNMODE is passed a hashref'; lives_ok { TestAppConfig->new->authen->config(LOGIN_RUNMODE => 'runmode' ) } 'config accepts LOGIN_RUNMODE as a string'; # test LOGIN_URL throws_ok { TestAppConfig->new->authen->config(LOGIN_URL => { }) } qr/parameter LOGIN_URL is not a string/, 'config dies when LOGIN_URL is passed a hashref'; lives_ok { TestAppConfig->new->authen->config(LOGIN_URL => '/' ) } 'config accepts LOGIN_URL as a string'; warning_like { TestAppConfig->new->authen->config(LOGIN_URL => '/', LOGIN_RUNMODE => 'runmode' ) } qr/authen config warning: parameter LOGIN_URL ignored since we already have LOGIN_RUNMODE/, "LOGIN_URL ignored when LOGIN_RUNMODE is configured"; # test LOGOUT_RUNMODE throws_ok { TestAppConfig->new->authen->config(LOGOUT_RUNMODE => { }) } qr/parameter LOGOUT_RUNMODE is not a string/, 'config dies when LOGOUT_RUNMODE is passed a hashref'; lives_ok { TestAppConfig->new->authen->config(LOGOUT_RUNMODE => 'runmode' ) } 'config accepts LOGOUT_RUNMODE as a string'; # test LOGOUT_URL throws_ok { TestAppConfig->new->authen->config(LOGOUT_URL => { }) } qr/parameter LOGOUT_URL is not a string/, 'config dies when LOGOUT_URL is passed a hashref'; lives_ok { TestAppConfig->new->authen->config(LOGOUT_URL => '/' ) } 'config accepts LOGOUT_URL as a string'; warning_like { TestAppConfig->new->authen->config(LOGOUT_URL => '/', LOGOUT_RUNMODE => 'runmode' ) } qr/authen config warning: parameter LOGOUT_URL ignored since we already have LOGOUT_RUNMODE/, "LOGOUT_URL ignored when LOGOUT_RUNMODE is configured"; # test POST_LOGIN_RUNMODE throws_ok { TestAppConfig->new->authen->config(POST_LOGIN_RUNMODE => { }) } qr/parameter POST_LOGIN_RUNMODE is not a string/, 'config dies when POST_LOGIN_RUNMODE is passed a hashref'; lives_ok { TestAppConfig->new->authen->config(POST_LOGIN_RUNMODE => 'runmode' ) } 'config accepts POST_LOGIN_RUNMODE as a string'; # test POST_LOGIN_URL throws_ok { TestAppConfig->new->authen->config(POST_LOGIN_URL => { }) } qr/parameter POST_LOGIN_URL is not a string/, 'config dies when POST_LOGIN_URL is passed a hashref'; lives_ok { TestAppConfig->new->authen->config(POST_LOGIN_URL => '/' ) } 'config accepts POST_LOGIN_URL as a string'; warning_like { TestAppConfig->new->authen->config(POST_LOGIN_URL => '/', POST_LOGIN_RUNMODE => 'runmode' ) } qr/authen config warning: parameter POST_LOGIN_URL ignored since we already have POST_LOGIN_RUNMODE/, "POST_LOGIN_UR_URL ignored when POST_LOGIN_RUNMODE is configured"; # test POST_LOGIN_CALLBACK throws_ok { TestAppConfig->new->authen->config(POST_LOGIN_CALLBACK => { }) } qr/parameter POST_LOGIN_CALLBACK is not a coderef/, 'config dies when POST_LOGIN_CALLBACK is passed a hashref'; throws_ok { TestAppConfig->new->authen->config(POST_LOGIN_CALLBACK => ' ') } qr/parameter POST_LOGIN_CALLBACK is not a coderef/, 'config dies when POST_LOGIN_CALLBACK is passed a string'; lives_ok { TestAppConfig->new->authen->config(POST_LOGIN_CALLBACK => sub { } ) } 'config accepts POST_LOGIN_CALLBACK as a coderef'; # test RENDER_LOGIN throws_ok { TestAppConfig->new->authen->config(RENDER_LOGIN => { }) } qr/parameter RENDER_LOGIN is not a coderef/, 'config dies when RENDER_LOGIN is passed a hashref'; throws_ok { TestAppConfig->new->authen->config(RENDER_LOGIN => ' ') } qr/parameter RENDER_LOGIN is not a coderef/, 'config dies when RENDER_LOGIN is passed a string'; lives_ok { TestAppConfig->new->authen->config(RENDER_LOGIN => sub { } ) } 'config accepts RENDER_LOGIN as a coderef'; # test LOGIN_FORM throws_ok { TestAppConfig->new->authen->config(LOGIN_FORM => ' ') } qr/parameter LOGIN_FORM is not a hashref/, 'config dies when LOGIN_FORM is passed a string'; lives_ok { TestAppConfig->new->authen->config(LOGIN_FORM => { }) } 'config accepts LOGIN_FORM as a hashref'; # test CREDENTIALS throws_ok { TestAppConfig->new->authen->config(CREDENTIALS => { }) } qr/parameter CREDENTIALS is not a string/, 'config dies when CREDENTIALS is passed a hashref'; lives_ok { TestAppConfig->new->authen->config(CREDENTIALS => 'authen_username' ) } 'config accepts CREDENTIALS as a string'; lives_ok { TestAppConfig->new->authen->config(CREDENTIALS => ['authen_username', 'authen_password'] ) } 'config accepts CREDENTIALS as an arrayref'; # test LOGIN_SESSION_TIMEOUT lives_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => '5h' ) } 'config accepts LOGIN_SESSION_TIMEOUT as a string'; lives_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => { IDLE_FOR => 1 } ) } 'config accepts LOGIN_SESSION_TIMEOUT with IDLE_FOR option'; lives_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => { EVERY => 1 } ) } 'config accepts LOGIN_SESSION_TIMEOUT with EVERY option'; lives_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => { CUSTOM => sub { 1 } } ) } 'config accepts LOGIN_SESSION_TIMEOUT with CUSTOM option'; lives_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => { IDLE_FOR => 1, EVERY => 1, CUSTOM => sub { 1 } } ) } 'config accepts LOGIN_SESSION_TIMEOUT as a hashref'; throws_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => [ ]) } qr/parameter LOGIN_SESSION_TIMEOUT is not a string or a hashref/, 'config dies when LOGIN_SESSION_TIMEOUT is passed a hashref'; throws_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => '5dodgy' ) } qr/parameter LOGIN_SESSION_TIMEOUT is not a valid time string/, 'config dies when LOGIN_SESSION_TIMEOUT recieves an unparsable string'; throws_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => { IDLE_FOR => '5dodgy' } ) } qr/IDLE_FOR option to LOGIN_SESSION_TIMEOUT is not a valid time string/, 'config dies when LOGIN_SESSION_TIMEOUT IDLE_FOR recieves an unparsable string'; throws_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => { EVERY => '5dodgy' } ) } qr/EVERY option to LOGIN_SESSION_TIMEOUT is not a valid time string/, 'config dies when LOGIN_SESSION_TIMEOUT EVERY recieves an unparsable string'; throws_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => { CUSTOM => 'notasub' } ) } qr/CUSTOM option to LOGIN_SESSION_TIMEOUT must be a code reference/, 'config dies when LOGIN_SESSION_TIMEOUT CUSTOM receives something other than a coderef'; throws_ok { TestAppConfig->new->authen->config(LOGIN_SESSION_TIMEOUT => { BADOPTION => 1 } ) } qr/Invalid option\(s\) \(BADOPTION\) passed to LOGIN_SESSION_TIMEOUT/, 'config dies when LOGIN_SESSION_TIMEOUT recieves an unparsable string'; # authen->config as a class method lives_ok { TestAppConfig->authen->config(%config) } 'config can be called as a class method'; # authen->config as a class method with hashref lives_ok { TestAppConfig->authen->config(\%config) } 'config can be called with a hashref or hash'; # authen->config with no parameters lives_ok { TestAppConfig->authen->config() } 'current configuration returned'; # authen->config dies when passed an invalid parameter throws_ok { TestAppConfig->new->authen->config(BAD_PARAM => 'foobar' ) } qr/Invalid option\(s\)/, 'config dies when passed an invalid parameter'; # authen->config dies when it is called after the plugin has been initialized my $app = TestAppConfig->new; my $authen = $app->authen; $authen->config( \%config ); $authen->initialize; throws_ok { $authen->config( \%config ) } qr/Calling config after the Authentication object has already been initialized/, 'config dies when called after initialization with new configuration info'; # test _time_to_seconds is(CGI::Application::Plugin::Authentication::_time_to_seconds('10'), 10, "_time_to_seconds works with number only"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('10s'), 10, "_time_to_seconds works with seconds"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('10m'), 600, "_time_to_seconds works with minutes"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('10h'), 36000, "_time_to_seconds works with hours"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('10d'), 864000, "_time_to_seconds works with days"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('10w'), 6048000, "_time_to_seconds works with weeks"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('10M'), 25920000, "_time_to_seconds works with months"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('10y'), 315360000, "_time_to_seconds works with years"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('.5m'), 30, "_time_to_seconds works with decimal values"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('0.5m'), 30, "_time_to_seconds works with decimal values"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('1.5m'), 90, "_time_to_seconds works with decimal values"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('1.m'), 60, "_time_to_seconds works with decimal values"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('1.0m'), 60, "_time_to_seconds works with decimal values"); is(CGI::Application::Plugin::Authentication::_time_to_seconds((1 / 7).'m'), 8, "_time_to_seconds works with decimal value that wouldn't result in an integer offset"); is(CGI::Application::Plugin::Authentication::_time_to_seconds('.5'), undef, "_time_to_seconds fails with decimal values and no modifier"); TODO: { local $TODO = "TestAppConfig->new->authen->config not finished"; } default100644001750001750 1327614546072342 22034 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/out
runmode100644001750001750 20214546072342 22002 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outSet-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Content-Type: text/html; charset=ISO-8859-1 THREEsuccess100644001750001750 16214546072342 22006 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outSet-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Content-Type: text/html; charset=ISO-8859-1 This is private06_timeout.t100644001750001750 1034514546072342 22030 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More tests => 13; use strict; use warnings; use lib qw(t); use CGI (); our %STORE; { package TestAppTimeout; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; __PACKAGE__->authen->config( DRIVER => [ 'Generic', { user => '123' } ], STORE => [ 'Store::Dummy', \%STORE ], LOGIN_SESSION_TIMEOUT => { IDLE_FOR => '30', EVERY => '30', CUSTOM => sub { 0 }, }, ); sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes([qw(one two)]); $self->authen->protected_runmodes(qw(two)); } sub one { my $self = shift; } sub two { my $self = shift; } } $ENV{CGI_APP_RETURN_ONLY} = 1; my ($now, $query, $cgiapp, $results); diag('The following tests have some small time delays'); $query = CGI->new( { authen_username => 'user', authen_password => '123', rm => 'two' } ); $cgiapp = TestAppTimeout->new( QUERY => $query ); $results = $cgiapp->run; ok( $cgiapp->authen->is_authenticated,'successful login' ); is( $cgiapp->authen->username, 'user', 'username set' ); is( $STORE{username}, 'user', 'username set in store' ); $now = time(); ok( $STORE{last_access} <= $now && $STORE{last_access} >= $now - 5, 'last access looks reasonable' ); ok( $STORE{last_login} <= $now && $STORE{last_login} >= $now - 5, 'last login looks reasonable' ); # Sleep so we know if the last_access time is updated select(undef, undef, undef, 1.1); $query = CGI->new( { rm => 'two' } ); $cgiapp = TestAppTimeout->new( QUERY => $query ); $results = $cgiapp->run; ok( $STORE{last_access} > $STORE{last_login}, 'last access updated on next request' ); # If we log out, make sure it is not marked as caused by a timeout ok ($cgiapp->authen->logout, "Logout manually"); ok( !$cgiapp->authen->is_authenticated, 'user logged out' ); ok( !$cgiapp->authen->is_login_timeout, 'logout not caused by timeout' ); { package TestAppTimeoutIDLE_FOR; use base qw(TestAppTimeout); __PACKAGE__->authen->config( DRIVER => [ 'Generic', { user => '123' } ], STORE => [ 'Store::Dummy', \%STORE ], LOGIN_SESSION_TIMEOUT => { IDLE_FOR => '1', }, ); } # login again $query = CGI->new( { authen_username => 'user', authen_password => '123', rm => 'two' } ); $cgiapp = TestAppTimeout->new( QUERY => $query ); $results = $cgiapp->run; # Sleep so we have enough idle time select(undef, undef, undef, 1.1); $query = CGI->new( { rm => 'two' } ); $cgiapp = TestAppTimeoutIDLE_FOR->new( QUERY => $query ); $results = $cgiapp->run; ok( !$cgiapp->authen->is_authenticated, 'IDLE_FOR idle time exceeded so user logged out' ); ok( $cgiapp->authen->is_login_timeout, 'logout caused by timeout' ); { package TestAppTimeoutEVERY; use base qw(TestAppTimeout); __PACKAGE__->authen->config( DRIVER => [ 'Generic', { user => '123' } ], STORE => [ 'Store::Dummy', \%STORE ], LOGIN_SESSION_TIMEOUT => { EVERY => '1', }, ); } # login again $query = CGI->new( { authen_username => 'user', authen_password => '123', rm => 'two' } ); $cgiapp = TestAppTimeoutEVERY->new( QUERY => $query ); $results = $cgiapp->run; # Sleep so we have enough idle time select(undef, undef, undef, 1.1); $query = CGI->new( { rm => 'two' } ); $cgiapp = TestAppTimeoutEVERY->new( QUERY => $query ); $results = $cgiapp->run; ok( !$cgiapp->authen->is_authenticated, 'EVERY idle time exceeded so user logged out' ); { package TestAppTimeoutCUSTOM; use base qw(TestAppTimeout); __PACKAGE__->authen->config( DRIVER => [ 'Generic', { user => '123' } ], STORE => [ 'Store::Dummy', \%STORE ], LOGIN_SESSION_TIMEOUT => { CUSTOM => sub { 1 }, }, ); } # login again $query = CGI->new( { authen_username => 'user', authen_password => '123', rm => 'two' } ); $cgiapp = TestAppTimeoutCUSTOM->new( QUERY => $query ); $results = $cgiapp->run; # no need to sleep here $query = CGI->new( { rm => 'two' } ); $cgiapp = TestAppTimeoutCUSTOM->new( QUERY => $query ); $results = $cgiapp->run; ok( !$cgiapp->authen->is_authenticated, 'CUSTOM idle time exceeded so user logged out' ); username100644001750001750 1375214546072342 22226 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outSet-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Content-Type: text/html; charset=ISO-8859-1 Sign In
cosmetic100644001750001750 246714546072342 22176 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/out
loginurl100644001750001750 15014546072342 22166 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outStatus: 302 Found Set-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Location: http://www.perl.org redirect100644001750001750 15214546072342 22136 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outStatus: 302 Found Set-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Location: http://news.bbc.co.uk cleanup100644001750001750 5614546072342 22133 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/_builddo{ my $x = { 'blib' => 1 }; $x; }prereqs100644001750001750 246314546072342 22231 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/_builddo{ my $x = { 'recommends' => { 'CGI::Application::Plugin::Session' => 0, 'Digest::MD5' => 0, 'Apache::Htpasswd' => '1.8', 'Color::Calc' => '0.12' }, 'conflicts' => {}, 'test_requires' => {}, 'requires' => { 'Class::ISA' => 0, 'Attribute::Handlers' => 0, 'CGI' => '3.16', 'Scalar::Util' => 0, 'perl' => '5.006', 'CGI::Application' => 4, 'Digest::SHA' => 0, 'UNIVERSAL::require' => 0, 'MIME::Base64' => 0 }, 'build_requires' => { 'Test::Taint' => 0, 'Test::MockObject' => 0, 'Readonly' => 0, 'Test::Regression' => 0, 'Test::More' => '0.93', 'Test::NoWarnings' => 0, 'Test::Without::Module' => 0, 'Test::Warn' => '0.11', 'Test::Exception' => 0 } }; $x; }80_devpopup.t100644001750001750 665214546072342 22174 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -wT use Test::More; use Test::Taint; use Test::Regression; use English qw(-no_match_vars); use lib qw(t); BEGIN { $ENV{CGI_APP_RETURN_ONLY} = 1; $ENV{CAP_DEVPOPUP_EXEC} = 1; use Test::More; eval {require CGI::Application::Plugin::DevPopup}; if ($@) { my $msg = 'CGI::Application::Plugin::DevPopup required'; plan skip_all => $msg; } if ($OSNAME eq 'MSWin32') { my $msg = 'Not running these tests on windows yet'; plan skip_all => $msg; } if ($CGI::Application::Plugin::DevPopup::VERSION < 1.05) { my $msg = 'There are some odd test failures that MAY be due to old versions of DevPopup'; plan skip_all => $msg; } plan tests => 4; } use strict; use warnings; use CGI (); taint_checking_ok('taint checking is on'); my $cap_options = { DRIVER => [ 'Generic', { user1 => '123' } ], STORE => ['Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y'], POST_LOGIN_RUNMODE=>'protected', }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::DevPopup; use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->authen->protected_runmodes(qw(protected)); $self->authen->config($cap_options); $self->run_modes( protected=>'protected', unprotected=>'unprotected', ); $self->start_mode('unprotected'); } sub unprotected { return "This is public"; } sub protected { return "This is private"; } } # front page subtest 'front page' => sub { plan tests => 2; my $query = CGI->new(); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/frontpage-dev", "frontpage"); ok(!$cgiapp->authen->is_authenticated,'not authenticated'); }; # login intercepted subtest 'interception' => sub { plan tests => 2; local $ENV{PATH_INFO} = '/private'; my $query = CGI->new(); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/login-dev", "login"); ok(!$cgiapp->authen->is_authenticated,'not authenticated'); }; # successful login subtest 'successful login' => sub { plan tests => 4; local $ENV{PATH_INFO} = '/private'; my $query = CGI->new( { authen_username => 'user1', authen_password=>'123'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/success-dev", "success"); ok($cgiapp->authen->is_authenticated,'login success'); is( $cgiapp->authen->username, 'user1', "login success - username set" ); is( $cgiapp->authen->login_attempts, 0, "successful login - failed login count" ); }; sub make_output_timeless { my $output = shift; $output =~ s/^(Set-Cookie: CAPAUTH_DATA=\w+\%3D\%3D\; path=\/\; expires=\w{3},\s\d{2}(?:\-|\s)\w{3}(?:\-|\s)\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Set-Cookie: CAPAUTH_DATA=; path=\/; expires=;$2/m; $output =~ s/^(Expires:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Expires$2/m; $output =~ s/^(Date:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Date$2/m; #$output =~ s/\r//g; return $output; } frontpage100644001750001750 7514546072342 22306 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 This is publiclogin-dev100644001750001750 743214546072342 22251 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 This is public features100644001750001750 2514546072342 22316 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/_builddo{ my $x = {}; $x; }magicnum100644001750001750 614546072342 22257 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/_build17879503_login_box.t100644001750001750 1022014546072342 22307 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -T use Test::More; use Test::Taint; use Test::Regression; use English qw(-no_match_vars); if ($OSNAME eq 'MSWin32') { my $msg = 'Not running these tests on windows yet'; plan skip_all => $msg; exit(0); } plan tests => 7; use strict; use warnings; use CGI (); taint_checking_ok('taint checking is on'); $ENV{CGI_APP_RETURN_ONLY} = 1; my $cap_options = { DRIVER => [ 'Generic', { user1 => '123' } ], STORE => ['Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y'], POST_LOGIN_CALLBACK => \&TestAppAuthenticate::post_login, }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes([qw(one two)]); $self->authen->protected_runmodes(qw(two)); $self->authen->config($cap_options); } sub one { my $self = shift; } sub two { my $self = shift; } sub post_login { my $self = shift; my $count=$self->param('post_login')||0; $self->param('post_login' => $count + 1 ); } } test_auth(); test_auth('cosmetic', { TITLE=>'Aanmelden', USERNAME_LABEL=>'Gebruikersnaam', PASSWORD_LABEL=>'Wachtwoord', SUBMIT_LABEL=>'Aanmelden', COMMENT=>'Vul uw gebruikersnaam en wachtwoord in de velden hieronder.', REMEMBERUSER_LABEL=>'Onthouden Gebruikersnaam', INVALIDPASSWORD_MESSAGE=>'Ongeldige gebruikersnaam of wachtwoord
(login poging% d)', INCLUDE_STYLESHEET=>0 }); test_auth('red', { BASE_COLOUR=>'#884454', LIGHT_COLOUR=>'49%', LIGHTER_COLOUR=>'74%', DARK_COLOUR=>'29%', DARKER_COLOUR=>'59%' }, 1); test_auth('green', { BASE_COLOUR=>'#2cf816' }, 1); test_auth('grey_extra', { BASE_COLOUR=>'#445588', }, 1); test_auth('grey_extra2', { GREY_COLOUR=>'#334488', BASE_COLOUR=>'#445588', }, 1); sub test_auth { my $test_name = shift || "default"; my $login_form = shift; my $color_calc_required = shift; if (defined $color_calc_required) { eval "use Color::Calc"; if ($@) { diag "Color::Calc required for this sub test"; pass($test_name); return; } } subtest $test_name => sub { plan tests => 11; local $cap_options->{LOGIN_FORM} = $login_form if $login_form; # Missing Credentials my $param = { authen_username => 'user1', rm => 'two' }; taint_deeply($param); my $query = CGI->new( $param); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); my $results = $cgiapp->run; ok(!$cgiapp->authen->is_authenticated,"$test_name - login failure"); is( $cgiapp->authen->username, undef, "$test_name - username not set" ); is( $cgiapp->param('post_login'),1,"$test_name - POST_LOGIN_CALLBACK executed" ); is( $cgiapp->authen->_detaint_destination, '', "$test_name - _detaint_destination"); untainted_ok($cgiapp->authen->_detaint_destination, "$test_name - _detaint_destination untainted"); # hash order is random ok($cgiapp->authen->_detaint_selfurl eq 'http://localhost?authen_username=user1;rm=two' || $cgiapp->authen->_detaint_selfurl eq 'http://localhost?rm=two;authen_username=user1', "$test_name - _detaint_selfurl"); untainted_ok($cgiapp->authen->_detaint_selfurl, "$test_name - _detaint_selfurl untainted"); is( $cgiapp->authen->_detaint_url, '', "$test_name - _detaint_url"); untainted_ok($cgiapp->authen->_detaint_url, "$test_name - _detaint_url untainted"); TODO: { local $TODO = 'Checking output against past runs is incompatible with random hash order. URLs with params are generated from the keys of a hash and thus each run can have some minor differences in URLs.'; ok_regression(sub {$cgiapp->authen->login_box}, "t/out/$test_name", "$test_name - verify login box"); } untainted_ok($cgiapp->authen->login_box, "$test_name - check login box taint"); } } 60_parsimony.t100644001750001750 464514546072342 22351 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use strict; use warnings; use lib qw(t); # Test script to test the following scenario: # Once upon a time there was a perfectly good CGI::Application website with no need for authentication, sessions or cookies. # Then one day the wicked step-boss came in and said "We need to have a login screen, or else I'll # have to send you out into the big forest to fend for yourselves. Oh and if you change so much as a single # header on the existing web pages, I'll grind your bones for the shareholders' bread." # Well what is a poor programmer to do? She can use CGI::Application::Plugin::Authentication # but the unprotected pages never needed sessions or cookies so that must still be the case. # However as long as this test passes, they all live happily ever after. use Test::More; eval "use TestAppParsimony"; plan skip_all => "CGI::Application::Plugin::Session etc required for this test" if $@; plan tests => 6; $ENV{CGI_APP_RETURN_ONLY} = 1; sub response_like { my ($app, $header_re, $body_re, $comment) = @_; my $output = $app->run; my ($header, $body) = split /\r\n\r\n/m, $output; $header =~ s/\r\n/|/g; like($header, $header_re, "$comment (header match)"); is($body, $body_re, "$comment (body match)"); } { my $app = TestAppParsimony->new(); $app->query(CGI->new({'rm' => 'unprotected'})); response_like( $app, qr{^Content-Type: text/html; charset=ISO-8859-1$}, 'This is public.', 'TestAppParsimony, unprotected' ); } { my $app = TestAppParsimony->new(); $app->query(CGI->new({'rm' => 'protected',auth_username=>'test', auth_password=>'123'})); response_like( $app, qr{^Set-Cookie: CGISESSID=\w{1,100}; path=/|Date: \w{3}, \d{1,2} \w{3} \d{4} \d{2}:\d{2}:\d{2} \d{3}|Content-Type: text/html; charset=ISO-8859-1$}, 'This is private.', 'TestAppParsimony, protected' ); } { my $app = TestAppParsimony->new(); $app->query(CGI->new({'rm' => 'unprotected'})); response_like( $app, qr{^Content-Type: text/html; charset=ISO-8859-1$}, 'This is public.', 'TestAppParsimony, unprotected reprise' ); } percentage100644001750001750 1366114546072342 22523 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
restricted100644001750001750 20014546072342 22477 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outSet-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Content-Type: text/html; charset=ISO-8859-1 TWOgrey_extra100644001750001750 1327614546072342 22561 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/out
Store000755001750001750 014546072342 20561 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tDummy.pm100644001750001750 111514546072342 22350 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/Storepackage Store::Dummy; use strict; use warnings; use base qw(CGI::Application::Plugin::Authentication::Store); sub initialize { my $self = shift; my ($storage) = $self->options; $self->{__DUMMY} = $storage || {}; } sub fetch { my $self = shift; return (map { $self->{__DUMMY}->{$_}||undef } @_)[0..$#_]; } sub save { my $self = shift; my %data = @_; foreach my $key (keys %data) { $self->{__DUMMY}->{$key} = $data{$key}; } return 1; } sub delete { my $self = shift; delete $self->{__DUMMY}->{$_} foreach @_; return 1; } 1; example000755001750001750 014546072342 20655 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24basic.cgi100755001750001750 302014546072342 22560 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example#!/usr/bin/perl # # Sample application [Using Basic display] # # Just place this file in a CGI enabled part of your website, and # load it up in your browser. The only valid username/password # combination is 'test' and '123'. # use strict; use warnings; { package SampleLogin; use base qw(CGI::Application); use CGI::Application::Plugin::Session; use CGI::Application::Plugin::Authentication; use CGI::Application::Plugin::AutoRunmode; use CGI::Carp qw(fatalsToBrowser); my %config = ( DRIVER => [ 'Generic', { test => '123' } ], STORE => 'Cookie', LOGOUT_RUNMODE => 'one', LOGIN_FORM=>{ DISPLAY_CLASS=>'Basic', }, ); SampleLogin->authen->config(%config); SampleLogin->authen->protected_runmodes('two'); sub setup { my $self = shift; $self->start_mode('one'); } sub one : Runmode { my $self = shift; return CGI::start_html() . CGI::h2('This page is NOT protected') . CGI::a( { -href => '?rm=two' }, 'Protected Runmode' ) . CGI::end_html(); } sub two : Runmode { my $self = shift; return CGI::start_html() . CGI::h2('This page is protected') . CGI::h2( 'username: ' . $self->authen->username ) . CGI::a( { -href => '?rm=one' }, 'Un-Protected Runmode' ) . CGI::br() . CGI::a( { -href => '?authen_logout=1' }, 'Logout' ) . CGI::end_html(); } } SampleLogin->new->run; 53_driver_dbi.t100644001750001750 2313514546072342 22456 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use lib qw(t); eval "use DBD::SQLite"; plan skip_all => "DBD::SQLite required for this test" if $@; plan tests => 90; use strict; use warnings; our $DBNAME = 't/sqlite.db'; unlink $DBNAME if -e $DBNAME; my $dbh = DBI->connect( "dbi:SQLite:dbname=$DBNAME", "", "" ); $dbh->do(<<""); CREATE TABLE user ( name VARCHAR(20), password VARCHAR(50) ) $dbh->do(<<""); INSERT INTO user VALUES ('user1', '123'); $dbh->do(<<""); INSERT INTO user VALUES ('user2', 'mQPVY1HNg8SJ2'); # crypt("123", "mQ") { package TestAppDriverDBISimple; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ [ 'DBI', DBH => $dbh, TABLE => 'user', CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__', 'user.password' => '__CREDENTIAL_2__' }, ], [ 'DBI', DBH => $dbh, TABLES => 'user', COLUMNS => { 'crypt:user.password' => '__CREDENTIAL_2__' }, CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__' }, ], ], STORE => 'Store::Dummy', ); } TestAppDriverDBISimple->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], [ 'user2', '123' ], ); $dbh->do(<<""); DROP TABLE user; # # MULTIPLE TABLES # $dbh->do(<<""); CREATE TABLE domain ( id INTEGER, name VARCHAR(20) ); $dbh->do(<<""); CREATE TABLE user ( id INTEGER, domainid INTEGER, name VARCHAR(20), password VARCHAR(50) ) $dbh->do(<<""); INSERT INTO domain VALUES (1, 'domain1'); $dbh->do(<<""); INSERT INTO domain VALUES (2, 'domain2'); $dbh->do(<<""); INSERT INTO user VALUES (1, 1, 'user1', '123'); $dbh->do(<<""); INSERT INTO user VALUES (2, 2, 'user1', '234'); $dbh->do(<<""); INSERT INTO user VALUES (3, 1, 'user2', '345'); $dbh->do(<<""); INSERT INTO user VALUES (4, 1, 'user3', 'mQPVY1HNg8SJ2'); # crypt("123", "mQ") { package TestAppDriverDBIMultiTable; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ [ 'DBI', DBH => $dbh, TABLES => [ 'user', 'domain' ], JOIN_ON => 'user.domainid = domain.id', CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__', 'user.password' => '__CREDENTIAL_2__', 'domain.name' => '__CREDENTIAL_3__' } ], [ 'DBI', DBH => $dbh, TABLES => [ 'user', 'domain' ], JOIN_ON => 'user.domainid = domain.id', COLUMNS => { 'user.password' => '__CREDENTIAL_3__', 'domain.name' => '__CREDENTIAL_2__' }, CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__' } ], ], STORE => 'Store::Dummy', CREDENTIALS => [qw(username password domain)], ); } TestAppDriverDBIMultiTable->run_authen_tests( [ 'username', 'password', 'domain' ], [ 'user1', '123', 'domain1' ], [ 'user1', '234', 'domain2' ], [ 'user1', 'domain1', '123' ], [ 'user1', 'domain2', '234' ], ); $dbh->do(<<""); DROP TABLE domain; $dbh->do(<<""); DROP TABLE user; # # ENCODED FIELDS # $dbh->do(<<""); CREATE TABLE user ( name VARCHAR(20), password VARCHAR(50) ) $dbh->do(<<""); INSERT INTO user VALUES ('user1', 'mQPVY1HNg8SJ2'); # crypt("123", "mQ") $dbh->do(<<""); INSERT INTO user VALUES ('user2', '202cb962ac59075b964b07152d234b70'); # md5_hex("123") { package TestAppDriverDBIEncode; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ [ 'DBI', DBH => $dbh, TABLE => 'user', COLUMNS => { 'crypt:password' => '__CREDENTIAL_2__' }, CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__' } ], [ 'DBI', DBH => $dbh, TABLE => 'user', CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__', 'MD5:password' => '__CREDENTIAL_2__' } ], ], STORE => 'Store::Dummy', CREDENTIALS => [qw(username password)], ); } TestAppDriverDBIEncode->run_authen_tests( [ 'username', 'password' ], [ 'user1', '123' ], [ 'user2', '123' ], ); $dbh->do(<<""); DROP TABLE user; # # ENCODED FIELDS # $dbh->do(<<""); CREATE TABLE user ( name VARCHAR(20), password VARCHAR(50), active INTEGER ) $dbh->do(<<""); INSERT INTO user VALUES ('user1', '123', 1); $dbh->do(<<""); INSERT INTO user VALUES ('user2', '123', 0); { package TestAppDriverDBIEncode; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ 'DBI', DBH => $dbh, TABLE => 'user', CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__', 'user.password' => '__CREDENTIAL_2__', 'active' => '1' }, ], STORE => 'Store::Dummy', CREDENTIALS => [qw(username password)], ); } TestAppDriverDBIEncode->run_authen_tests( [ 'username', 'password' ], [ 'user1', '123' ], ); TestAppDriverDBIEncode->run_authen_failure_tests( [ 'username', 'password' ], [ 'user2', '123' ], ); $dbh->do(<<""); DROP TABLE user; # # ORDER BY # $dbh->do(<<""); CREATE TABLE user ( id INTEGER, name VARCHAR(20), password VARCHAR(50), created TIMESTAMP ) $dbh->do(<<""); INSERT INTO user VALUES (1, 'user1', '123', '2009-01-01'); $dbh->do(<<""); INSERT INTO user VALUES (2, 'user2', '123', '2009-01-01'); $dbh->do(<<""); INSERT INTO user VALUES (3, 'user1', '321', '2009-01-02'); $dbh->do(<<""); INSERT INTO user VALUES (4, 'user2', '321', '2009-01-02'); { package TestAppDriverDBIEncode; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ 'DBI', DBH => $dbh, TABLE => 'user', COLUMNS => { 'user.password' => '__CREDENTIAL_2__' }, CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__', }, ORDER_BY => 'created DESC', LIMIT => 1, ], STORE => 'Store::Dummy', CREDENTIALS => [qw(username password)], ); } TestAppDriverDBIEncode->run_authen_tests( [ 'username', 'password' ], [ 'user1', '321' ], [ 'user2', '321' ], ); TestAppDriverDBIEncode->run_authen_failure_tests( [ 'username', 'password' ], [ 'user1', '123' ], [ 'user2', '123' ], ); $dbh->do(<<""); DROP TABLE user; # # ALL TOGETHER # $dbh->do(<<""); CREATE TABLE user ( id INTEGER, name VARCHAR(20), password VARCHAR(50) ) $dbh->do(<<""); CREATE TABLE dailycode ( id INTEGER, userid INTEGER, date DATE DEFAULT 'CURRENT_DATE', code VARCHAR(20) ); $dbh->do(<<""); INSERT INTO user VALUES (1, 'user1', 'mQPVY1HNg8SJ2'); # crypt("123", "mQ") $dbh->do(<<""); INSERT INTO user VALUES (2, 'user2', 'mQPVY1HNg8SJ2'); # crypt("123", "mQ") $dbh->do(<<""); INSERT INTO dailycode VALUES (1, 1, 'CURRENT_DATE', '202CB962AC59075B964B07152D234B70'); # uc(md5_hex("123")) $dbh->do(<<""); INSERT INTO dailycode VALUES (2, 2, '2000-01-01', '202CB962AC59075B964B07152D234B70'); # uc(md5_hex("123")) { package TestAppDriverDBIEncode; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ 'DBI', DBH => $dbh, TABLES => ['user U', 'dailycode D'], JOIN_ON => 'U.id = D.userid', COLUMNS => { 'crypt:U.password' => '__CREDENTIAL_2__' }, CONSTRAINTS => { 'U.name' => '__CREDENTIAL_1__', 'uc:MD5_hex:D.code' => '__CREDENTIAL_3__', 'D.date' => 'CURRENT_DATE' }, ], STORE => 'Store::Dummy', CREDENTIALS => [qw(username password dailycode)], ); } TestAppDriverDBIEncode->run_authen_tests( [ 'username', 'password', 'dailycode' ], [ 'user1', '123', '123' ], ); TestAppDriverDBIEncode->run_authen_failure_tests( [ 'username', 'password', 'dailycode' ], [ 'user1', '123', 'xxx' ], [ 'user1', 'xxx', '123' ], [ 'user2', '123', '123' ], ); $dbh->do(<<""); DROP TABLE user; $dbh->do(<<""); DROP TABLE dailycode; $dbh->do(<<""); CREATE TABLE user ( name VARCHAR(20), password VARCHAR(50) ) $dbh->do(<<""); INSERT INTO user VALUES ('user1', '123'); SKIP: { eval "use DBI;"; skip "DBI not available", 6 if $@; { package TestAppDriverDBIDBH; use base qw(TestAppDriver); use Test::More; eval "use CGI::Application::Plugin::DBH (qw/dbh dbh_config/);"; skip "CGI::Application::Plugin::DBH not available", 6 if $@; sub cgiapp_init { my $self = shift; $self->dbh_config($dbh); $self->authen->config( DRIVER => [ 'DBI', TABLE => 'user', CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__', 'user.password' => '__CREDENTIAL_2__' }, ], STORE => 'Store::Dummy', CREDENTIALS => [qw(authen_username authen_password)], ); } } TestAppDriverDBIDBH->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], ); } $dbh->do(<<""); DROP TABLE user; undef $dbh; unlink $DBNAME if -e $DBNAME; 40_encoder_lc.t100644001750001750 61314546072342 22372 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More tests => 4; BEGIN { use_ok('CGI::Application::Plugin::Authentication::Driver::Filter::lc') }; use strict; use warnings; my $class = 'CGI::Application::Plugin::Authentication::Driver::Filter::lc'; is($class->filter(undef, 'ABC'), 'abc', "filter"); ok($class->check(undef, 'ABC', 'abc'), "check passes"); ok(!$class->check(undef, 'XXX', 'abc'), "check fails"); 40_encoder_uc.t100644001750001750 61314546072342 22403 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More tests => 4; BEGIN { use_ok('CGI::Application::Plugin::Authentication::Driver::Filter::uc') }; use strict; use warnings; my $class = 'CGI::Application::Plugin::Authentication::Driver::Filter::uc'; is($class->filter(undef, 'abc'), 'ABC', "filter"); ok($class->check(undef, 'abc', 'ABC'), "check passes"); ok(!$class->check(undef, 'xxx', 'ABC'), "check fails"); 04_attributes.t100644001750001750 437314546072342 22512 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More tests => 7; use lib './t'; use strict; use warnings; use CGI (); { package TestAppAttributes; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; __PACKAGE__->authen->config( DRIVER => [ 'Generic', { user1 => '123' } ], STORE => 'Store::Dummy', ); sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes( [qw(one two three four)] ); $self->authen->protected_runmodes(qw(two)); } sub one { return 'test one return value'; } sub two { return 'test two return value'; } sub three : RequireAuthentication { return 'test three return value'; } sub four : Authen(value) { return 'test four return value'; } } $ENV{CGI_APP_RETURN_ONLY} = 1; { # Open runmode my $query = CGI->new( { rm => 'one' } ); my $cgiapp = TestAppAttributes->new( QUERY => $query ); my $results = $cgiapp->run; like($results, qr/test one return value/, 'runmode one is open'); } { # Protected runmode (regular) my $query = CGI->new( { rm => 'two' } ); my $cgiapp = TestAppAttributes->new( QUERY => $query ); my $results = $cgiapp->run; unlike($results, qr/test two return value/, 'runmode two is protected'); } { # Protected runmode (attribute RequireAuthentication) my $query = CGI->new( { rm => 'three' } ); my $cgiapp = TestAppAttributes->new( QUERY => $query ); my $results = $cgiapp->run; unlike($results, qr/test three return value/, 'runmode three is protected'); } { # Protected runmode (attribute Authen) my $query = CGI->new( { rm => 'four' } ); my $cgiapp = TestAppAttributes->new( QUERY => $query ); my $results = $cgiapp->run; unlike($results, qr/test four return value/, 'runmode four is protected'); } { # Successful Login my $query = CGI->new( { authen_username => 'user1', authen_password => '123', rm => 'three' } ); my $cgiapp = TestAppAttributes->new( QUERY => $query ); my $results = $cgiapp->run; ok($cgiapp->authen->is_authenticated,'successful login'); is( $cgiapp->authen->username, 'user1', 'successful login - username set' ); like($results, qr/test three return value/, 'runmode three is visible after login'); } TestAppStore.pm100644001750001750 706114546072342 22564 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tpackage TestAppStore; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; use Test::More; use CGI (); $ENV{CGI_APP_RETURN_ONLY} = 1; sub setup { my $self = shift; $self->start_mode('unprotected'); $self->run_modes([qw(unprotected protected)]); $self->authen->protected_runmodes(qw(protected)); } sub unprotected { my $self = shift; my $username = $self->authen->username || ''; return "unprotected\nusername:$username\n"; } sub protected { my $self = shift; my $username = $self->authen->username; return "protected\nusername:$username\n"; } # helper class method that runs the app with certain parameters our ($CGIAPP, $RESULTS); sub run_app { my $class = shift; my $params = shift || {}; my $query = CGI->new( $params ); $class->maintain_state($CGIAPP, $RESULTS, $query) if $CGIAPP && $RESULTS; $CGIAPP = $class->new( QUERY => $query ); $RESULTS = $CGIAPP->run; my $store_entries = $class->can('get_store_entries') ? $class->get_store_entries($CGIAPP, $RESULTS) : undef; return ($CGIAPP, $RESULTS, $store_entries); } sub maintain_state {} sub clear_state { my $class = shift; $CGIAPP = undef; $RESULTS = undef; } sub run_store_tests { my $class = shift; my ( $cgiapp, $results, $store_entries ); # Regular call to unprotected page shouldn't create a store entry ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'unprotected' } ); ok(!$store_entries, "Store entry not created when calling unprotected page" ); # Regular call to protected page (without a valid login) shouldn't create a store entry ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected' } ); ok(!$store_entries, "Store entry not created when calling protected page without valid login" ); # Regular call to protected page (with an invalid login) should create a store entry marking login attempts ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected', auth_username => 'test', auth_password => 'badpassword' } ); ok(!$cgiapp->authen->is_authenticated,'failed login attempt'); ok($store_entries, "Store entry created when calling protected page with invalid login" ); isnt($store_entries->{username}, 'test', "Store entry contained the right username" ); is($store_entries->{login_attempts}, 1, "Store entry contained the right value for login_attempts" ); # Regular call to protected page (with an invalid login) should create a store entry marking login attempts ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected', auth_username => 'test', auth_password => 'badpassword' } ); ok(!$cgiapp->authen->is_authenticated,'failed login attempt'); ok($store_entries, "Store entry created when calling protected page with invalid login" ); isnt($store_entries->{username}, 'test', "Store entry contained the right username" ); is($store_entries->{login_attempts}, 2, "Store entry contained the right value for login_attempts" ); # Regular call to protected page (with a valid login) should create a store entry ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected', auth_username => 'test', auth_password => '123' } ); ok($cgiapp->authen->is_authenticated,'successful login'); ok($store_entries, "Store entry created when calling protected page with valid login" ); is($store_entries->{username}, 'test', "Store entry contained the right username" ); ok(!$store_entries->{login_attempts}, "Store entry cleared login_attempts" ); } 1; success-dev100644001750001750 764314546072342 22615 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outSet-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Content-Type: text/html; charset=ISO-8859-1 This is private grey_extra2100644001750001750 1327614546072342 22643 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/out
sample.cgi100755001750001750 304014546072342 22762 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example#!/usr/bin/perl -T # # Sample application # # Just place this file in a CGI enabled part of your website, and # load it up in your browser. The only valid username/password # combination is 'test' and '123'. # use strict; use warnings; { package SampleLogin; use base qw(CGI::Application); use CGI::Application::Plugin::Session; use CGI::Application::Plugin::Authentication; use CGI::Application::Plugin::AutoRunmode; use CGI::Carp qw(fatalsToBrowser); my %config = ( DRIVER => [ 'Generic', { test => '123' } ], STORE => 'Cookie', LOGOUT_RUNMODE => 'one', ); SampleLogin->authen->config(%config); SampleLogin->authen->protected_runmodes('two'); sub setup { my $self = shift; $self->start_mode('one'); } sub one : Runmode { my $self = shift; return CGI::start_html( -style => { -code => $self->authen->login_styles } ) . CGI::h2('This page is NOT protected') . CGI::a( { -href => '?rm=two' }, 'Protected Runmode' ) . CGI::end_html(); } sub two : Runmode { my $self = shift; return CGI::start_html( -style => { -code => $self->authen->login_styles } ) . CGI::h2('This page is protected') . CGI::h2( 'username: ' . $self->authen->username ) . CGI::a( { -href => '?rm=one' }, 'Un-Protected Runmode' ) . CGI::br() . CGI::a( { -href => '?authen_logout=1' }, 'Logout' ) . CGI::end_html(); } } SampleLogin->new->run; TestAppDriver.pm100644001750001750 722614546072342 22726 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tpackage TestAppDriver; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; use Test::More; use CGI (); sub setup { my $self = shift; $self->start_mode('unprotected'); $self->run_modes([qw(unprotected protected)]); $self->authen->protected_runmodes(qw(protected)); } sub unprotected { my $self = shift; my $username = $self->authen->username; return "username:$username\n"; } sub protected { my $self = shift; my $username = $self->authen->username; return "username:$username\n"; } # # These tests should pass with the credentials that were passed # But other tests are performed that should successfully fail # sub run_authen_tests { my $class = shift; my $credentials = shift; my @testdata = @_; $ENV{CGI_APP_RETURN_ONLY} = 1; foreach my $data (@testdata) { my ($params, $query, $cgiapp, $results); # Successful Login $params = { map { $credentials->[$_] => $data->[$_] } 0..$#$credentials }; $params->{rm} = 'protected'; $query = CGI->new( $params ); $cgiapp = $class->new( QUERY => $query ); $results = $cgiapp->run; ok($cgiapp->authen->is_authenticated,'successful login'); is( $cgiapp->authen->username, $data->[0], 'successful login - username set' ); # Missing Credentials $params = { map { $credentials->[$_] => $data->[$_] } 1..$#$credentials }; $params->{rm} = 'protected'; $query = CGI->new( $params ); $cgiapp = $class->new( QUERY => $query ); $results = $cgiapp->run; ok(!$cgiapp->authen->is_authenticated,'missing credentials - login failure'); is( $cgiapp->authen->username, undef, 'missing credentials - username not set' ); # Bad user or password $params = { map { $credentials->[$_] => 'badvalue' } 0..$#$credentials }; $params->{rm} = 'protected'; $query = CGI->new( $params ); $cgiapp = $class->new( QUERY => $query ); $results = $cgiapp->run; ok(!$cgiapp->authen->is_authenticated,'login failure'); is( $cgiapp->authen->username, undef, "login failure - username not set" ); } } # # These tests should pass with the credentials that were passed # sub run_authen_success_tests { my $class = shift; my $credentials = shift; my @testdata = @_; $ENV{CGI_APP_RETURN_ONLY} = 1; foreach my $data (@testdata) { my ($params, $query, $cgiapp, $results); # Failed Login $params = { map { $credentials->[$_] => $data->[$_] } 0..$#$credentials }; $params->{rm} = 'protected'; $query = CGI->new( $params ); $cgiapp = $class->new( QUERY => $query ); $results = $cgiapp->run; ok( $cgiapp->authen->is_authenticated,'good credentials - login success'); is( $cgiapp->authen->username, $data->[0], 'good credentials - username set' ); } } # # These tests should fail with the credentials that were passed # sub run_authen_failure_tests { my $class = shift; my $credentials = shift; my @testdata = @_; $ENV{CGI_APP_RETURN_ONLY} = 1; foreach my $data (@testdata) { my ($params, $query, $cgiapp, $results); # Failed Login $params = { map { $credentials->[$_] => $data->[$_] } 0..$#$credentials }; $params->{rm} = 'protected'; $query = CGI->new( $params ); $cgiapp = $class->new( QUERY => $query ); $results = $cgiapp->run; ok(!$cgiapp->authen->is_authenticated,'failed credentials - login failure'); is( $cgiapp->authen->username, undef, 'failed credentials - username not set' ); } } 1; 03_destination.t100644001750001750 2166214546072342 22664 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -T use Test::More; use Test::Taint; use Test::Regression; use Test::Warn; use English qw(-no_match_vars); use strict; use warnings; if ($OSNAME eq 'MSWin32') { my $msg = 'Not running these tests on windows yet'; plan skip_all => $msg; exit(0); } plan tests => 11; use strict; use warnings; taint_checking_ok('taint checking is on'); use CGI (); my $cap_options = { DRIVER => [ 'Generic', { user1 => '123' } ], STORE => ['Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y'], POST_LOGIN_CALLBACK => \&TestAppAuthenticate::post_login, }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes([qw(one two three)]); $self->authen->protected_runmodes(qw(two three)); $self->authen->config($cap_options); } sub one { my $self = shift; return "ONE"; } sub two { my $self = shift; return "TWO"; } sub three { my $self = shift; return "THREE"; } sub post_login { my $self = shift; my $count=$self->param('post_login')||0; $self->param('post_login' => $count + 1 ); } } $ENV{CGI_APP_RETURN_ONLY} = 1; # successful login subtest 'straightforward use of destination parameter' => sub { plan tests => 5; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password=>'123', destination=>'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/redirect", "redirection"); ok($cgiapp->authen->is_authenticated,'login success'); is( $cgiapp->authen->username, 'user1', "login success - username set" ); is( $cgiapp->authen->login_attempts, 0, "successful login - failed login count" ); is( $cgiapp->param('post_login'),1,'successful login - POST_LOGIN_CALLBACK executed' ); }; subtest 'redirection including CRLF' => sub { plan tests => 5; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password=>'123', destination=>'http://news.bbc.co.uk\r\nLocation: blah' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/crlf", "crlf"); ok($cgiapp->authen->is_authenticated,'login success'); is( $cgiapp->authen->username, 'user1', "login success - username set" ); is( $cgiapp->authen->login_attempts, 0, "successful login - failed login count" ); is( $cgiapp->param('post_login'),1,'successful login - POST_LOGIN_CALLBACK executed' ); }; subtest 'redirection with constraining taint check' => sub { plan tests => 5; local $cap_options->{DETAINT_URL_REGEXP} = '^(http\:\/\/www\.perl.org\/[\w\_\%\?\&\;\-\/\@\.\+\$\=\#\:\!\*\"\'\(\)\,]+)$'; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password=>'123', destination=>'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/restricted", "restricted"); ok($cgiapp->authen->is_authenticated,'login success'); is( $cgiapp->authen->username, 'user1', "login success - username set" ); is( $cgiapp->authen->login_attempts, 0, "successful login - failed login count" ); is( $cgiapp->param('post_login'),1,'successful login - POST_LOGIN_CALLBACK executed' ); }; subtest 'user name failing taint check' => sub { plan tests => 5; local $cap_options->{DETAINT_USERNAME_REGEXP} = '^([A-Z]+)$'; my $query = CGI->new( { authen_username => 'user1', rm => 'two', destination=>'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/username", "username"); ok(!$cgiapp->authen->is_authenticated,'login failure'); is( $cgiapp->authen->username, undef, "login failure - username not set" ); is( $cgiapp->authen->login_attempts, 1, "failed login - failed login count" ); is( $cgiapp->param('post_login'),1,'failed login - POST_LOGIN_CALLBACK executed' ); }; subtest 'user name failing taint check - basic' => sub { plan tests => 5; local $cap_options->{LOGIN_FORM}->{DISPLAY_CLASS} = 'Basic'; local $cap_options->{DETAINT_USERNAME_REGEXP} = '^([A-Z]+)$'; my $query = CGI->new( { authen_username => 'user1', rm => 'two', destination=>'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/username-basic", "username basic"); ok(!$cgiapp->authen->is_authenticated,'login failure'); is( $cgiapp->authen->username, undef, "login failure - username not set" ); is( $cgiapp->authen->login_attempts, 1, "failed login - failed login count" ); is( $cgiapp->param('post_login'),1,'failed login - POST_LOGIN_CALLBACK executed' ); }; subtest 'POST_LOGIN_URL usage' => sub { plan tests => 5; local $cap_options->{POST_LOGIN_URL} = 'http://www.perl.org'; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password=>'123', destination=>'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/loginurl", "loginurl"); ok($cgiapp->authen->is_authenticated,'login success'); is( $cgiapp->authen->username, 'user1', "login success - username set" ); is( $cgiapp->authen->login_attempts, 0, "successful login - failed login count" ); is( $cgiapp->param('post_login'),1,'successful login - POST_LOGIN_CALLBACK executed' ); }; subtest 'POST_LOGIN_RUNMODE usage' => sub { plan tests => 6; local $cap_options->{POST_LOGIN_RUNMODE} = 'three'; local $cap_options->{POST_LOGIN_URL} = 'http://www.perl.org'; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password=>'123', destination=>'http://news.bbc.co.uk' } ); my $cgiapp; warning_is {$cgiapp = TestAppAuthenticate->new( QUERY => $query );} "authen config warning: parameter POST_LOGIN_URL ignored since we already have POST_LOGIN_RUNMODE", "checking generated warning"; ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/runmode", "runmode"); ok($cgiapp->authen->is_authenticated,'login success'); is( $cgiapp->authen->username, 'user1', "login success - username set" ); is( $cgiapp->authen->login_attempts, 0, "successful login - failed login count" ); is( $cgiapp->param('post_login'),1,'successful login - POST_LOGIN_CALLBACK executed' ); }; subtest 'LOGOUT usage' => sub { plan tests => 2; local $cap_options->{POST_LOGIN_RUNMODE} = 'three'; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password=>'123', authen_logout=>1, destination=>'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/logout", "logout"); ok(!$cgiapp->authen->is_authenticated,'logout success'); }; subtest 'Redirection failure' => sub { plan tests => 1; local $ENV{PATH_INFO} = '!!!!'; local $cap_options->{DETAINT_URL_REGEXP} = '^(\w+)$'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/redirection_failure", "redirection_failure"); }; subtest 'Redirection failure [Basic]' => sub { plan tests => 1; local $ENV{PATH_INFO} = '!!!!'; local $cap_options->{DETAINT_URL_REGEXP} = '^(\w+)$'; local $cap_options->{LOGIN_FORM}->{DISPLAY_CLASS} = 'Basic'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/redirection_failure_basic", "redirection_failure [Basic]"); }; sub make_output_timeless { my $output = shift; $output =~ s/^(Set-Cookie: CAPAUTH_DATA=\w+\%3D(?:\%3D)?\; path=\/\; expires=\w{3},\s\d{2}(?:\-|\s)\w{3}(?:\-|\s)\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Set-Cookie: CAPAUTH_DATA=; path=\/; expires=;$2/m; $output =~ s/^(Expires:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Expires$2/m; $output =~ s/^(Date:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Date$2/m; #$output =~ s/\r//g; return $output; } 05_autorunmode.t100644001750001750 1162114546072342 22701 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; eval "require CGI::Application::Plugin::AutoRunmode"; plan skip_all => "CGI::Application::Plugin::AutoRunmode required for this test" if $@; use lib './t'; use strict; use warnings; use CGI (); { package TestAppAutoRunmode; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; CGI::Application::Plugin::AutoRunmode->import; use Test::More; __PACKAGE__->authen->config( DRIVER => [ 'Generic', { user1 => '123' } ], STORE => [ 'Store::Dummy' ], ); sub setup { my $self = shift; $self->authen->protected_runmodes(qw(two)); } eval < "CGI::Application::Plugin::AutoRunmode version does not work with Authentication" if $@; package TestAppAutoRunmode::Subclass; use base qw(TestAppAutoRunmode); use Test::More; sub setup { my $self = shift; $self->authen->protected_runmodes(qw(six)); } eval < "CGI::Application::Plugin::AutoRunmode version does not work with Authentication" if $@; } plan tests => 14; $ENV{CGI_APP_RETURN_ONLY} = 1; my $class = 'TestAppAutoRunmode'; { # Open runmode my $query = CGI->new( { rm => 'one' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; like($results, qr/test one return value/, 'runmode one is open'); } { # Protected runmode (regular) my $query = CGI->new( { rm => 'two' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; unlike($results, qr/test two return value/, 'runmode two is protected'); } { # Protected runmode (attribute RequireAuthentication) my $query = CGI->new( { rm => 'three' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; unlike($results, qr/test three return value/, 'runmode three is protected'); } { # Protected runmode (attribute Authen) my $query = CGI->new( { rm => 'four' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; unlike($results, qr/test four return value/, 'runmode four is protected'); } { # Successful Login my $query = CGI->new( { authen_username => 'user1', authen_password => '123', rm => 'three' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; ok($cgiapp->authen->is_authenticated,'successful login'); is( $cgiapp->authen->username, 'user1', 'successful login - username set' ); like($results, qr/test three return value/, 'runmode three is visible after login'); } $class = 'TestAppAutoRunmode::Subclass'; { # Open runmode my $query = CGI->new( { rm => 'five' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; like($results, qr/test five return value/, 'runmode five is open'); } { # Protected runmode (regular) my $query = CGI->new( { rm => 'six' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; unlike($results, qr/test six return value/, 'runmode six is protected'); } { # Protected runmode (attribute RequireAuthentication) my $query = CGI->new( { rm => 'seven' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; unlike($results, qr/test seven return value/, 'runmode seven is protected'); } { # Protected runmode (attribute Authen) my $query = CGI->new( { rm => 'eight' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; unlike($results, qr/test eight return value/, 'runmode eight is protected'); } { # Successful Login my $query = CGI->new( { authen_username => 'user1', authen_password => '123', rm => 'seven' } ); my $cgiapp = $class->new( QUERY => $query ); my $results = $cgiapp->run; ok($cgiapp->authen->is_authenticated,'successful login'); is( $cgiapp->authen->username, 'user1', 'successful login - username set' ); like($results, qr/test seven return value/, 'runmode seven is visible after login'); } 40_encoder_md5.t100644001750001750 317114546072342 22503 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use strict; use warnings; eval "use Digest::MD5"; plan skip_all => "Digest::MD5 required for this test" if $@; plan tests => 17; use_ok('CGI::Application::Plugin::Authentication::Driver::Filter::md5'); my $class = 'CGI::Application::Plugin::Authentication::Driver::Filter::md5'; # Test binary my $binary = Digest::MD5::md5('123'); is( $class->filter( 'binary', '123' ), $binary, "filter" ); ok( $class->check( 'binary', '123', $binary ), "check passes" ); ok( !$class->check( 'binary', 'xxx', $binary ), "check fails" ); ok( $class->check( undef, '123', $binary ), "check passes" ); ok( !$class->check( undef, 'xxx', $binary ), "check fails" ); # Test base64 is( $class->filter( 'base64', '123' ), 'ICy5YqxZB1uWSwcVLSNLcA', "filter" ); ok( $class->check( 'base64', '123', 'ICy5YqxZB1uWSwcVLSNLcA' ), "check passes" ); ok( !$class->check( 'base64', 'xxx', 'ICy5YqxZB1uWSwcVLSNLcA' ), "check fails" ); ok( $class->check( undef, '123', 'ICy5YqxZB1uWSwcVLSNLcA' ), "check passes" ); ok( !$class->check( undef, 'xxx', 'ICy5YqxZB1uWSwcVLSNLcA' ), "check fails" ); # Test hex is( $class->filter( 'hex', '123' ), '202cb962ac59075b964b07152d234b70', "filter" ); ok( $class->check( 'hex', '123', '202cb962ac59075b964b07152d234b70' ), "check passes" ); ok( !$class->check( 'hex', 'xxx', '202cb962ac59075b964b07152d234b70' ), "check fails" ); is( $class->filter( undef, '123' ), '202cb962ac59075b964b07152d234b70', "filter" ); ok( $class->check( undef, '123', '202cb962ac59075b964b07152d234b70' ), "check passes" ); ok( !$class->check( undef, 'xxx', '202cb962ac59075b964b07152d234b70' ), "check fails" ); config_data100644001750001750 2514546072342 22736 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/_builddo{ my $x = {}; $x; }60_store_cookie.t100644001750001750 252614546072342 23011 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use strict; use warnings; use lib qw(t); use CGI::Util; use Test::More; plan tests => 17; { package TestAppStoreCookie; use base qw(TestAppStore); __PACKAGE__->authen->config( DRIVER => [ 'Generic', { 'test' => '123' } ], STORE => [ 'Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CUSTOM_NAME', EXPIRY => '+1y' ], CREDENTIALS => [qw(auth_username auth_password)], ); sub get_store_entries { my $class = shift; my $cgiapp = shift; my $results = shift; my ($capauth_data, $therest) = $results =~ qr/^Set\-Cookie:\s+CUSTOM_NAME=([\d\w%]+);(.*)$/m; return undef unless $capauth_data; main::like($therest, qr/expires=/, 'Expiry on the cookie is set'); my $data = CGI::Util::unescape($capauth_data); return $data ? $cgiapp->authen->store->_decode($data) : undef; } sub maintain_state { my $class = shift; my $old_cgiapp = shift; my $old_results = shift; my $new_query = shift; delete $ENV{'COOKIE'}; $old_results =~ qr/Set\-Cookie:\s+(CUSTOM_NAME=[\d\w%]+);/; $ENV{'COOKIE'} = $1 if $1; } sub clear_state { my $class = shift; delete $ENV{'COOKIE'}; $class->SUPER::clear_state(@_); } } TestAppStoreCookie->run_store_tests; 03_authenticate.t100644001750001750 466214546072342 23002 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -T use Test::More; eval "use CGI::Application::Plugin::Session"; plan skip_all => "CGI::Application::Plugin::Session required for this test" if $@; plan tests => 11; use strict; use warnings; use CGI (); { package TestAppAuthenticate; use base qw(CGI::Application); CGI::Application::Plugin::Session->import; # it was used conditionally above use CGI::Application::Plugin::Authentication; __PACKAGE__->authen->config( DRIVER => [ 'Generic', { user1 => '123' } ], STORE => 'Session', POST_LOGIN_CALLBACK => \&post_login, ); sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes([qw(one two)]); $self->authen->protected_runmodes(qw(two)); } sub one { my $self = shift; } sub two { my $self = shift; } sub post_login { my $self = shift; my $count=$self->param('post_login')||0; $self->param('post_login' => $count + 1 ); } } $ENV{CGI_APP_RETURN_ONLY} = 1; # Missing Credentials my $query = CGI->new( { authen_username => 'user1', rm => 'two' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); my $results = $cgiapp->run; ok(!$cgiapp->authen->is_authenticated,'missing credentials - login failure'); is( $cgiapp->authen->username, undef, 'missing credentials - username not set' ); is( $cgiapp->param('post_login'),1,'missing credentials - POST_LOGIN_CALLBACK executed' ); # Successful Login $query = CGI->new( { authen_username => 'user1', authen_password => '123', rm => 'two' } ); $cgiapp = TestAppAuthenticate->new( QUERY => $query ); $results = $cgiapp->run; ok($cgiapp->authen->is_authenticated,'successful login'); is( $cgiapp->authen->username, 'user1', 'successful login - username set' ); is( $cgiapp->authen->login_attempts, 0, "successful login - failed login count" ); is( $cgiapp->param('post_login'),1,'successful login - POST_LOGIN_CALLBACK executed' ); # Bad user or password $query = CGI->new( { authen_username => 'user2', authen_password => '123', rm => 'two' } ); $cgiapp = TestAppAuthenticate->new( QUERY => $query ); $results = $cgiapp->run; ok(!$cgiapp->authen->is_authenticated,'login failure'); is( $cgiapp->authen->username, undef, "login failure - username not set" ); is( $cgiapp->authen->login_attempts, 1, "login failure - failed login count" ); is( $cgiapp->param('post_login'),1,'login failure - POST_LOGIN_CALLBACK executed' ); 40_encoder_sha1.t100644001750001750 305114546072342 22647 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use strict; use warnings; use Digest::SHA; plan tests => 17; use_ok('CGI::Application::Plugin::Authentication::Driver::Filter::sha1'); my $class = 'CGI::Application::Plugin::Authentication::Driver::Filter::sha1'; # Test binary my $binary = Digest::SHA::sha1('123'); is($class->filter('binary', '123'), $binary, "filter"); ok($class->check('binary', '123', $binary), "check passes"); ok(!$class->check('binary', 'xxx', $binary), "check fails"); ok($class->check(undef, '123', $binary), "check passes"); ok(!$class->check(undef, 'xxx', $binary), "check fails"); # Test base64 is($class->filter('base64', '123'), 'QL0AFWMIX8NRZTKeof9cXsvbvu8', "filter"); ok($class->check('base64', '123', 'QL0AFWMIX8NRZTKeof9cXsvbvu8'), "check passes"); ok(!$class->check('base64', 'xxx', 'QL0AFWMIX8NRZTKeof9cXsvbvu8'), "check fails"); ok($class->check(undef, '123', 'QL0AFWMIX8NRZTKeof9cXsvbvu8'), "check passes"); ok(!$class->check(undef, 'xxx', 'QL0AFWMIX8NRZTKeof9cXsvbvu8'), "check fails"); # Test hex is($class->filter('hex', '123'), '40bd001563085fc35165329ea1ff5c5ecbdbbeef', "filter"); ok($class->check('hex', '123', '40bd001563085fc35165329ea1ff5c5ecbdbbeef'), "check passes"); ok(!$class->check('hex', 'xxx', '40bd001563085fc35165329ea1ff5c5ecbdbbeef'), "check fails"); is($class->filter(undef, '123'), '40bd001563085fc35165329ea1ff5c5ecbdbbeef', "filter"); ok($class->check(undef, '123', '40bd001563085fc35165329ea1ff5c5ecbdbbeef'), "check passes"); ok(!$class->check(undef, 'xxx', '40bd001563085fc35165329ea1ff5c5ecbdbbeef'), "check fails"); 99_pod_coverage.t100644001750001750 45614546072342 22755 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tuse Test::More; if ( not $ENV{TEST_AUTHOR} ) { my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; plan( skip_all => $msg ); } eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); 51_driver_dummy.t100644001750001750 70514546072342 23007 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use lib qw(t); plan tests => 8; use strict; use warnings; { package TestAppDriverGeneric; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => 'Dummy', STORE => 'Store::Dummy', ); } TestAppDriverGeneric->run_authen_success_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], [ 'user2', '234' ], [ 'user3', '' ], [ 'user4' ], ); frontpage-dev100644001750001750 743214546072342 23126 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 This is public generic_login100644001750001750 1413214546072342 23204 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outSet-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Content-Type: text/html; charset=ISO-8859-1 Sign In
missing_color100644001750001750 1366114546072342 23255 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
build_params100644001750001750 1333514546072342 23232 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/_builddo{ my $x = [ { 'ARGV' => [] }, {}, { 'config_dir' => '_build', 'orig_dir' => '/home/wes/code/cgi-app-p-authen', 'use_rcfile' => 1, 'include_dirs' => [], 'get_options' => {}, 'build_bat' => 0, 'auto_configure_requires' => 1, 'install_base_relpaths' => {}, 'dist_name' => 'CGI-Application-Plugin-Authentication', 'perl' => '/home/wes/.plenv/versions/5.20.1/bin/perl5.20.1', 'allow_pureperl' => 0, 'libdoc_dirs' => [ 'blib/lib', 'blib/arch' ], 'config' => undef, 'program_name' => undef, 'prereq_action_types' => [ 'requires', 'build_requires', 'test_requires', 'conflicts', 'recommends' ], 'test_requires' => {}, 'license' => 'perl', 'xs_files' => undef, 'build_script' => 'Build', 'sign' => undef, 'create_readme' => 1, 'create_license' => undef, 'dist_author' => [ 'Cees Hek ' ], 'requires' => { 'Class::ISA' => 0, 'Attribute::Handlers' => 0, 'CGI' => '3.16', 'Scalar::Util' => 0, 'perl' => '5.006', 'CGI::Application' => 4, 'Digest::SHA' => 0, 'UNIVERSAL::require' => 0, 'MIME::Base64' => 0 }, 'create_makefile_pl' => 'traditional', 'destdir' => undef, 'prefix' => undef, 'install_sets' => {}, '_added_to_INC' => [], 'prefix_relpaths' => {}, 'configure_requires' => {}, 'meta_merge' => { 'resources' => { 'repository' => 'http://github.com/cees/cgi-application-plugin-authentication/tree' }, 'keywords' => [ 'cgiapp', 'Titanium', 'authentication' ] }, 'use_tap_harness' => 0, 'verbose' => undef, 'test_file_exts' => [ '.t' ], 'conflicts' => {}, 'tap_harness_args' => {}, 'build_elements' => [ 'PL', 'support', 'pm', 'xs', 'share_dir', 'pod', 'script' ], 'pureperl_only' => 0, 'PL_files' => undef, 'magic_number' => undef, 'extra_linker_flags' => [], 'release_status' => 'stable', 'module_name' => 'CGI::Application::Plugin::Authentication', 'recommends' => { 'CGI::Application::Plugin::Session' => 0, 'Digest::MD5' => 0, 'Apache::Htpasswd' => '1.8', 'Color::Calc' => '0.12' }, 'meta_add' => {}, 'cpan_client' => 'cpan', 'extra_compiler_flags' => [], 'recurse_into' => [], 'has_config_data' => undef, 'pm_files' => undef, 'html_css' => '', 'mb_version' => '0.421', 'blib' => 'blib', 'scripts' => undef, 'original_prefix' => {}, 'create_packlist' => 1, 'bundle_inc' => [], 'dynamic_config' => 1, 'base_dir' => '/home/wes/code/cgi-app-p-authen', 'metafile' => 'META.yml', 'debug' => undef, 'share_dir' => undef, 'script_files' => undef, 'test_files' => undef, 'recursive_test_files' => undef, 'install_base' => undef, 'dist_version' => '0.20', 'metafile2' => 'META.json', 'debugger' => undef, 'build_requires' => { 'Test::Taint' => 0, 'Test::MockObject' => 0, 'Readonly' => 0, 'Test::Regression' => 0, 'Test::More' => '0.93', 'Test::NoWarnings' => 0, 'Test::Without::Module' => 0, 'Test::Warn' => '0.11', 'Test::Exception' => 0 }, 'installdirs' => 'site', 'extra_manify_args' => undef, 'install_path' => {}, 'pod_files' => undef, 'build_class' => 'Module::Build', 'mymetafile2' => 'MYMETA.json', 'dist_abstract' => undef, 'dist_version_from' => 'lib/CGI/Application/Plugin/Authentication.pm', 'autosplit' => undef, 'pollute' => undef, 'quiet' => undef, 'bundle_inc_preload' => [], 'c_source' => undef, 'dist_suffix' => undef, 'mymetafile' => 'MYMETA.yml', 'bindoc_dirs' => [ 'blib/script' ], 'needs_compiler' => '', 'allow_mb_mismatch' => 0 } ]; $x; }template.cgi100755001750001750 422014546072342 23315 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example#!/usr/bin/perl # # Sample application [Templates] # # This example is a bit more realistic than the sample.cgi and basic.cgi. # It is intended to show how you can control the style of the Basic login form. # You need to copy the templates and the contents of the httpdocs # to their appropriate places for you server. # Unless you change the .cgi script to use a local copy, # you will also need access to the internet so the script can load # some javascript files from YUI. # # The only valid username/password # combination is 'test' and '123'. # use strict; use warnings; use Readonly; # This bit needs to be modified for the local system. Readonly my $TEMPLATE_DIR => 'example/templates'; { package SampleLogin; use base ("CGI::Application::Plugin::HTDot", "CGI::Application"); use CGI::Application::Plugin::Session; use CGI::Application::Plugin::Authentication; use CGI::Application::Plugin::AutoRunmode; use CGI::Application::Plugin::Authentication::Display::Basic; use CGI::Carp qw(fatalsToBrowser); my %config = ( DRIVER => [ 'Generic', { test => '123' } ], STORE => 'Cookie', LOGOUT_RUNMODE => 'one', LOGIN_RUNMODE => 'login', ); SampleLogin->authen->config(%config); SampleLogin->authen->protected_runmodes('two'); sub setup { my $self = shift; $self->start_mode('one'); } sub one : Runmode { my $self = shift; my $tmpl_obj = $self->load_tmpl('one.tmpl'); return $tmpl_obj->output; } sub login : Runmode { my $self = shift; my $tmpl_obj = $self->load_tmpl('login.tmpl'); my $display = CGI::Application::Plugin::Authentication::Display::Basic->new($self); $tmpl_obj->param(login => $display); return $tmpl_obj->output; } sub two : Runmode { my $self = shift; my $tmpl_obj = $self->load_tmpl('two.tmpl'); my $display = CGI::Application::Plugin::Authentication::Display::Basic->new($self); $tmpl_obj->param(login => $display); return $tmpl_obj->output; } } SampleLogin->new(TMPL_PATH=>$TEMPLATE_DIR)->run; 40_encoder_crypt.t100644001750001750 70414546072342 23136 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -wT use Test::More tests => 4; BEGIN { use_ok('CGI::Application::Plugin::Authentication::Driver::Filter::crypt') }; use strict; use warnings; my $class = 'CGI::Application::Plugin::Authentication::Driver::Filter::crypt'; is($class->filter(undef, '123', 'mQPVY1HNg8SJ2'), 'mQPVY1HNg8SJ2', "encode"); ok($class->check(undef, '123', 'mQPVY1HNg8SJ2'), "check passes"); ok(!$class->check(undef, 'xxx', 'mQPVY1HNg8SJ2'), "check fails"); 40_encoder_strip.t100644001750001750 64314546072342 23140 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More tests => 4; BEGIN { use_ok('CGI::Application::Plugin::Authentication::Driver::Filter::strip') }; use strict; use warnings; my $class = 'CGI::Application::Plugin::Authentication::Driver::Filter::strip'; is($class->filter(undef, " abc\t\n"), 'abc', "filter"); ok($class->check(undef, " abc\t\n", 'abc'), "check passes"); ok(!$class->check(undef, " xxx\t\n", 'abc'), "check fails"); 03_missing_color.t100644001750001750 577714546072342 23203 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -T use Test::More; use Test::Taint; use Test::Regression; use Test::Warn; use Test::Without::Module qw(Color::Calc); use English qw(-no_match_vars); if ($OSNAME eq 'MSWin32') { my $msg = 'Not running these tests on windows yet'; plan skip_all => $msg; exit(0); } plan tests => 4; use strict; use warnings; taint_checking_ok('taint checking is on'); use CGI (); my $cap_options = { DRIVER => [ 'Generic', { user1 => '123' } ], STORE => ['Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y'], POST_LOGIN_CALLBACK => \&TestAppAuthenticate::post_login, }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes([qw(one two three)]); $self->authen->protected_runmodes(qw(two three)); $self->authen->config($cap_options); } sub one { my $self = shift; return "ONE"; } sub two { my $self = shift; return "TWO"; } sub three { my $self = shift; return "THREE"; } sub post_login { my $self = shift; my $count=$self->param('post_login')||0; $self->param('post_login' => $count + 1 ); } } $ENV{CGI_APP_RETURN_ONLY} = 1; subtest 'Base color' => sub { plan tests => 2; local $cap_options->{LOGIN_FORM}->{BASE_COLOUR} = 'purple'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); my $output; warning_is {$output = $cgiapp->run;} "Color::Calc is required when specifying a custom BASE_COLOUR, and leaving LIGHTER_COLOUR, LIGHT_COLOUR, DARK_COLOUR or DARKER_COLOUR blank or when providing percentage based colour", "checking generated warning"; ok_regression(sub {make_output_timeless($output)}, "t/out/missing_color", "Missing color"); }; subtest 'No Base color' => sub { plan tests => 1; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/missing_color", "Missing color"); }; sub make_output_timeless { my $output = shift; $output =~ s/^(Set-Cookie: CAPAUTH_DATA=\w+\%3D\%3D\; path=\/\; expires=\w{3},\s\d{2}(?:\-|\s)\w{3}(?:\-|\s)\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Set-Cookie: CAPAUTH_DATA=; path=\/; expires=;$2/m; $output =~ s/^(Expires:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Expires$2/m; $output =~ s/^(Date:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Date$2/m; #$output =~ s/\r//g; return $output; } # Test::NoWarn doesn't play nice with the windows skip_all require Test::NoWarnings; Test::NoWarnings::had_no_warnings(); 60_store_session.t100644001750001750 304214546072342 23215 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use strict; use warnings; use lib qw(t); use CGI::Util; use Test::More; eval "use CGI::Application::Plugin::Session"; plan skip_all => "CGI::Application::Plugin::Session required for this test" if $@; plan tests => 14; { package TestAppStoreSession; use base qw(TestAppStore); CGI::Application::Plugin::Session->import; # was loaded conditionally above __PACKAGE__->authen->config( DRIVER => [ 'Generic', { 'test' => '123' } ], STORE => [ 'Session' ], CREDENTIALS => [qw(auth_username auth_password)], ); sub get_store_entries { my $class = shift; my $cgiapp = shift; my $results = shift; my $data = { username => $cgiapp->session->param('AUTH_USERNAME'), login_attempts => $cgiapp->session->param('AUTH_LOGIN_ATTEMPTS'), }; return ($data->{username} || $data->{login_attempts}) ? $data : undef; } sub maintain_state { my $class = shift; my $old_cgiapp = shift; my $old_results = shift; my $new_query = shift; $old_cgiapp->session->flush; $new_query->param(-name => CGI::Session->name, -value => $old_cgiapp->session->id, -override => 1); } sub clear_state { my $class = shift; my $old_cgiapp = shift; my $old_results = shift; $old_cgiapp->session->clear(['AUTH_USERNAME','AUTH_LOGIN_ATTEMPTS']), $old_cgiapp->session->flush; $class->SUPER::clear_state(@_); } } TestAppStoreSession->run_store_tests; username-basic100644001750001750 355214546072342 23262 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outSet-Cookie: CAPAUTH_DATA=; path=/; expires=; Date Content-Type: text/html; charset=ISO-8859-1 Sign In
auto_features100644001750001750 2514546072342 23346 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/_builddo{ my $x = {}; $x; }53_driver_dbi_bad.t100644001750001750 654214546072342 23247 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use Test::Exception; use Test::Warn; use lib qw(t); eval "use DBD::SQLite"; plan skip_all => "DBD::SQLite required for this test" if $@; plan tests => 9; use strict; use warnings; our $DBNAME = 't/sqlite.db'; unlink $DBNAME if -e $DBNAME; my $dbh = DBI->connect( "dbi:SQLite:dbname=$DBNAME", "", "" ); $dbh->do(<<""); CREATE TABLE user ( name VARCHAR(20), password VARCHAR(50), active INT ) $dbh->do(<<""); INSERT INTO user VALUES ('user1', '123', 1); $dbh->do(<<""); INSERT INTO user VALUES ('user3', '123', 0); $dbh->do(<<""); INSERT INTO user VALUES ('user2', 'mQPVY1HNg8SJ2', 1); # crypt("123", "mQ") my %options = ( DRIVER => [ 'DBI', DBH => $dbh, TABLE => 'user', ], STORE => 'Store::Dummy', ); { package TestAppDriverDBISimple; use base qw(TestAppDriver); sub setup { my $self = shift; $self->SUPER::setup(); $self->authen->config(%options); } } { local $options{DRIVER}->[4] = undef; throws_ok {TestAppDriverDBISimple->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], [ 'user2', '123' ], );} qr/Error executing class callback in prerun stage: No TABLE parameter defined/, "no TABLE"; } { my @opts = @{$options{DRIVER}}; local $options{DRIVER} = [@opts, 'COLUMNS', 'bad column']; throws_ok {TestAppDriverDBISimple->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], [ 'user2', '123' ], );} qr/Error executing class callback in prerun stage: COLUMNS must be a hashref/, "COLUMNS not a hashref"; } { my @opts = @{$options{DRIVER}}; local $options{DRIVER} = [@opts, 'CONSTRAINTS', 'bad constraints']; throws_ok {TestAppDriverDBISimple->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], [ 'user2', '123' ], );} qr/Error executing class callback in prerun stage: CONSTRAINTS must be a hashref/, "CONSTRAINTS not a hashref"; } { my @opts = @{$options{DRIVER}}; local $options{DRIVER} = [@opts, 'CONSTRAINTS', 0]; warning_like {throws_ok {TestAppDriverDBISimple->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], [ 'user2', '123' ], );} qr/Error executing class callback in prerun stage: Failed to prepare SQL statement: (near " "|incomplete input)/, "DBI syntax error";} qr/DBD::SQLite::db prepare_cached failed: (near " ": syntax error|incomplete input)/, "DBD:SQLite"; } { my @opts = @{$options{DRIVER}}; local $options{DRIVER} = [ @opts, 'COLUMNS', {active=>1}, 'CONSTRAINTS', { 'user.name' => '__CREDENTIAL_1__', 'user.password' => '__CREDENTIAL_2__' }, ]; TestAppDriverDBISimple->run_authen_success_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], ); TestAppDriverDBISimple->run_authen_failure_tests( [ 'authen_username', 'authen_password' ], [ 'user3', '123' ], ); } $dbh->do(<<""); DROP TABLE user; undef $dbh; unlink $DBNAME if -e $DBNAME; TestAppParsimony.pm100644001750001750 136514546072342 23452 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/tpackage TestAppParsimony; use strict; use warnings; use Carp; use base qw(CGI::Application); use CGI::Application::Plugin::Session; use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->start_mode('unprotected'); #$self->mode_param('rm'); $self->run_modes( 'unprotected' => sub {return "This is public.";}, 'protected' => sub {return "This is private.";} ); $self->authen->config( DRIVER => [ 'Generic', { 'test' => '123' } ], STORE => [ 'Session' ], CREDENTIALS => [qw(auth_username auth_password)], ); $self->authen->protected_runmodes('protected'); } 1 61_cookie_badargs.t100644001750001750 170614546072342 23260 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use strict; use warnings; use lib qw(t); use CGI::Util; use Test::More; use Test::NoWarnings; plan tests => 2; { package TestAppStoreCookie; use Test::More; use Test::Exception; use base qw(TestAppStore); __PACKAGE__->authen->config( DRIVER => [ 'Generic', { 'test' => '123' } ], STORE => [ 'Cookie', EXPIRY=>'+1y', 'YAH_BOO_SUCKS'], CREDENTIALS => [qw(auth_username auth_password)], ); sub run_store_tests { my $class = shift; my ( $cgiapp, $results, $store_entries ); # Regular call to unprotected page shouldn't create a store entry throws_ok { ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'unprotected' } ); } qr/Error executing run mode 'unprotected': Invalid Store Configuration for the Cookie store - options section must contain a hash of values/, 'invalid args'; } } TestAppStoreCookie->run_store_tests; 53_driver_dbi_die.t100644001750001750 226514546072342 23260 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl BEGIN {push @ARGV, '--dbtest';} use Test::More; use Test::Exception; use Test::Warn; use lib qw(t); my $dbh; use Test::MockObject; $dbh = Test::MockObject->new; $dbh->set_isa('DBI'); $dbh->fake_module('DBI'); $dbh->mock('prepare_cached', sub {return $dbh;}); $dbh->set_false('execute'); $dbh->set_always('errstr', 'Mock error'); plan tests => 1; use strict; use warnings; { package TestAppDriverDBISimple; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ [ 'DBI', DBH => $dbh, TABLE => 'user', CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__', 'user.password' => '__CREDENTIAL_2__' }, ], ], STORE => 'Store::Dummy', ); } $ENV{CGI_APP_RETURN_ONLY} = 1; my $params = { authen_username => 'user1', authen_password => '123', rm => 'protected', }; my $query = CGI->new( $params ); my $cgiapp = TestAppDriverDBISimple->new( QUERY => $query ); throws_ok {$cgiapp->run;} qr/Error executing class callback in prerun stage: Mock error/, 'throws error correctly'; undef $dbh; 52_driver_generic.t100644001750001750 156714546072342 23320 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use lib qw(t); plan tests => 32; use strict; use warnings; { package TestAppDriverGeneric; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ [ 'Generic', { user1 => '123' } ], [ 'Generic', [ [ 'user2', '234' ], [ 'user3', '345' ], ], ], [ 'Generic', sub { no warnings qw(uninitialized); $_[0] eq 'user4' && $_[1] eq '456' ? $_[0] : 0 } ], ], STORE => 'Store::Dummy', ); } TestAppDriverGeneric->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], [ 'user2', '234' ], [ 'user3', '345' ], [ 'user4', '456' ], ); TestAppDriverGeneric->run_authen_failure_tests( [ 'authen_username', 'authen_password' ], [ 'user1', 'xxx' ], [ 'user2', 'xxx' ], [ 'user3', 'xxx' ], [ 'user4', 'xxx' ], ); basic_login_box100644001750001750 264114546072342 23503 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/out
runtime_params100644001750001750 2514546072342 23526 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/_builddo{ my $x = {}; $x; }author-pod-syntax.t100644001750001750 45414546072342 23403 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!perl BEGIN { unless ($ENV{AUTHOR_TESTING}) { print qq{1..0 # SKIP these tests are for testing by the author\n}; exit } } # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); 03_login_box_other.t100644001750001750 1422014546072342 23514 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl # taint chcking seems to break Devel::Cover use Test::More; use Test::Regression; use Test::Warn; use English qw(-no_match_vars); BEGIN { use Test::More; eval {require Color::Calc;}; if ($@) { my $msg = 'Color::Calc required'; diag $msg; plan skip_all => $msg; } if ($OSNAME eq 'MSWin32') { my $msg = 'Not running these tests on windows yet'; plan skip_all => $msg; } plan tests => 7; } use strict; use warnings; use CGI (); my $cap_options = { DRIVER => [ 'Generic', { user1 => '123' } ], STORE => ['Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y'], POST_LOGIN_CALLBACK => \&TestAppAuthenticate::post_login, }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes([qw(one two three)]); $self->authen->protected_runmodes(qw(two three)); $self->authen->config($cap_options); } sub one { my $self = shift; return "ONE"; } sub two { my $self = shift; return "TWO"; } sub three { my $self = shift; return "THREE"; } sub post_login { my $self = shift; my $count=$self->param('post_login')||0; $self->param('post_login' => $count + 1 ); } } $ENV{CGI_APP_RETURN_ONLY} = 1; subtest 'Various other pemutations' => sub { plan tests => 1; undef local $cap_options->{LOGIN_FORM}->{COMMENT}; local $cap_options->{LOGIN_FORM}->{FOCUS_FORM_ONLOAD} = 1; local $cap_options->{LOGIN_FORM}->{REMEMBERUSER_OPTION} = 0; local $cap_options->{LOGIN_FORM}->{REGISTER_URL} = '/register'; local $cap_options->{LOGIN_FORM}->{FORGOTPASSWORD_URL} = '/forgot'; local $cap_options->{LOGIN_FORM}->{GREY_COLOUR} = 'purple'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/other_permutations", "Other permutations"); }; subtest 'Percentage' => sub { plan tests => 1; local $cap_options->{LOGIN_FORM}->{LIGHT_COLOUR} = '20%'; local $cap_options->{LOGIN_FORM}->{LIGHTER_COLOUR} = '10%'; local $cap_options->{LOGIN_FORM}->{DARK_COLOUR} = '80%'; local $cap_options->{LOGIN_FORM}->{DARKER_COLOUR} = '90%'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/percentage", "Percentage"); }; subtest 'Names of colours' => sub { plan tests => 1; local $cap_options->{LOGIN_FORM}->{LIGHT_COLOUR} = '110%'; local $cap_options->{LOGIN_FORM}->{LIGHTER_COLOUR} = 'red'; local $cap_options->{LOGIN_FORM}->{DARK_COLOUR} = 'green'; local $cap_options->{LOGIN_FORM}->{DARKER_COLOUR} = 'blue'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/names_of_colours", "Names of colours"); }; subtest 'Names of colours II' => sub { plan tests => 1; local $cap_options->{LOGIN_FORM}->{LIGHT_COLOUR} = 'orange'; local $cap_options->{LOGIN_FORM}->{LIGHTER_COLOUR} = 'red'; local $cap_options->{LOGIN_FORM}->{DARK_COLOUR} = '110%'; local $cap_options->{LOGIN_FORM}->{DARKER_COLOUR} = 'blue'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/names_of_colours_2", "Names of colours"); }; subtest 'Names of colours III' => sub { plan tests => 1; local $cap_options->{LOGIN_FORM}->{LIGHT_COLOUR} = 'orange'; local $cap_options->{LOGIN_FORM}->{LIGHTER_COLOUR} = 'red'; local $cap_options->{LOGIN_FORM}->{DARK_COLOUR} = 'purple'; local $cap_options->{LOGIN_FORM}->{DARKER_COLOUR} = 'blue'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/names_of_colours_3", "Names of colours"); }; subtest 'grey' => sub { plan tests => 1; local $cap_options->{LOGIN_FORM}->{LIGHT_COLOUR} = 'orange'; local $cap_options->{LOGIN_FORM}->{LIGHTER_COLOUR} = '15%'; local $cap_options->{LOGIN_FORM}->{DARK_COLOUR} = 'purple'; local $cap_options->{LOGIN_FORM}->{DARKER_COLOUR} = 'blue'; local $cap_options->{LOGIN_FORM}->{GREY_COLOUR} = 'blue'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/grey", "grey"); }; subtest 'grey II' => sub { plan tests => 1; local $cap_options->{LOGIN_FORM}->{LIGHT_COLOUR} = 'orange'; local $cap_options->{LOGIN_FORM}->{LIGHTER_COLOUR} = '15%'; local $cap_options->{LOGIN_FORM}->{DARK_COLOUR} = 'purple'; local $cap_options->{LOGIN_FORM}->{DARKER_COLOUR} = 'blue'; local $cap_options->{LOGIN_FORM}->{GREY_COLOUR} = '0'; my $query = CGI->new( { rm => 'two'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/grey2", "grey"); }; sub make_output_timeless { my $output = shift; $output =~ s/^(Set-Cookie: CAPAUTH_DATA=\w+\%3D\%3D\; path=\/\; expires=\w{3},\s\d{2}(?:\-|\s)\w{3}(?:\-|\s)\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Set-Cookie: CAPAUTH_DATA=; path=\/; expires=;$2/m; $output =~ s/^(Expires:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Expires$2/m; $output =~ s/^(Date:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Date$2/m; #$output =~ s/\r//g; return $output; } 03_login_box_basic.t100644001750001750 1362714546072342 23466 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -T use Test::More; use Test::Taint; use Test::Regression; use Test::Exception; use English qw(-no_match_vars); use lib qw(t); if ($OSNAME eq 'MSWin32') { my $msg = 'Not running these tests on windows yet'; plan skip_all => $msg; exit(0); } plan tests => 6; use strict; use warnings; use CGI (); taint_checking_ok('taint checking is on'); $ENV{CGI_APP_RETURN_ONLY} = 1; my $cap_options = { DRIVER => [ 'Generic', { user1 => '123' } ], STORE => ['Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y'], POST_LOGIN_CALLBACK => \&TestAppAuthenticate::post_login, LOGIN_FORM=>{ DISPLAY_CLASS=>'Basic', }, }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes([qw(one two)]); $self->authen->protected_runmodes(qw(two)); $self->authen->config($cap_options); } sub one { my $self = shift; } sub two { my $self = shift; } sub post_login { my $self = shift; my $count=$self->param('post_login')||0; $self->param('post_login' => $count + 1 ); } } subtest 'empty' => sub { plan tests => 14; my $cgiapp = TestAppAuthenticate->new; my $results = $cgiapp->run; ok(!$cgiapp->authen->is_authenticated,"login failure"); is( $cgiapp->authen->username, undef, "username not set" ); my $display = $cgiapp->authen->display; isa_ok($display, 'CGI::Application::Plugin::Authentication::Display'); isa_ok($display, 'CGI::Application::Plugin::Authentication::Display::Basic'); is($display->login_title, 'Sign In', 'title'); ok_regression(sub {return $display->login_box}, 't/out/basic_login_box', 'login box'); is($display->logout_form, '', 'logout_form'); is($display->is_authenticated, 0, 'is_authenticated'); is($display->username, undef, 'username'); is($display->last_login, undef, 'last_login'); is($display->last_access, undef, 'last_access'); is($display->is_login_timeout, 0, 'is_login_timeout'); is($display->login_attempts, undef, 'login_attempts'); throws_ok(sub {$display->enforce_protection}, qr/Attempt to bypass authentication on protected template/, 'not authenticated'); }; subtest 'authenticated' => sub { plan tests => 14; my $cgiapp = TestAppAuthenticate->new; $cgiapp->query->param(rm=>'two'); $cgiapp->query->param(authen_username=>'user1'); $cgiapp->query->param(authen_password=>'123'); $cgiapp->run; ok($cgiapp->authen->is_authenticated,"login success"); is( $cgiapp->authen->username, 'user1', "username set" ); my $display = $cgiapp->authen->display; isa_ok($display, 'CGI::Application::Plugin::Authentication::Display'); isa_ok($display, 'CGI::Application::Plugin::Authentication::Display::Basic'); is($display->login_title, 'Sign In', 'title'); throws_ok(sub {return $display->login_box}, qr{already authenticated}, 'login box'); is($display->logout_form, 'Logout', 'logout_form'); is($display->is_authenticated, 1, 'is_authenticated'); is($display->username, 'user1', 'username'); ok(abs(time - $display->last_login) < 100, 'last_login'); ok(abs(time - $display->last_access) < 100, 'last_access'); is($display->is_login_timeout, 0, 'is_login_timeout'); is($display->login_attempts, 0, 'login_attempts'); is($display->enforce_protection, "\n", 'authenticated'); }; subtest 'failure_and_options' => sub { plan tests => 8; local $cap_options->{LOGIN_FORM}->{REMEMBERUSER_OPTION} = 0; local $cap_options->{LOGIN_FORM}->{REGISTER_URL} = '/register'; local $cap_options->{LOGIN_FORM}->{FORGOTPASSWORD_URL} = '/forgotpassword'; my $cgiapp = TestAppAuthenticate->new; $cgiapp->query->param(rm=>'two'); $cgiapp->query->param(authen_username=>'user1'); $cgiapp->query->param(authen_password=>'666'); $cgiapp->run; ok(!$cgiapp->authen->is_authenticated,"login failure"); is( $cgiapp->authen->username, undef, "username not set" ); my $display = $cgiapp->authen->display; isa_ok($display, 'CGI::Application::Plugin::Authentication::Display'); isa_ok($display, 'CGI::Application::Plugin::Authentication::Display::Basic'); is($display->login_title, 'Sign In', 'title'); ok_regression(sub {return $display->login_box}, 't/out/basic_login_box_options', 'login box'); is($display->logout_form, '', 'logout_form'); is($display->is_authenticated, 0, 'is_authenticated'); }; subtest 'null' => sub { plan tests => 14; local $cap_options->{LOGIN_FORM}->{DISPLAY_CLASS} = 'Null'; my $cgiapp = TestAppAuthenticate->new; my $results = $cgiapp->run; ok(!$cgiapp->authen->is_authenticated,"login failure"); is( $cgiapp->authen->username, undef, "username not set" ); my $display = $cgiapp->authen->display; isa_ok($display, 'CGI::Application::Plugin::Authentication::Display'); isa_ok($display, 'CGI::Application::Plugin::Authentication::Display::Null'); is($display->login_title, 'Sign In', 'title'); throws_ok(sub {return $display->login_box}, qr/not implemented in base class/, 'login box'); is($display->logout_form, '', 'logout_form'); is($display->is_authenticated, 0, 'is_authenticated'); is($display->username, undef, 'username'); is($display->last_login, undef, 'last_login'); is($display->last_access, undef, 'last_access'); is($display->is_login_timeout, 0, 'is_login_timeout'); is($display->login_attempts, undef, 'login_attempts'); throws_ok(sub {$display->enforce_protection}, qr/Attempt to bypass authentication on protected template/, 'not authenticated'); }; # Test::NoWarn doesn't play nice with the windows skip_all require Test::NoWarnings; Test::NoWarnings::had_no_warnings(); 54_driver_htpasswd.t100644001750001750 225014546072342 23531 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -w use strict; use warnings; use Test::More; use Test::Exception; use lib qw(t); eval "use Apache::Htpasswd 1.8;"; plan skip_all => "Apache::Htpasswd >= 1.8 required for this test" if $@; plan tests => 31; use strict; use warnings; our $HTPASSWD = 't/htpasswd'; our $HTPASSWD2 = 't/htpasswd2'; { package TestAppDriverHTPasswd; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ 'HTPasswd', $HTPASSWD, $HTPASSWD2 ], STORE => 'Store::Dummy', ); } TestAppDriverHTPasswd->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], [ 'user2', '123' ], [ 'user3', '123' ], [ 'user4', '123' ], [ 'user5', '123' ], ); # Test bad config { package TestAppDriverHTPasswd2; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ 'HTPasswd' ], STORE => 'Store::Dummy', ); } throws_ok {TestAppDriverHTPasswd2->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], );} qr/Error executing class callback in prerun stage: The HTPasswd driver requires at least one htpasswd file/, 'no htpasswd files'; 70_action_dispatch.t100644001750001750 671514546072342 23465 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -wT use Test::More; use Test::Taint; use Test::Regression; use English qw(-no_match_vars); use lib qw(t); BEGIN { use Test::More; eval {require CGI::Application::Plugin::ActionDispatch;}; if ($@) { my $msg = 'CGI::Application::Plugin::ActionDispatch required'; plan skip_all => $msg; } if ($OSNAME eq 'MSWin32') { my $msg = 'Not running these tests on windows yet'; plan skip_all => $msg; } plan tests => 4; } use strict; use warnings; use CGI (); taint_checking_ok('taint checking is on'); my $cap_options = { DRIVER => [ 'Generic', { user1 => '123' } ], STORE => ['Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y'], POST_LOGIN_CALLBACK => \&TestAppAuthenticate::post_login, }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::ActionDispatch; use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->authen->protected_runmodes(qw(protected)); $self->authen->config($cap_options); } sub unprotected : Default { return "This is public"; } sub protected : Path('private') { return "This is private"; } sub post_login { my $self = shift; my $count=$self->param('post_login')||0; $self->param('post_login' => $count + 1 ); } } $ENV{CGI_APP_RETURN_ONLY} = 1; # front page subtest 'front page' => sub { plan tests => 2; my $query = CGI->new(); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/frontpage", "frontpage"); ok(!$cgiapp->authen->is_authenticated,'not authenticated'); }; # login intercepted subtest 'interception' => sub { plan tests => 3; local $ENV{PATH_INFO} = '/private'; my $query = CGI->new(); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/login", "login"); ok(!$cgiapp->authen->is_authenticated,'not authenticated'); ok( !defined($cgiapp->param('post_login')),'unsuccessful login' ); }; # successful login subtest 'successful login' => sub { plan tests => 5; local $ENV{PATH_INFO} = '/private'; my $query = CGI->new( { authen_username => 'user1', authen_password=>'123'} ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok_regression(sub {make_output_timeless($cgiapp->run)}, "t/out/success", "success"); ok($cgiapp->authen->is_authenticated,'login success'); is( $cgiapp->authen->username, 'user1', "login success - username set" ); is( $cgiapp->authen->login_attempts, 0, "successful login - failed login count" ); is( $cgiapp->param('post_login'),1,'successful login - POST_LOGIN_CALLBACK executed' ); }; sub make_output_timeless { my $output = shift; $output =~ s/^(Set-Cookie: CAPAUTH_DATA=\w+\%3D\%3D\; path=\/\; expires=\w{3},\s\d{2}(?:\-|\s)\w{3}(?:\-|\s)\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Set-Cookie: CAPAUTH_DATA=; path=\/; expires=;$2/m; $output =~ s/^(Expires:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Expires$2/m; $output =~ s/^(Date:\s\w{3},\s\d{2}\s\w{3}\s\d{4}\s\d{2}:\d{2}:\d{2}\s\w{3})([\r\n\s]*)$/Date$2/m; #$output =~ s/\r//g; return $output; } names_of_colours100644001750001750 1364014546072342 23740 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
50_driver_undefined.t100644001750001750 2644714546072342 23667 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -T use Test::More; use Test::Taint; use Test::Exception; use Test::Regression; use English qw(-no_match_vars); use lib qw(t); if ($OSNAME eq 'MSWin32') { my $msg = 'Not running these tests on windows yet'; plan skip_all => $msg; } plan tests => 46; srand(0); use strict; use warnings; taint_checking_ok('taint checking is on'); use CGI (); my $cap_options = { STORE => [ 'Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y' ], }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes( [qw(one two three)] ); $self->authen->protected_runmodes(qw(two three)); $self->authen->config($cap_options); } sub one { my $self = shift; return "ONE"; } sub two { my $self = shift; return "TWO"; } sub three { my $self = shift; return "THREE"; } sub post_login { my $self = shift; my $count = $self->param('post_login') || 0; $self->param( 'post_login' => $count + 1 ); } } $ENV{CGI_APP_RETURN_ONLY} = 1; # Test 'find_options' function and what happens when we don't define 'verify_credentials' { local $cap_options->{DRIVER} = [ 'Silly', option1 => 'Tom', option2 => 'Dick', option3 => 'Harry' ]; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); my @drivers = $cgiapp->authen->drivers; ok( scalar(@drivers) == 1, 'We should have just one driver' ); ok( $drivers[0]->find_option( 'option1', 'Tom' ), 'Tom' ); ok( $drivers[0]->find_option( 'option2', 'Dick' ), 'Dick' ); ok( $drivers[0]->find_option( 'option3', 'Harry' ), 'Harry' ); throws_ok { $cgiapp->run } qr/verify_credentials must be implemented in the subclass/, 'undefined function caught okay'; }; # Test what happens when we have no options. { local $cap_options->{DRIVER} = [ 'Silly', ]; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok( !exists $cgiapp->authen->{drivers}, 'nothing cached yet' ); my @drivers = $cgiapp->authen->drivers; ok( scalar(@drivers) == 1, 'We should have just one driver' ); ok( scalar( @{ $cgiapp->authen->{drivers} } ) == 1, 'cached now' ); # test caching my @drivers1 = $cgiapp->authen->drivers; ok( scalar(@drivers1) == 1, 'We should have just one driver' ); ok( $drivers[0] == $drivers1[0], 'test caching' ); ok( !defined( $drivers[0]->find_option( 'option1', 'Tom' ) ), 'Tom' ); ok( !defined( $drivers[0]->find_option( 'option2', 'Dick' ) ), 'Dick' ); ok( !defined( $drivers[0]->find_option( 'option3', 'Harry' ) ), 'Harry' ); }; # Test what happens when no driver is defined { my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); my @drivers = $cgiapp->authen->drivers; ok( scalar(@drivers) == 1, 'We should have just one driver' ); isa_ok( $drivers[0], 'CGI::Application::Plugin::Authentication::Driver::Dummy', 'Dummy is the default driver' ); }; # Test what happens when a non-existent driver is called { local $cap_options->{DRIVER} = ['Blah']; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); throws_ok { $cgiapp->authen->drivers } qr/Driver Blah can not be found/, 'Non existent driver'; }; # Test what happens when a driver constructor dies { local $cap_options->{DRIVER} = ['Die']; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); throws_ok { $cgiapp->authen->drivers } qr/Could not create new CGI::Application::Plugin::Authentication::Driver::Die object/, 'Suicidal driver'; }; # Start playing with filter { my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok( !exists $cgiapp->authen->{drivers}, 'nothing cached yet' ); my @drivers = $cgiapp->authen->drivers; ok( scalar(@drivers) == 1, 'We should have just one driver' ); ok( scalar( @{ $cgiapp->authen->{drivers} } ) == 1, 'cached now' ); my $driver = ($cgiapp->authen->drivers)[0]; is($driver->filter('crypt_blah:password', 'hello123', 'UDI'), "UDAdLpAU1oHWU", "crypt - salt=UDI"); is($driver->filter('crypt_blah:password', 'hello123', 'JJJ'), "JJfyQYJkUrAE6", "crypt - salt=JJJ"); is($driver->filter('crypt_blah:password', 'hello123'), "8jtQ9rloNVKU.", "crypt - no salt"); is($driver->filter('crypt_blah:password', 'hello123', ''), "4rJy6RLB765G6", "crypt - bland salt"); throws_ok { $driver->filter('nonsense:crypt_blah:password', 'hello123', '') } qr/No filters found for 'nonsense'/, "undefined filter"; throws_ok { $driver->filter('md5_blah:crypt_blah:password', 'hello123', '') } qr/Unknown MD5 format blah/, "Unknown MD5 parameter"; throws_ok { $driver->filter('sha1_blah:crypt_blah:password', 'hello123', '') } qr/Unknown SHA1 format blah/, "Unknown SHA1 parameter"; }; # Nonsense filter { local $cap_options->{DRIVER} = [ 'Dummy', FILTERS=>{nonsense=>'not a suboutine'} ]; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok( !exists $cgiapp->authen->{drivers}, 'nothing cached yet' ); my @drivers = $cgiapp->authen->drivers; ok( scalar(@drivers) == 1, 'We should have just one driver' ); ok( scalar( @{ $cgiapp->authen->{drivers} } ) == 1, 'cached now' ); my $driver = ($cgiapp->authen->drivers)[0]; throws_ok { $driver->filter('nonsense1_blah:crypt_blah:password', 'hello123', '') } qr/No filter found for 'nonsense1'/, "undefined filter"; throws_ok { $driver->filter('nonsense:crypt_blah:password', 'hello123', '') } qr/the 'nonsense' filter listed in FILTERS must be a subroutine reference/, "undefined filter"; }; # FILTERS option not a hashref { local $cap_options->{DRIVER} = [ 'Dummy', FILTERS=>'not a hashref' ]; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok( !exists $cgiapp->authen->{drivers}, 'nothing cached yet' ); my @drivers = $cgiapp->authen->drivers; ok( scalar(@drivers) == 1, 'We should have just one driver' ); ok( scalar( @{ $cgiapp->authen->{drivers} } ) == 1, 'cached now' ); my $driver = ($cgiapp->authen->drivers)[0]; throws_ok { $driver->filter('nonsense_blah:crypt_blah:password', 'hello123', '') } qr/the FILTERS configuration option must be a hashref/, "undefined filter"; }; # FILTERS option not a hashref { local $cap_options->{DRIVER} = [ 'Dummy', FILTERS=>{nonsense=>\&obfuscate}, ]; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok( !exists $cgiapp->authen->{drivers}, 'nothing cached yet' ); my @drivers = $cgiapp->authen->drivers; ok( scalar(@drivers) == 1, 'We should have just one driver' ); ok( scalar( @{ $cgiapp->authen->{drivers} } ) == 1, 'cached now' ); my $driver = ($cgiapp->authen->drivers)[0]; is($driver->filter('nonsense:password', 'hello123', ''), "|hello123|G", "custom filter"); }; # Generic driver { local $cap_options->{DRIVER} = [ 'Generic', 'Use me if you can' ]; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); throws_ok { $cgiapp->run } qr/Unknown options for Generic Driver/, 'Unknown options for Generic Driver'; }; # DBI driver { local $cap_options->{DRIVER} = [ 'DBI', 'Use me if you can' ]; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); throws_ok { $cgiapp->run } qr/The DBI driver requires a hash of options/, 'The DBI driver requires a hash of options'; }; # DBI driver (no dbh) { local $cap_options->{DRIVER} = [ 'DBI', ]; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); throws_ok { $cgiapp->run } qr/No DBH handle passed to the DBI Driver, and no dbh\(\) method detected/, 'No DBH'; }; # Generic driver where first credential is undefined { local $cap_options->{DRIVER} = [ 'Generic', {user=>'123',}, ]; my $query = CGI->new( { authen_username => undef, rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); $cgiapp->run; ok(!$cgiapp->authen->is_authenticated, "undefined username"); my @drivers = $cgiapp->authen->drivers; ok(!defined($drivers[0]->verify_credentials(undef, 'blah'))); }; sub obfuscate { my $param = shift || "G"; my $value = shift; return "|$value|$param"; } 53_driver_dbi_syntax.t100644001750001750 312614546072342 24042 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use Test::Exception; use Test::Warn; use lib qw(t); eval "use DBD::SQLite"; plan skip_all => "DBD::SQLite required for this test" if $@; plan tests => 2; use strict; use warnings; our $DBNAME = 't/sqlite.db'; unlink $DBNAME if -e $DBNAME; my $dbh = DBI->connect( "dbi:SQLite:dbname=$DBNAME", "", "" ); $dbh->do(<<""); CREATE TABLE user ( name VARCHAR(20), password VARCHAR(50) ) $dbh->do(<<""); INSERT INTO user VALUES ('user1', '123'); $dbh->do(<<""); INSERT INTO user VALUES ('user2', 'mQPVY1HNg8SJ2'); # crypt("123", "mQ") { package TestAppDriverDBISimple; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ [ 'DBI', DBH => $dbh, TABLE => 'user', JOIN_ON => ' blah blah blah', CONSTRAINTS => { 'user.name' => '__CREDENTIAL_1__', 'user.password' => '__CREDENTIAL_2__' }, ], ], STORE => 'Store::Dummy', ); } $ENV{CGI_APP_RETURN_ONLY} = 1; my $params = { authen_username => 'user1', authen_password => '123', rm => 'protected', }; my $query = CGI->new( $params ); my $cgiapp = TestAppDriverDBISimple->new( QUERY => $query ); warning_like {throws_ok {$cgiapp->run;} qr/Error executing class callback in prerun stage: Failed to prepare SQL statement: near "blah": syntax error/, 'Syntax error';} qr/DBD::SQLite::db prepare_cached failed: near "blah": syntax error/, 'checking warnings'; $dbh->do(<<""); DROP TABLE user; undef $dbh; unlink $DBNAME if -e $DBNAME; other_permutations100644001750001750 1375314546072342 24343 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
names_of_colours_3100644001750001750 1363414546072342 24165 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
names_of_colours_2100644001750001750 1363714546072342 24167 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
Simple000755001750001750 014546072342 22142 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/AuthenDummy.pm100644001750001750 73514546072342 23720 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/Authen/Simplepackage Authen::Simple::Dummy; use strict; use warnings; use base 'Authen::Simple::Adapter'; use Params::Validate; __PACKAGE__->options({ testuser => { type => Params::Validate::SCALAR, optional => 1 }, testpass => { type => Params::Validate::SCALAR, optional => 1 }, }); sub check { my ( $self, $username, $password ) = @_; return $username eq $self->testuser && $password eq $self->testpass ? 1 : 0; } 1; 61_store_cookie_other.t100644001750001750 1155014546072342 24230 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use strict; use warnings; use lib qw(t); use Readonly; Readonly my $SECRET_WARN => qr/using default SECRET\! Please provide a proper SECRET when using the Cookie store/; use Test::NoWarnings; use CGI::Util; use Test::More; plan tests => 25; { package TestAppStoreCookie; use Test::More; use Test::Warn; use base qw(TestAppStore); __PACKAGE__->authen->config( DRIVER => [ 'Generic', { 'test' => '123' } ], STORE => [ 'Cookie', EXPIRY=>'+1y'], CREDENTIALS => [qw(auth_username auth_password)], ); sub get_store_entries { my $class = shift; my $cgiapp = shift; my $results = shift; my ($capauth_data, $therest) = $results =~ qr/^Set\-Cookie:\s+CAPAUTH_DATA=([\d\w%]+);(.*)$/m; return undef unless $capauth_data; main::like($therest, qr/expires=/, 'Expiry on the cookie is set'); my $data = CGI::Util::unescape($capauth_data); return $data ? $cgiapp->authen->store->_decode($data) : undef; } sub maintain_state { my $class = shift; my $old_cgiapp = shift; my $old_results = shift; my $new_query = shift; delete $ENV{'COOKIE'}; $old_results =~ qr/Set\-Cookie:\s+(CAPAUTH_DATA=[\d\w%]+);/; $ENV{'COOKIE'} = $1 if $1; } sub clear_state { my $class = shift; delete $ENV{'COOKIE'}; $class->SUPER::clear_state(@_); } sub run_store_tests { my $class = shift; my ( $cgiapp, $results, $store_entries ); # Regular call to unprotected page shouldn't create a store entry ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'unprotected' } ); ok(!$store_entries, "Store entry not created when calling unprotected page" ); # Regular call to protected page (without a valid login) shouldn't create a store entry ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected' } ); ok(!$store_entries, "Store entry not created when calling protected page without valid login" ); # Regular call to protected page (with an invalid login) should create a store entry marking login attempts warnings_like { ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected', auth_username => 'test', auth_password => 'badpassword' } ); } [$SECRET_WARN, $SECRET_WARN], 'bad SECRET warning'; ok(!$cgiapp->authen->is_authenticated,'failed login attempt'); ok($store_entries, "Store entry created when calling protected page with invalid login" ); isnt($store_entries->{username}, 'test', "Store entry contained the right username" ); is($store_entries->{login_attempts}, 1, "Store entry contained the right value for login_attempts" ); # Regular call to protected page (with an invalid login) should create a store entry marking login attempts warnings_like { ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected', auth_username => 'test', auth_password => 'badpassword' } ); } [$SECRET_WARN, $SECRET_WARN, $SECRET_WARN], 'bad SECRET warning'; ok(!$cgiapp->authen->is_authenticated,'failed login attempt'); ok($store_entries, "Store entry created when calling protected page with invalid login" ); isnt($store_entries->{username}, 'test', "Store entry contained the right username" ); is($store_entries->{login_attempts}, 2, "Store entry contained the right value for login_attempts" ); # Regular call to protected page (with a valid login) should create a store entry warnings_like { ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected', auth_username => 'test', auth_password => '123' } ); } [$SECRET_WARN, $SECRET_WARN, $SECRET_WARN], 'bad SECRET warning'; ok($cgiapp->authen->is_authenticated,'successful login'); ok($store_entries, "Store entry created when calling protected page with valid login" ); is($store_entries->{username}, 'test', "Store entry contained the right username" ); ok(!$store_entries->{login_attempts}, "Store entry cleared login_attempts" ); my $nothing = $cgiapp->authen->store->_decode(''); is($nothing, undef, 'decode nothing'); use MIME::Base64; my %hash = (c=>'I am not a checksum',f=>'Bubble'); my $rawdata = join("\0", map {join ('=', $_, $hash{$_}) } keys %hash); my $nonsense; warning_like { $nonsense = $cgiapp->authen->store->_decode(MIME::Base64::encode($rawdata)); } $SECRET_WARN, 'decode warning'; is($nonsense, undef, 'decode nonsense'); { use CGI::Application::Plugin::Authentication::Store::Cookie; $CGI::Application::Plugin::Authentication::Store::Cookie::SECRET = 'you would never guess'; } $nonsense = $cgiapp->authen->store->_decode(MIME::Base64::encode($rawdata)); is($nonsense, undef, 'decode nonsense with secret'); } } TestAppStoreCookie->run_store_tests; 07_protected_runmodes.t100644001750001750 531414546072342 24230 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -wT use Test::More; plan tests => 22; use strict; use warnings; use CGI (); { package TestAppProtectedRunmodes; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; __PACKAGE__->authen->config( DRIVER => [ 'Generic', { user1 => '123' } ], STORE => 'Store::Dummy', ); } $ENV{CGI_APP_RETURN_ONLY} = 1; my $cgiapp = TestAppProtectedRunmodes->new; my $authen = $cgiapp->authen; ok($authen->protected_runmodes(qw(one)), 'we can register protected runmodes'); is_deeply( [$authen->protected_runmodes], [ 'one' ], 'verify that runmode is registered correctly' ); ok($authen->protected_runmodes(qw(two three)), 'we can register multiple protected runmodes'); is_deeply( [$authen->protected_runmodes], [ qw(one two three) ], 'verify that runmodes are cummulative' ); ok($authen->protected_runmodes(qr/^auth_/), 'we can register protected runmodes as a regexp'); is_deeply( [$authen->protected_runmodes], [ qw(one two three), qr/^auth_/ ], 'verify that this test was added' ); my $sub = sub { $_[0] eq 'sub' ? 1 : 0 }; ok($authen->protected_runmodes($sub), 'we can register protected runmodes as a subroutine reference'); is_deeply( [$authen->protected_runmodes], [ qw(one two three), qr/^auth_/, $sub ], 'verify that this test was added' ); # test valid runmodes ok($authen->is_protected_runmode('one'), "Test 'is_protected_runmode' with valid string"); ok($authen->is_protected_runmode('two'), "Test 'is_protected_runmode' with valid string"); ok($authen->is_protected_runmode('three'), "Test 'is_protected_runmode' with valid string"); ok($authen->is_protected_runmode('auth_test'), "Test 'is_protected_runmode' with valid regexp test string"); ok($authen->is_protected_runmode('sub'), "Test 'is_protected_runmode' with valid subroutine test string"); # test invalid runmodes ok(!$authen->is_protected_runmode('notone'), "Test 'is_protected_runmode' with invalid value"); ok(!$authen->is_protected_runmode('authtest'), "Test 'is_protected_runmode' with invalid value"); ok(!$authen->is_protected_runmode('subtest'), "Test 'is_protected_runmode' with invalid value"); ok(!$authen->is_protected_runmode(''), "Test 'is_protected_runmode' with empty string value"); ok(!$authen->is_protected_runmode( [] ), "Test 'is_protected_runmode' with invalid value (arrayref)"); ok(!$authen->is_protected_runmode( {} ), "Test 'is_protected_runmode' with invalid value (arrayref)"); ok($authen->protected_runmodes(':all'), 'we can mark all runmodes as protected'); is_deeply( [$authen->protected_runmodes], [ qw(one two three), qr/^auth_/, $sub, ':all' ], 'verify that this test was added' ); ok($authen->is_protected_runmode('anything_goes'), "Test 'is_protected_runmode' with any string"); redirection_failure100644001750001750 1363214546072342 24422 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
templates000755001750001750 014546072342 22653 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/exampleone.tmpl100644001750001750 64314546072342 24455 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example/templates Untitled Document

This page is NOT protected

Protected Runmode two.tmpl100644001750001750 101714546072342 24521 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example/templates Untitled Document

This page is protected

username: test


Un-Protected Runmode 55_driver_authensimple.t100644001750001750 230314546072342 24372 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use lib qw(t); eval "use Authen::Simple"; plan skip_all => "Authen::Simple required for this test" if $@; plan tests => 11; use strict; use warnings; { package TestAppDriverAuthenSimple; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ 'Authen::Simple::Dummy', testuser => 'user1', testpass => '123' ], STORE => 'Store::Dummy', ); } TestAppDriverAuthenSimple->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], ); TestAppDriverAuthenSimple->run_authen_failure_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '1234' ], ); # Test covering certain coverage cases TestAppDriverAuthenSimple->run_authen_failure_tests( [ 'authen_username', 'authen_password' ], [ 0, 'hhhh'], ); $ENV{CGI_APP_RETURN_ONLY} = 1; my $params = { rm => 'protected', authen_username => undef, authen_password => '2234' }; { use CGI; my $query = CGI->new( $params ); my $cgiapp = TestAppDriverAuthenSimple->new( QUERY => $query ); my @drivers = $cgiapp->authen->drivers; ok(!defined $drivers[0]->verify_credentials(undef, '2234'), 'impossible case'); } login.tmpl100644001750001750 201314546072342 25015 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example/templates <TMPL_VAR NAME="login.login_title"> js000755001750001750 014546072342 23121 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example/httpdocsfocus.js100644001750001750 37714546072342 24725 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example/httpdocs/jsYAHOO.util.Event.onAvailable('authen_loginfield', function(o) { YAHOO.util.Dom.get('authen_loginfield').focus(); }, this); YAHOO.util.Event.onAvailable('authen_rememberuserfield', function(o) { YAHOO.util.Dom.get('authen_loginfield').select(); }, this);61_store_cookie_noexpiry.t100644001750001750 1012314546072342 24757 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use strict; use warnings; use lib qw(t); use Readonly; Readonly my $SECRET_WARN => qr/using default SECRET\! Please provide a proper SECRET when using the Cookie store/; use Test::NoWarnings; use CGI::Util; use Test::More; plan tests => 21; { package TestAppStoreCookie; use Test::More; use Test::Warn; use base qw(TestAppStore); __PACKAGE__->authen->config( DRIVER => [ 'Generic', { 'test' => '123' } ], STORE => [ 'Cookie'], CREDENTIALS => [qw(auth_username auth_password)], ); sub get_store_entries { my $class = shift; my $cgiapp = shift; my $results = shift; my ($capauth_data, $therest) = $results =~ qr/^Set\-Cookie:\s+CAPAUTH_DATA=([\d\w%]+);(.*)$/m; return undef unless $capauth_data; main::unlike($therest, qr/expires=/, 'Expiry on the cookie is not set'); my $data = CGI::Util::unescape($capauth_data); return $data ? $cgiapp->authen->store->_decode($data) : undef; } sub maintain_state { my $class = shift; my $old_cgiapp = shift; my $old_results = shift; my $new_query = shift; delete $ENV{'COOKIE'}; $old_results =~ qr/Set\-Cookie:\s+(CAPAUTH_DATA=[\d\w%]+);/; $ENV{'COOKIE'} = $1 if $1; } sub clear_state { my $class = shift; delete $ENV{'COOKIE'}; $class->SUPER::clear_state(@_); } sub run_store_tests { my $class = shift; my ( $cgiapp, $results, $store_entries ); # Regular call to unprotected page shouldn't create a store entry ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'unprotected' } ); ok(!$store_entries, "Store entry not created when calling unprotected page" ); # Regular call to protected page (without a valid login) shouldn't create a store entry ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected' } ); ok(!$store_entries, "Store entry not created when calling protected page without valid login" ); # Regular call to protected page (with an invalid login) should create a store entry marking login attempts warnings_like { ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected', auth_username => 'test', auth_password => 'badpassword' } ); } [$SECRET_WARN, $SECRET_WARN], 'bad SECRET warning'; ok(!$cgiapp->authen->is_authenticated,'failed login attempt'); ok($store_entries, "Store entry created when calling protected page with invalid login" ); isnt($store_entries->{username}, 'test', "Store entry contained the right username" ); is($store_entries->{login_attempts}, 1, "Store entry contained the right value for login_attempts" ); # Regular call to protected page (with an invalid login) should create a store entry marking login attempts warnings_like { ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected', auth_username => 'test', auth_password => 'badpassword' } ); } [$SECRET_WARN, $SECRET_WARN, $SECRET_WARN], 'bad SECRET warning'; ok(!$cgiapp->authen->is_authenticated,'failed login attempt'); ok($store_entries, "Store entry created when calling protected page with invalid login" ); isnt($store_entries->{username}, 'test', "Store entry contained the right username" ); is($store_entries->{login_attempts}, 2, "Store entry contained the right value for login_attempts" ); # Regular call to protected page (with a valid login) should create a store entry warnings_like { ($cgiapp, $results, $store_entries) = $class->run_app( { rm => 'protected', auth_username => 'test', auth_password => '123' } ); } [$SECRET_WARN, $SECRET_WARN, $SECRET_WARN], 'bad SECRET warning'; ok($cgiapp->authen->is_authenticated,'successful login'); ok($store_entries, "Store entry created when calling protected page with valid login" ); is($store_entries->{username}, 'test', "Store entry contained the right username" ); ok(!$store_entries->{login_attempts}, "Store entry cleared login_attempts" ); } } TestAppStoreCookie->run_store_tests; 50_driver_missing_modules.t100644001750001750 561414546072342 25100 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl -T use Test::More; use Test::Taint; use Test::Exception; use lib qw(t); use Test::Without::Module qw(Digest::MD5); use Test::Without::Module qw(Digest::SHA); use English qw(-no_match_vars); if ($OSNAME eq 'MSWin32') { my $msg = 'Not running these tests on windows yet'; plan skip_all => $msg; } plan tests => 11; srand(0); use strict; use warnings; taint_checking_ok('taint checking is on'); use CGI (); my $cap_options = { STORE => [ 'Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y' ], }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes( [qw(one two three)] ); $self->authen->protected_runmodes(qw(two three)); $self->authen->config($cap_options); } sub one { my $self = shift; return "ONE"; } sub two { my $self = shift; return "TWO"; } sub three { my $self = shift; return "THREE"; } sub post_login { my $self = shift; my $count = $self->param('post_login') || 0; $self->param( 'post_login' => $count + 1 ); } } $ENV{CGI_APP_RETURN_ONLY} = 1; # Start playing with filter { my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', destination => 'http://news.bbc.co.uk' } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok( !exists $cgiapp->authen->{drivers}, 'nothing cached yet' ); my @drivers = $cgiapp->authen->drivers; ok( scalar(@drivers) == 1, 'We should have just one driver' ); ok( scalar( @{ $cgiapp->authen->{drivers} } ) == 1, 'cached now' ); my $driver = ($cgiapp->authen->drivers)[0]; is($driver->filter('crypt_blah:password', 'hello123', 'UDI'), "UDAdLpAU1oHWU", "crypt - salt=UDI"); is($driver->filter('crypt_blah:password', 'hello123', 'JJJ'), "JJfyQYJkUrAE6", "crypt - salt=JJJ"); is($driver->filter('crypt_blah:password', 'hello123'), "8jtQ9rloNVKU.", "crypt - no salt"); is($driver->filter('crypt_blah:password', 'hello123', ''), "4rJy6RLB765G6", "crypt - bland salt"); throws_ok { $driver->filter('nonsense:crypt_blah:password', 'hello123', '') } qr/No filters found for 'nonsense'/, "undefined filter"; throws_ok { $driver->filter('md5:crypt_blah:password', 'hello123', '') } qr/Digest::MD5 is required to check MD5 passwords/, "Digest::MD5 not present"; throws_ok { $driver->filter('sha1:crypt_blah:password', 'hello123', '') } qr/Digest::SHA is required to check SHA1 passwords/, "Digest::SHA not present"; }; basic_login_box_options100644001750001750 261114546072342 25253 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/out
55_driver_authensimple_die.t100644001750001750 172314546072342 25220 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use Test::Exception; use Test::Warn; use Test::MockObject; use lib qw(t); BEGIN { eval {require Params::Validate}; if ($@) { my $msg = "Authen::Simple depends on Params::Validate, hence this test also"; plan skip_all => $msg; } } my $authensimple = Test::MockObject->new; $authensimple->fake_module('Authen::Simple::Adapter', new=>sub{return undef},options=>sub{1}); plan tests => 1; use strict; use warnings; { package TestAppDriverAuthenSimple; use base qw(TestAppDriver); __PACKAGE__->authen->config( DRIVER => [ 'Authen::Simple::Dummy', testuser => 'user1', testpass => '123' ], STORE => 'Store::Dummy', ); } throws_ok { TestAppDriverAuthenSimple->run_authen_tests( [ 'authen_username', 'authen_password' ], [ 'user1', '123' ], ); } qr/Error executing class callback in prerun stage: Failed to create Authen::Simple::Dummy instance/, 'throws error correctly'; css000755001750001750 014546072342 23275 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example/httpdocsieonly.css100644001750001750 7114546072342 25404 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example/httpdocs/cssdiv.login label .authen_input { margin-top: -1em; } redirection_failure_basic100644001750001750 343214546072342 25540 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t/outContent-Type: text/html; charset=ISO-8859-1 Sign In
release-changes_has_content.t100644001750001750 230614546072342 25426 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t BEGIN { unless ($ENV{RELEASE_TESTING}) { print qq{1..0 # SKIP these tests are for release candidate testing\n}; exit } } use Test::More tests => 2; note 'Checking Changes'; my $changes_file = 'Changes'; my $newver = '0.24'; my $trial_token = '-TRIAL'; my $encoding = 'UTF-8'; SKIP: { ok(-e $changes_file, "$changes_file file exists") or skip 'Changes is missing', 1; ok(_get_changes($newver), "$changes_file has content for $newver"); } done_testing; sub _get_changes { my $newver = shift; # parse changelog to find commit message open(my $fh, '<', $changes_file) or die "cannot open $changes_file: $!"; my $changelog = join('', <$fh>); if ($encoding) { require Encode; $changelog = Encode::decode($encoding, $changelog, Encode::FB_CROAK()); } close $fh; my @content = grep { /^$newver(?:$trial_token)?(?:\s+|$)/ ... /^\S/ } # from newver to un-indented split /\n/, $changelog; shift @content; # drop the version line # drop unindented last line and trailing blank lines pop @content while ( @content && $content[-1] =~ /^(?:\S|\s*$)/ ); # return number of non-blank lines return scalar @content; } ieonly6.css100644001750001750 7014546072342 25471 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example/httpdocs/cssdiv.login .login_footer { margin-bottom: -0.5em; } template.css100644001750001750 1041314546072342 26001 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/example/httpdocs/cssdiv.login { width: 25em; margin: auto; padding: 3px; font-weight: bold; border: 2px solid #445588; color: #303c5f; font-family: sans-serif; } div.login div { margin: 0; padding: 0; border: none; } div.login .login_header { background: #445588; border-bottom: 1px solid #1b2236; height: 1.5em; padding: 0.45em; text-align: left; color: #fff; font-size: 100%; font-weight: bold; } div.login .login_content { background: #d0d5e1; padding: 0.8em; border-top: 1px solid white; border-bottom: 1px solid #565656; font-size: 80%; } div.login .login_footer { background: #a2aac4; border-top: 1px solid white; border-bottom: 1px solid white; text-align: left; padding: 0; margin: 0; min-height: 2.8em; } div.login fieldset { margin: 0; padding: 0; border: none; width: 95%; } div.login label { clear: left; float: left; padding: 0.6em 0 0.6em 0; margin-right: 1em; width: 100%; text-align: left; } div.login label .authen_input { float: right; margin: 0 1em 0 0; padding: 0 0 0 18px; } /* image courtesy of http://www.famfamfam.com/lab/icons/silk/ */ #authen_loginfield { background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAAK/INwWK6QAAABl0RVh0U29mdHdhcmUAQWRvYmUgSW1hZ2VSZWFkeXHJZTwAAAG5SURBVHjaYvz//z8DJQAggFiIVfh0twHn9w8KD9+/ZBT+9/cfExfvwwc87GxWAAFEtAFf3yl++/9XikHXL56BkYmJ4dKmcoUPT99PBQggRmK8ALT9v4BUBQMLrxxQMztY7N+PjwyXtk76BxBATMRoFjGewsDCx8jw9Oxyht9vboIxCDAxs/wCCCC8LoBrZv/A8PPpVoZ/39gZ7p57xcDLJ8Xw5tkdBrO8DYwAAcRElOYXaxn+/73DwC4vzyAmzsLw58kJsGaQOoAAYiJK868nDGwSXgxvjp1n+Hz7HoNawRFGmFqAAMIw4MBEDaI1gwBAAKEYsKtL/b9x2HSiNYMAQACBA3FmiqKCohrbfQ2nLobn97Yz6Br/JEozCAAEEDgh/eb6d98yYhEDBxsnw5VNZxnOffjLIKltw/D52B6GH89fMVjUnGbEFdgAAQRPiexMzAyfDk9gMJbmYbh17irDueMrGbjExBi8Oy8z4ksnAAEENuDY1S8MjjsnMSgaezJ8Z2Bm+P95PgPX6ycENYMAQACBwyDSUeQ/GzB926kLMEjwsjOwifKvcy05EkxMHgEIIEZKszNAgAEA+j3MEVmacXUAAAAASUVORK5CYII=') no-repeat 0 1px; background-color: #fff; width: 12em; border-top: solid 1px #565656; border-left: solid 1px #565656; border-bottom: solid 1px #a2aac4; border-right: solid 1px #a2aac4; } /* image courtesy of http://www.famfamfam.com/lab/icons/silk/ */ #authen_passwordfield { background: url('data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAABGdBTUEAAK/INwWK6QAAABl0RVh0U29mdHdhcmUAQWRvYmUgSW1hZ2VSZWFkeXHJZTwAAAKbSURBVHjaYvz//z8DPvBko+s0IJUJ5U6X8d+dhSwPEEAMIANw4ccbXKYB8f8/P+6BMYgNEkNWAxBAhDV/Pff/5+t5/39/2gcU/gc25P5qpzkwdQABxIjNCzBnS7p2Mfz5tJ+BkVWE4dWRxWA5oBcYHiyyYnj5heGAedYxR4AAwmXAf0mPWQx/3q9n+P/3I9AAMaCoBsPr4x0MDH/+MUgHrGG4P8eF4fVf9gMAAcSEK/D+/3oA1gxm/3kLJG8wSDhWMAjoeTJ8fxjNoJDQzyD0+7sDQACx4DKAkVWcgZGZG2jIV6AJfxn+/37F8OfPO6BhRxl+f/nIwC7xluHPm58MAAHEhMX5ILHp787OYvj/7zvDr7f7Gf59vw804DUwPM4x/P3+loFb0ZfhVlc1wxMu7psAAcSCEd9MjAzswoYMAppmDD9e9DKwcIkwMHFyMPx+dZnh7+9vDDxqwQx3Ji1jeMrJc9W1/JQOQAAheyFT2mctw9+vpxh+fz7A8O1JDQMrEz/QK2YMb47uZpD0SmEAmsRwu7eJ4QUX1wWXklOGIE0AAcQIim9YShOzSmf49W4xw5+PdxlYeIUYWLh9GS6vXPH+3U/Gd3K/vikzcTAzvOTkOmNXeNIUZitAALFAbF4D9N8Bhl+vJjP8/vCUgY1fkoGZ24PhysoV7178Y9vmW3M8FqZBHS3MAAIIZMDnP59P835/3Mnw98t7Bg5xNQZGNnOgzSvfv2ZgX+dbfiwVX14BCCCQAbyMrNwMDKxcDOxi/Az/WU0YLi1b8/E9K8cqr6JjGQwEAEAAMf378+/cn+//GFi5bRiYuMOBzt7w4RMH50IPIjSDAEAAsbz8+Gfdh9VFEr9//WX7//s/009uzlmuWUcqGYgEAAEGAIZWUhP4bjW1AAAAAElFTkSuQmCC') no-repeat 0 1px; background-color: #fff; width: 12em; border-top: solid 1px #565656; border-left: solid 1px #565656; border-bottom: solid 1px #a2aac4; border-right: solid 1px #a2aac4; } #authen_loginfield:focus, #authen_passwordfield:focus { background-color: #ffc; color: #000; } div.login a { font-size: 80%; color: #303c5f; } div.login div.buttons input { border-top: solid 2px #a2aac4; border-left: solid 2px #a2aac4; border-bottom: solid 2px #565656; border-right: solid 2px #565656; background-color: #d0d5e1; padding: 0.2em 1em ; font-size: 80%; font-weight: bold; color: #303c5f; } div.login div.buttons { display: block; margin: 8px 4px; width: 100%; } #authen_loginbutton { float: right; margin-right: 1em; } #authen_registerlink { display: block; } #authen_forgotpasswordlink { display: block; } ul.message { margin-top: 0; margin-bottom: 0; list-style: none; } ul.message li { text-indent: -2em; padding: 0px; margin: 0px; font-style: italic; } ul.message li.warning { color: red; } 55_driver_missing_authensimple.t100644001750001750 366314546072342 26135 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/t#!/usr/bin/perl use Test::More; use Test::Exception; use lib qw(t); use Test::Without::Module qw(Authen::Simple::Adapter); plan tests => 4; srand(0); use strict; use warnings; use CGI (); my $cap_options = { STORE => [ 'Cookie', SECRET => "Shhh, don't tell anyone", NAME => 'CAPAUTH_DATA', EXPIRY => '+1y' ], }; { package TestAppAuthenticate; use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; sub setup { my $self = shift; $self->start_mode('one'); $self->run_modes( [qw(one two three)] ); $self->authen->protected_runmodes(qw(two three)); $self->authen->config($cap_options); } sub one { my $self = shift; return "ONE"; } sub two { my $self = shift; return "TWO"; } sub three { my $self = shift; return "THREE"; } sub post_login { my $self = shift; my $count = $self->param('post_login') || 0; $self->param( 'post_login' => $count + 1 ); } } $ENV{CGI_APP_RETURN_ONLY} = 1; # Authen::Simple { local $cap_options->{DRIVER} = [ 'Authen::Simple::Dummy', testuser => 'user1', testpass => '123' ]; my $query = CGI->new( { authen_username => 'user1', rm => 'two', authen_password => '123', } ); my $cgiapp = TestAppAuthenticate->new( QUERY => $query ); ok( !exists $cgiapp->authen->{drivers}, 'nothing cached yet' ); my @drivers = $cgiapp->authen->drivers; ok( scalar(@drivers) == 1, 'We should have just one driver' ); ok( scalar( @{ $cgiapp->authen->{drivers} } ) == 1, 'cached now' ); throws_ok {$cgiapp->run;} qr/Error executing class callback in prerun stage: The Authen::Simple::Dummy module is not installed/, "missing Authen::Simple"; } Build000755001750001750 014546072342 24375 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/local/lib/perl5/ModuleBase.pm100444001750001750 50366014546072342 26015 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/local/lib/perl5/Module/Build# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- # vim:ts=8:sw=2:et:sta:sts=2 package Module::Build::Base; use 5.006; use strict; use warnings; our $VERSION = '0.4234'; $VERSION = eval $VERSION; use Carp; use Cwd (); use File::Copy (); use File::Find (); use File::Path (); use File::Basename (); use File::Spec 0.82 (); use File::Compare (); use Module::Build::Dumper (); use Text::ParseWords (); use Module::Metadata; use Module::Build::Notes; use Module::Build::Config; use version; #################### Constructors ########################### sub new { my $self = shift()->_construct(@_); $self->{invoked_action} = $self->{action} ||= 'Build_PL'; $self->cull_args(@ARGV); die "Too early to specify a build action '$self->{action}'. Do 'Build $self->{action}' instead.\n" if $self->{action} && $self->{action} ne 'Build_PL'; $self->check_manifest; $self->auto_require; # All checks must run regardless if one fails, so no short circuiting! if( grep { !$_ } $self->check_prereq, $self->check_autofeatures ) { $self->log_warn(<dist_name eq 'Module-Build' || $ENV{PERL5_CPANPLUS_IS_RUNNING} || $ENV{PERL5_CPAN_IS_RUNNING} ) { $self->log_warn( "Run 'Build installdeps' to install missing prerequisites.\n\n" ); } } # record for later use in resume; $self->{properties}{_added_to_INC} = [ $self->_added_to_INC ]; $self->set_bundle_inc; $self->dist_name; $self->dist_version; $self->release_status; $self->_guess_module_name unless $self->module_name; $self->_find_nested_builds; return $self; } sub resume { my $package = shift; my $self = $package->_construct(@_); $self->read_config; my @added_earlier = @{ $self->{properties}{_added_to_INC} || [] }; @INC = ($self->_added_to_INC, @added_earlier, $self->_default_INC); # If someone called Module::Build->current() or # Module::Build->new_from_context() and the correct class to use is # actually a *subclass* of Module::Build, we may need to load that # subclass here and re-delegate the resume() method to it. unless ( $package->isa($self->build_class) ) { my $build_class = $self->build_class; my $config_dir = $self->config_dir || '_build'; my $build_lib = File::Spec->catdir( $config_dir, 'lib' ); unshift( @INC, $build_lib ); unless ( $build_class->can('new') ) { eval "require $build_class; 1" or die "Failed to re-load '$build_class': $@"; } return $build_class->resume(@_); } unless ($self->_perl_is_same($self->{properties}{perl})) { my $perl = $self->find_perl_interpreter; die(<<"DIEFATAL"); * FATAL ERROR: Perl interpreter mismatch. Configuration was initially created with '$self->{properties}{perl}' but we are now using '$perl'. You must run 'Build realclean' or 'make realclean' and re-configure. DIEFATAL } $self->cull_args(@ARGV); unless ($self->allow_mb_mismatch) { my $mb_version = $Module::Build::VERSION; if ( $mb_version ne $self->{properties}{mb_version} ) { $self->log_warn(<<"MISMATCH"); * WARNING: Configuration was initially created with Module::Build version '$self->{properties}{mb_version}' but we are now using version '$mb_version'. If errors occur, you must re-run the Build.PL or Makefile.PL script. MISMATCH } } $self->{invoked_action} = $self->{action} ||= 'build'; return $self; } sub new_from_context { my ($package, %args) = @_; $package->run_perl_script('Build.PL',[],[$package->unparse_args(\%args)]); return $package->resume; } sub current { # hmm, wonder what the right thing to do here is local @ARGV; return shift()->resume; } sub _construct { my ($package, %input) = @_; my $args = delete $input{args} || {}; my $config = delete $input{config} || {}; my $self = bless { args => {%$args}, config => Module::Build::Config->new(values => $config), properties => { base_dir => $package->cwd, mb_version => $Module::Build::VERSION, %input, }, phash => {}, stash => {}, # temporary caching, not stored in _build }, $package; $self->_set_defaults; my ($p, $ph) = ($self->{properties}, $self->{phash}); foreach (qw(notes config_data features runtime_params cleanup auto_features)) { my $file = File::Spec->catfile($self->config_dir, $_); $ph->{$_} = Module::Build::Notes->new(file => $file); $ph->{$_}->restore if -e $file; if (exists $p->{$_}) { my $vals = delete $p->{$_}; foreach my $k (sort keys %$vals) { $self->$_($k, $vals->{$k}); } } } # The following warning could be unnecessary if the user is running # an embedded perl, but there aren't too many of those around, and # embedded perls aren't usually used to install modules, and the # installation process sometimes needs to run external scripts # (e.g. to run tests). $p->{perl} = $self->find_perl_interpreter or $self->log_warn("Warning: Can't locate your perl binary"); my $blibdir = sub { File::Spec->catdir($p->{blib}, @_) }; $p->{bindoc_dirs} ||= [ $blibdir->("script") ]; $p->{libdoc_dirs} ||= [ $blibdir->("lib"), $blibdir->("arch") ]; $p->{dist_author} = [ $p->{dist_author} ] if defined $p->{dist_author} and not ref $p->{dist_author}; # Synonyms $p->{requires} = delete $p->{prereq} if defined $p->{prereq}; $p->{script_files} = delete $p->{scripts} if defined $p->{scripts}; # Convert to from shell strings to arrays for ('extra_compiler_flags', 'extra_linker_flags') { $p->{$_} = [ $self->split_like_shell($p->{$_}) ] if exists $p->{$_}; } # Convert to arrays for ('include_dirs') { $p->{$_} = [ $p->{$_} ] if exists $p->{$_} && !ref $p->{$_} } $self->add_to_cleanup( @{delete $p->{add_to_cleanup}} ) if $p->{add_to_cleanup}; return $self; } ################## End constructors ######################### sub log_info { my $self = shift; print @_ if ref($self) && ( $self->verbose || ! $self->quiet ); } sub log_verbose { my $self = shift; print @_ if ref($self) && $self->verbose; } sub log_debug { my $self = shift; print @_ if ref($self) && $self->debug; } sub log_warn { # Try to make our call stack invisible shift; if (@_ and $_[-1] !~ /\n$/) { my (undef, $file, $line) = caller(); warn @_, " at $file line $line.\n"; } else { warn @_; } } # install paths must be generated when requested to be sure all changes # to config (from various sources) are included sub _default_install_paths { my $self = shift; my $c = $self->{config}; my $p = {}; my @libstyle = $c->get('installstyle') ? File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5); my $arch = $c->get('archname'); my $version = $c->get('version'); my $bindoc = $c->get('installman1dir') || undef; my $libdoc = $c->get('installman3dir') || undef; my $binhtml = $c->get('installhtml1dir') || $c->get('installhtmldir') || undef; my $libhtml = $c->get('installhtml3dir') || $c->get('installhtmldir') || undef; $p->{install_sets} = { core => { lib => $c->get('installprivlib'), arch => $c->get('installarchlib'), bin => $c->get('installbin'), script => $c->get('installscript'), bindoc => $bindoc, libdoc => $libdoc, binhtml => $binhtml, libhtml => $libhtml, }, site => { lib => $c->get('installsitelib'), arch => $c->get('installsitearch'), bin => $c->get('installsitebin') || $c->get('installbin'), script => $c->get('installsitescript') || $c->get('installsitebin') || $c->get('installscript'), bindoc => $c->get('installsiteman1dir') || $bindoc, libdoc => $c->get('installsiteman3dir') || $libdoc, binhtml => $c->get('installsitehtml1dir') || $binhtml, libhtml => $c->get('installsitehtml3dir') || $libhtml, }, vendor => { lib => $c->get('installvendorlib'), arch => $c->get('installvendorarch'), bin => $c->get('installvendorbin') || $c->get('installbin'), script => $c->get('installvendorscript') || $c->get('installvendorbin') || $c->get('installscript'), bindoc => $c->get('installvendorman1dir') || $bindoc, libdoc => $c->get('installvendorman3dir') || $libdoc, binhtml => $c->get('installvendorhtml1dir') || $binhtml, libhtml => $c->get('installvendorhtml3dir') || $libhtml, }, }; $p->{original_prefix} = { core => $c->get('installprefixexp') || $c->get('installprefix') || $c->get('prefixexp') || $c->get('prefix') || '', site => $c->get('siteprefixexp'), vendor => $c->get('usevendorprefix') ? $c->get('vendorprefixexp') : '', }; $p->{original_prefix}{site} ||= $p->{original_prefix}{core}; # Note: you might be tempted to use $Config{installstyle} here # instead of hard-coding lib/perl5, but that's been considered and # (at least for now) rejected. `perldoc Config` has some wisdom # about it. $p->{install_base_relpaths} = { lib => ['lib', 'perl5'], arch => ['lib', 'perl5', $arch], bin => ['bin'], script => ['bin'], bindoc => ['man', 'man1'], libdoc => ['man', 'man3'], binhtml => ['html'], libhtml => ['html'], }; $p->{prefix_relpaths} = { core => { lib => [@libstyle], arch => [@libstyle, $version, $arch], bin => ['bin'], script => ['bin'], bindoc => ['man', 'man1'], libdoc => ['man', 'man3'], binhtml => ['html'], libhtml => ['html'], }, vendor => { lib => [@libstyle], arch => [@libstyle, $version, $arch], bin => ['bin'], script => ['bin'], bindoc => ['man', 'man1'], libdoc => ['man', 'man3'], binhtml => ['html'], libhtml => ['html'], }, site => { lib => [@libstyle, 'site_perl'], arch => [@libstyle, 'site_perl', $version, $arch], bin => ['bin'], script => ['bin'], bindoc => ['man', 'man1'], libdoc => ['man', 'man3'], binhtml => ['html'], libhtml => ['html'], }, }; return $p } sub _find_nested_builds { my $self = shift; my $r = $self->recurse_into or return; my ($file, @r); if (!ref($r) && $r eq 'auto') { local *DH; opendir DH, $self->base_dir or die "Can't scan directory " . $self->base_dir . " for nested builds: $!"; while (defined($file = readdir DH)) { my $subdir = File::Spec->catdir( $self->base_dir, $file ); next unless -d $subdir; push @r, $subdir if -e File::Spec->catfile( $subdir, 'Build.PL' ); } } $self->recurse_into(\@r); } sub cwd { return Cwd::cwd(); } sub _quote_args { # Returns a string that can become [part of] a command line with # proper quoting so that the subprocess sees this same list of args. my ($self, @args) = @_; my @quoted; for (@args) { if ( /^[^\s*?!\$<>;\\|'"\[\]\{\}]+$/ ) { # Looks pretty safe push @quoted, $_; } else { # XXX this will obviously have to improve - is there already a # core module lying around that does proper quoting? s/('+)/'"$1"'/g; push @quoted, qq('$_'); } } return join " ", @quoted; } sub _backticks { my ($self, @cmd) = @_; if ($self->have_forkpipe) { local *FH; my $pid = open *FH, "-|"; if ($pid) { return wantarray ? : join '', ; } else { die "Can't execute @cmd: $!\n" unless defined $pid; exec { $cmd[0] } @cmd; } } else { my $cmd = $self->_quote_args(@cmd); return `$cmd`; } } # Tells us whether the construct open($fh, '-|', @command) is # supported. It would probably be better to dynamically sense this. sub have_forkpipe { 1 } # Determine whether a given binary is the same as the perl # (configuration) that started this process. sub _perl_is_same { my ($self, $perl) = @_; my @cmd = ($perl); # When run from the perl core, @INC will include the directories # where perl is yet to be installed. We need to reference the # absolute path within the source distribution where it can find # it's Config.pm This also prevents us from picking up a Config.pm # from a different configuration that happens to be already # installed in @INC. if ($ENV{PERL_CORE}) { push @cmd, '-I' . File::Spec->catdir(File::Basename::dirname($perl), 'lib'); } push @cmd, qw(-MConfig=myconfig -e print -e myconfig); return $self->_backticks(@cmd) eq Config->myconfig; } # cache _discover_perl_interpreter() results { my $known_perl; sub find_perl_interpreter { my $self = shift; return $known_perl if defined($known_perl); return $known_perl = $self->_discover_perl_interpreter; } } # Returns the absolute path of the perl interpreter used to invoke # this process. The path is derived from $^X or $Config{perlpath}. On # some platforms $^X contains the complete absolute path of the # interpreter, on other it may contain a relative path, or simply # 'perl'. This can also vary depending on whether a path was supplied # when perl was invoked. Additionally, the value in $^X may omit the # executable extension on platforms that use one. It's a fatal error # if the interpreter can't be found because it can result in undefined # behavior by routines that depend on it (generating errors or # invoking the wrong perl.) sub _discover_perl_interpreter { my $proto = shift; my $c = ref($proto) ? $proto->{config} : 'Module::Build::Config'; my $perl = $^X; my $perl_basename = File::Basename::basename($perl); my @potential_perls; # Try 1, Check $^X for absolute path push( @potential_perls, $perl ) if File::Spec->file_name_is_absolute($perl); # Try 2, Check $^X for a valid relative path my $abs_perl = File::Spec->rel2abs($perl); push( @potential_perls, $abs_perl ); # Try 3, Last ditch effort: These two option use hackery to try to locate # a suitable perl. The hack varies depending on whether we are running # from an installed perl or an uninstalled perl in the perl source dist. if ($ENV{PERL_CORE}) { # Try 3.A, If we are in a perl source tree, running an uninstalled # perl, we can keep moving up the directory tree until we find our # binary. We wouldn't do this under any other circumstances. # CBuilder is also in the core, so it should be available here require ExtUtils::CBuilder; my $perl_src = Cwd::realpath( ExtUtils::CBuilder->perl_src ); if ( defined($perl_src) && length($perl_src) ) { my $uninstperl = File::Spec->rel2abs(File::Spec->catfile( $perl_src, $perl_basename )); push( @potential_perls, $uninstperl ); } } else { # Try 3.B, First look in $Config{perlpath}, then search the user's # PATH. We do not want to do either if we are running from an # uninstalled perl in a perl source tree. push( @potential_perls, $c->get('perlpath') ); push( @potential_perls, map File::Spec->catfile($_, $perl_basename), File::Spec->path() ); } # Now that we've enumerated the potential perls, it's time to test # them to see if any of them match our configuration, returning the # absolute path of the first successful match. my $exe = $c->get('exe_ext'); foreach my $thisperl ( @potential_perls ) { if (defined $exe) { $thisperl .= $exe unless $thisperl =~ m/$exe$/i; } if ( -f $thisperl && $proto->_perl_is_same($thisperl) ) { return $thisperl; } } # We've tried all alternatives, and didn't find a perl that matches # our configuration. Throw an exception, and list alternatives we tried. my @paths = map File::Basename::dirname($_), @potential_perls; die "Can't locate the perl binary used to run this script " . "in (@paths)\n"; } # Adapted from IPC::Cmd::can_run() sub find_command { my ($self, $command) = @_; if( File::Spec->file_name_is_absolute($command) ) { return $self->_maybe_command($command); } else { for my $dir ( File::Spec->path ) { my $abs = File::Spec->catfile($dir, $command); return $abs if $abs = $self->_maybe_command($abs); } } } # Copied from ExtUtils::MM_Unix::maybe_command sub _maybe_command { my($self,$file) = @_; return $file if -x $file && ! -d $file; return; } sub _is_interactive { return -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; # Pipe? } # NOTE this is a blocking operation if(-t STDIN) sub _is_unattended { my $self = shift; return $ENV{PERL_MM_USE_DEFAULT} || ( !$self->_is_interactive && eof STDIN ); } sub _readline { my $self = shift; return undef if $self->_is_unattended; my $answer = ; chomp $answer if defined $answer; return $answer; } sub prompt { my $self = shift; my $mess = shift or die "prompt() called without a prompt message"; # use a list to distinguish a default of undef() from no default my @def; @def = (shift) if @_; # use dispdef for output my @dispdef = scalar(@def) ? ('[', (defined($def[0]) ? $def[0] . ' ' : ''), ']') : (' ', ''); local $|=1; print "$mess ", @dispdef; if ( $self->_is_unattended && !@def ) { die <_readline(); if ( !defined($ans) # Ctrl-D or unattended or !length($ans) ) { # User hit return print "$dispdef[1]\n"; $ans = scalar(@def) ? $def[0] : ''; } return $ans; } sub y_n { my $self = shift; my ($mess, $def) = @_; die "y_n() called without a prompt message" unless $mess; die "Invalid default value: y_n() default must be 'y' or 'n'" if $def && $def !~ /^[yn]/i; my $answer; while (1) { # XXX Infinite or a large number followed by an exception ? $answer = $self->prompt(@_); return 1 if $answer =~ /^y/i; return 0 if $answer =~ /^n/i; local $|=1; print "Please answer 'y' or 'n'.\n"; } } sub current_action { shift->{action} } sub invoked_action { shift->{invoked_action} } sub notes { shift()->{phash}{notes}->access(@_) } sub config_data { shift()->{phash}{config_data}->access(@_) } sub runtime_params { shift->{phash}{runtime_params}->read( @_ ? shift : () ) } # Read-only sub auto_features { shift()->{phash}{auto_features}->access(@_) } sub features { my $self = shift; my $ph = $self->{phash}; if (@_) { my $key = shift; if ($ph->{features}->exists($key)) { return $ph->{features}->access($key, @_); } if (my $info = $ph->{auto_features}->access($key)) { my $disabled; for my $type ( @{$self->prereq_action_types} ) { next if $type eq 'description' || $type eq 'recommends' || ! exists $info->{$type}; my $prereqs = $info->{$type}; for my $modname ( sort keys %$prereqs ) { my $spec = $prereqs->{$modname}; my $status = $self->check_installed_status($modname, $spec); if ((!$status->{ok}) xor ($type =~ /conflicts$/)) { return 0; } if ( ! eval "require $modname; 1" ) { return 0; } } } return 1; } return $ph->{features}->access($key, @_); } # No args - get the auto_features & overlay the regular features my %features; my %auto_features = $ph->{auto_features}->access(); while (my ($name, $info) = each %auto_features) { my $failures = $self->prereq_failures($info); my $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/, keys %$failures ) ? 1 : 0; $features{$name} = $disabled ? 0 : 1; } %features = (%features, $ph->{features}->access()); return wantarray ? %features : \%features; } BEGIN { *feature = \&features } # Alias sub _mb_feature { my $self = shift; if (($self->module_name || '') eq 'Module::Build') { # We're building Module::Build itself, so ...::ConfigData isn't # valid, but $self->features() should be. return $self->feature(@_); } else { require Module::Build::ConfigData; return Module::Build::ConfigData->feature(@_); } } sub _warn_mb_feature_deps { my $self = shift; my $name = shift; $self->log_warn( "The '$name' feature is not available. Please install missing\n" . "feature dependencies and try again.\n". $self->_feature_deps_msg($name) . "\n" ); } sub add_build_element { my ($self, $elem) = @_; my $elems = $self->build_elements; push @$elems, $elem unless grep { $_ eq $elem } @$elems; } sub ACTION_config_data { my $self = shift; return unless $self->has_config_data; my $module_name = $self->module_name or die "The config_data feature requires that 'module_name' be set"; my $notes_name = $module_name . '::ConfigData'; # TODO: Customize name ??? my $notes_pm = File::Spec->catfile($self->blib, 'lib', split /::/, "$notes_name.pm"); return if $self->up_to_date(['Build.PL', $self->config_file('config_data'), $self->config_file('features') ], $notes_pm); $self->log_verbose("Writing config notes to $notes_pm\n"); File::Path::mkpath(File::Basename::dirname($notes_pm)); Module::Build::Notes->write_config_data ( file => $notes_pm, module => $module_name, config_module => $notes_name, config_data => scalar $self->config_data, feature => scalar $self->{phash}{features}->access(), auto_features => scalar $self->auto_features, ); } ######################################################################## { # enclosing these lexicals -- TODO my %valid_properties = ( __PACKAGE__, {} ); my %additive_properties; sub _mb_classes { my $class = ref($_[0]) || $_[0]; return ($class, $class->mb_parents); } sub valid_property { my ($class, $prop) = @_; return grep exists( $valid_properties{$_}{$prop} ), $class->_mb_classes; } sub valid_properties { return keys %{ shift->valid_properties_defaults() }; } sub valid_properties_defaults { my %out; for my $class (reverse shift->_mb_classes) { @out{ keys %{ $valid_properties{$class} } } = map { $_->() } values %{ $valid_properties{$class} }; } return \%out; } sub array_properties { map { exists $additive_properties{$_}->{ARRAY} ? @{$additive_properties{$_}->{ARRAY}} : () } shift->_mb_classes; } sub hash_properties { map { exists $additive_properties{$_}->{HASH} ? @{$additive_properties{$_}->{HASH}} : () } shift->_mb_classes; } sub add_property { my ($class, $property) = (shift, shift); die "Property '$property' already exists" if $class->valid_property($property); my %p = @_ == 1 ? ( default => shift ) : @_; my $type = ref $p{default}; $valid_properties{$class}{$property} = $type eq 'CODE' ? $p{default} : $type eq 'HASH' ? sub { return { %{ $p{default} } } } : $type eq 'ARRAY'? sub { return [ @{ $p{default} } ] } : sub { return $p{default} } ; push @{$additive_properties{$class}->{$type}}, $property if $type; unless ($class->can($property)) { # TODO probably should put these in a util package my $sub = $type eq 'HASH' ? _make_hash_accessor($property, \%p) : _make_accessor($property, \%p); no strict 'refs'; *{"$class\::$property"} = $sub; } return $class; } sub property_error { my $self = shift; die 'ERROR: ', @_; } sub _set_defaults { my $self = shift; # Set the build class. $self->{properties}{build_class} ||= ref $self; # If there was no orig_dir, set to the same as base_dir $self->{properties}{orig_dir} ||= $self->{properties}{base_dir}; my $defaults = $self->valid_properties_defaults; foreach my $prop (keys %$defaults) { $self->{properties}{$prop} = $defaults->{$prop} unless exists $self->{properties}{$prop}; } # Copy defaults for arrays any arrays. for my $prop ($self->array_properties) { $self->{properties}{$prop} = [@{$defaults->{$prop}}] unless exists $self->{properties}{$prop}; } # Copy defaults for arrays any hashes. for my $prop ($self->hash_properties) { $self->{properties}{$prop} = {%{$defaults->{$prop}}} unless exists $self->{properties}{$prop}; } } } # end enclosure ######################################################################## sub _make_hash_accessor { my ($property, $p) = @_; my $check = $p->{check} || sub { 1 }; return sub { my $self = shift; # This is only here to deprecate the historic accident of calling # properties as class methods - I suspect it only happens in our # test suite. unless(ref($self)) { carp("\n$property not a class method (@_)"); return; } my $x = $self->{properties}; return $x->{$property} unless @_; my $prop = $x->{$property}; if ( defined $_[0] && !ref $_[0] ) { if ( @_ == 1 ) { return exists $prop->{$_[0]} ? $prop->{$_[0]} : undef; } elsif ( @_ % 2 == 0 ) { my %new = (%{ $prop }, @_); local $_ = \%new; $x->{$property} = \%new if $check->($self); return $x->{$property}; } else { die "Unexpected arguments for property '$property'\n"; } } else { die "Unexpected arguments for property '$property'\n" if defined $_[0] && ref $_[0] ne 'HASH'; local $_ = $_[0]; $x->{$property} = shift if $check->($self); } }; } ######################################################################## sub _make_accessor { my ($property, $p) = @_; my $check = $p->{check} || sub { 1 }; return sub { my $self = shift; # This is only here to deprecate the historic accident of calling # properties as class methods - I suspect it only happens in our # test suite. unless(ref($self)) { carp("\n$property not a class method (@_)"); return; } my $x = $self->{properties}; return $x->{$property} unless @_; local $_ = $_[0]; $x->{$property} = shift if $check->($self); return $x->{$property}; }; } ######################################################################## # Add the default properties. __PACKAGE__->add_property(auto_configure_requires => 1); __PACKAGE__->add_property(blib => 'blib'); __PACKAGE__->add_property(build_class => 'Module::Build'); __PACKAGE__->add_property(build_elements => [qw(PL support pm xs share_dir pod script)]); __PACKAGE__->add_property(build_script => 'Build'); __PACKAGE__->add_property(build_bat => 0); __PACKAGE__->add_property(bundle_inc => []); __PACKAGE__->add_property(bundle_inc_preload => []); __PACKAGE__->add_property(config_dir => '_build'); __PACKAGE__->add_property(dynamic_config => 1); __PACKAGE__->add_property(include_dirs => []); __PACKAGE__->add_property(license => 'unknown'); __PACKAGE__->add_property(metafile => 'META.yml'); __PACKAGE__->add_property(mymetafile => 'MYMETA.yml'); __PACKAGE__->add_property(metafile2 => 'META.json'); __PACKAGE__->add_property(mymetafile2 => 'MYMETA.json'); __PACKAGE__->add_property(recurse_into => []); __PACKAGE__->add_property(use_rcfile => 1); __PACKAGE__->add_property(create_packlist => 1); __PACKAGE__->add_property(allow_mb_mismatch => 0); __PACKAGE__->add_property(config => undef); __PACKAGE__->add_property(test_file_exts => ['.t']); __PACKAGE__->add_property(use_tap_harness => 0); __PACKAGE__->add_property(cpan_client => 'cpan'); __PACKAGE__->add_property(tap_harness_args => {}); __PACKAGE__->add_property(pureperl_only => 0); __PACKAGE__->add_property(allow_pureperl => 0); __PACKAGE__->add_property( 'installdirs', default => 'site', check => sub { return 1 if /^(core|site|vendor)$/; return shift->property_error( $_ eq 'perl' ? 'Perhaps you meant installdirs to be "core" rather than "perl"?' : 'installdirs must be one of "core", "site", or "vendor"' ); return shift->property_error("Perhaps you meant 'core'?") if $_ eq 'perl'; return 0; }, ); { __PACKAGE__->add_property(html_css => ''); } { my @prereq_action_types = qw(requires build_requires test_requires conflicts recommends); foreach my $type (@prereq_action_types) { __PACKAGE__->add_property($type => {}); } __PACKAGE__->add_property(prereq_action_types => \@prereq_action_types); } __PACKAGE__->add_property($_ => {}) for qw( get_options install_base_relpaths install_path install_sets meta_add meta_merge original_prefix prefix_relpaths configure_requires ); __PACKAGE__->add_property($_) for qw( PL_files autosplit base_dir bindoc_dirs c_source cover create_license create_makefile_pl create_readme debugger destdir dist_abstract dist_author dist_name dist_suffix dist_version dist_version_from extra_compiler_flags extra_linker_flags has_config_data install_base libdoc_dirs magic_number mb_version module_name needs_compiler orig_dir perl pm_files pod_files pollute prefix program_name quiet recursive_test_files release_status script_files scripts share_dir sign test_files verbose debug xs_files extra_manify_args ); sub config { my $self = shift; my $c = ref($self) ? $self->{config} : 'Module::Build::Config'; return $c->all_config unless @_; my $key = shift; return $c->get($key) unless @_; my $val = shift; return $c->set($key => $val); } sub mb_parents { # Code borrowed from Class::ISA. my @in_stack = (shift); my %seen = ($in_stack[0] => 1); my ($current, @out); while (@in_stack) { next unless defined($current = shift @in_stack) && $current->isa('Module::Build::Base'); push @out, $current; next if $current eq 'Module::Build::Base'; no strict 'refs'; unshift @in_stack, map { my $c = $_; # copy, to avoid being destructive substr($c,0,2) = "main::" if substr($c,0,2) eq '::'; # Canonize the :: -> main::, ::foo -> main::foo thing. # Should I ever canonize the Foo'Bar = Foo::Bar thing? $seen{$c}++ ? () : $c; } @{"$current\::ISA"}; # I.e., if this class has any parents (at least, ones I've never seen # before), push them, in order, onto the stack of classes I need to # explore. } shift @out; return @out; } sub extra_linker_flags { shift->_list_accessor('extra_linker_flags', @_) } sub extra_compiler_flags { shift->_list_accessor('extra_compiler_flags', @_) } sub _list_accessor { (my $self, local $_) = (shift, shift); my $p = $self->{properties}; $p->{$_} = [@_] if @_; $p->{$_} = [] unless exists $p->{$_}; return ref($p->{$_}) ? $p->{$_} : [$p->{$_}]; } # XXX Problem - if Module::Build is loaded from a different directory, # it'll look for (and perhaps destroy/create) a _build directory. sub subclass { my ($pack, %opts) = @_; my $build_dir = '_build'; # XXX The _build directory is ostensibly settable by the user. Shouldn't hard-code here. $pack->delete_filetree($build_dir) if -e $build_dir; die "Must provide 'code' or 'class' option to subclass()\n" unless $opts{code} or $opts{class}; $opts{code} ||= ''; $opts{class} ||= 'MyModuleBuilder'; my $filename = File::Spec->catfile($build_dir, 'lib', split '::', $opts{class}) . '.pm'; my $filedir = File::Basename::dirname($filename); $pack->log_verbose("Creating custom builder $filename in $filedir\n"); File::Path::mkpath($filedir); die "Can't create directory $filedir: $!" unless -d $filedir; open(my $fh, '>', $filename) or die "Can't create $filename: $!"; print $fh <catdir(File::Spec->rel2abs($build_dir), 'lib'); eval "use $opts{class}"; die $@ if $@; return $opts{class}; } sub _guess_module_name { my $self = shift; my $p = $self->{properties}; return if $p->{module_name}; if ( $p->{dist_version_from} && -e $p->{dist_version_from} ) { my $mi = Module::Metadata->new_from_file($self->dist_version_from); $p->{module_name} = $mi->name; } else { my $mod_path = my $mod_name = $p->{dist_name}; $mod_name =~ s{-}{::}g; $mod_path =~ s{-}{/}g; $mod_path .= ".pm"; if ( -e $mod_path || -e "lib/$mod_path" ) { $p->{module_name} = $mod_name; } else { $self->log_warn( << 'END_WARN' ); No 'module_name' was provided and it could not be inferred from other properties. This will prevent a packlist from being written for this file. Please set either 'module_name' or 'dist_version_from' in Build.PL. END_WARN } } } sub dist_name { my $self = shift; my $p = $self->{properties}; my $me = 'dist_name'; return $p->{$me} if defined $p->{$me}; die "Can't determine distribution name, must supply either 'dist_name' or 'module_name' parameter" unless $self->module_name; ($p->{$me} = $self->module_name) =~ s/::/-/g; return $p->{$me}; } sub release_status { my ($self) = @_; my $me = 'release_status'; my $p = $self->{properties}; if ( ! defined $p->{$me} ) { $p->{$me} = $self->_is_dev_version ? 'testing' : 'stable'; } unless ( $p->{$me} =~ qr/\A(?:stable|testing|unstable)\z/ ) { die "Illegal value '$p->{$me}' for $me\n"; } if ( $p->{$me} eq 'stable' && $self->_is_dev_version ) { my $version = $self->dist_version; die "Illegal value '$p->{$me}' with version '$version'\n"; } return $p->{$me}; } sub dist_suffix { my ($self) = @_; my $p = $self->{properties}; my $me = 'dist_suffix'; return $p->{$me} if defined $p->{$me}; if ( $self->release_status eq 'stable' ) { $p->{$me} = ""; } else { # non-stable release but non-dev version number needs '-TRIAL' appended $p->{$me} = $self->_is_dev_version ? "" : "TRIAL" ; } return $p->{$me}; } sub dist_version_from { my ($self) = @_; my $p = $self->{properties}; my $me = 'dist_version_from'; if ($self->module_name) { $p->{$me} ||= join( '/', 'lib', split(/::/, $self->module_name) ) . '.pm'; } return $p->{$me} || undef; } sub dist_version { my ($self) = @_; my $p = $self->{properties}; my $me = 'dist_version'; return $p->{$me} if defined $p->{$me}; if ( my $dist_version_from = $self->dist_version_from ) { my $version_from = File::Spec->catfile( split( qr{/}, $dist_version_from ) ); my $pm_info = Module::Metadata->new_from_file( $version_from ) or die "Can't find file $version_from to determine version"; #$p->{$me} is undef here $p->{$me} = $self->normalize_version( $pm_info->version() ); unless (defined $p->{$me}) { die "Can't determine distribution version from $version_from"; } } die ("Can't determine distribution version, must supply either 'dist_version',\n". "'dist_version_from', or 'module_name' parameter") unless defined $p->{$me}; return $p->{$me}; } sub _is_dev_version { my ($self) = @_; my $dist_version = $self->dist_version; my $version_obj = eval { version->new( $dist_version ) }; # assume it's normal if the version string is fatal -- in this case # the author might be doing something weird so should play along and # assume they'll specify all necessary behavior return $@ ? 0 : $version_obj->is_alpha; } sub dist_author { shift->_pod_parse('author') } sub dist_abstract { shift->_pod_parse('abstract') } sub _pod_parse { my ($self, $part) = @_; my $p = $self->{properties}; my $member = "dist_$part"; return $p->{$member} if defined $p->{$member}; my $docfile = $self->_main_docfile or return; open(my $fh, '<', $docfile) or return; require Module::Build::PodParser; my $parser = Module::Build::PodParser->new(fh => $fh); my $method = "get_$part"; return $p->{$member} = $parser->$method(); } sub version_from_file { # Method provided for backwards compatibility return Module::Metadata->new_from_file($_[1])->version(); } sub find_module_by_name { # Method provided for backwards compatibility return Module::Metadata->find_module_by_name(@_[1,2]); } { # $unlink_list_for_pid{$$} = [ ... ] my %unlink_list_for_pid; sub _unlink_on_exit { my $self = shift; for my $f ( @_ ) { push @{$unlink_list_for_pid{$$}}, $f if -f $f; } return 1; } END { for my $f ( map glob($_), @{ $unlink_list_for_pid{$$} || [] } ) { next unless -e $f; File::Path::rmtree($f, 0, 0); } } } sub add_to_cleanup { my $self = shift; my %files = map {$self->localize_file_path($_), 1} @_; $self->{phash}{cleanup}->write(\%files); } sub cleanup { my $self = shift; my $all = $self->{phash}{cleanup}->read; return wantarray ? sort keys %$all : keys %$all; } sub config_file { my $self = shift; return unless -d $self->config_dir; return File::Spec->catfile($self->config_dir, @_); } sub read_config { my ($self) = @_; my $file = $self->config_file('build_params') or die "Can't find 'build_params' in " . $self->config_dir; open(my $fh, '<', $file) or die "Can't read '$file': $!"; my $ref = eval do {local $/; <$fh>}; die if $@; close $fh; my $c; ($self->{args}, $c, $self->{properties}) = @$ref; $self->{config} = Module::Build::Config->new(values => $c); } sub has_config_data { my $self = shift; return scalar grep $self->{phash}{$_}->has_data(), qw(config_data features auto_features); } sub _write_data { my ($self, $filename, $data) = @_; my $file = $self->config_file($filename); open(my $fh, '>', $file) or die "Can't create '$file': $!"; unless (ref($data)) { # e.g. magicnum print $fh $data; return; } print {$fh} Module::Build::Dumper->_data_dump($data); close $fh; } sub write_config { my ($self) = @_; File::Path::mkpath($self->{properties}{config_dir}); -d $self->{properties}{config_dir} or die "Can't mkdir $self->{properties}{config_dir}: $!"; my @items = @{ $self->prereq_action_types }; $self->_write_data('prereqs', { map { $_, $self->$_() } @items }); $self->_write_data('build_params', [$self->{args}, $self->{config}->values_set, $self->{properties}]); # Set a new magic number and write it to a file $self->_write_data('magicnum', $self->magic_number(int rand 1_000_000)); $self->{phash}{$_}->write() foreach qw(notes cleanup features auto_features config_data runtime_params); } { # packfile map -- keys are guts of regular expressions; If they match, # values are module names corresponding to the packlist my %packlist_map = ( '^File::Spec' => 'Cwd', '^Devel::AssertOS' => 'Devel::CheckOS', ); sub _find_packlist { my ($self, $inst, $mod) = @_; my $lookup = $mod; my $packlist = eval { $inst->packlist($lookup) }; if ( ! $packlist ) { # try from packlist_map while ( my ($re, $new_mod) = each %packlist_map ) { if ( $mod =~ qr/$re/ ) { $lookup = $new_mod; $packlist = eval { $inst->packlist($lookup) }; last; } } } return $packlist ? $lookup : undef; } sub set_bundle_inc { my $self = shift; my $bundle_inc = $self->{properties}{bundle_inc}; my $bundle_inc_preload = $self->{properties}{bundle_inc_preload}; # We're in author mode if inc::latest is loaded, but not from cwd return unless inc::latest->can('loaded_modules'); require ExtUtils::Installed; # ExtUtils::Installed is buggy about finding additions to default @INC my $inst = eval { ExtUtils::Installed->new(extra_libs => [@INC]) }; if ($@) { $self->log_warn( << "EUI_ERROR" ); Bundling in inc/ is disabled because ExtUtils::Installed could not create a list of your installed modules. Here is the error: $@ EUI_ERROR return; } my @bundle_list = map { [ $_, 0 ] } inc::latest->loaded_modules; # XXX TODO: Need to get ordering of prerequisites correct so they are # are loaded in the right order. Use an actual tree?! while( @bundle_list ) { my ($mod, $prereq) = @{ shift @bundle_list }; # XXX TODO: Append prereqs to list # skip if core or already in bundle or preload lists # push @bundle_list, [$_, 1] for prereqs() # Locate packlist for bundling my $lookup = $self->_find_packlist($inst,$mod); if ( ! $lookup ) { # XXX Really needs a more helpful error message here die << "NO_PACKLIST"; Could not find a packlist for '$mod'. If it's a core module, try force installing it from CPAN. NO_PACKLIST } else { push @{ $prereq ? $bundle_inc_preload : $bundle_inc }, $lookup; } } } # sub check_bundling } sub check_autofeatures { my ($self) = @_; my $features = $self->auto_features; return 1 unless %$features; # TODO refactor into ::Util my $longest = sub { my @str = @_ or croak("no strings given"); my @len = map({length($_)} @str); my $max = 0; my $longest; for my $i (0..$#len) { ($max, $longest) = ($len[$i], $str[$i]) if($len[$i] > $max); } return($longest); }; my $max_name_len = length($longest->(keys %$features)); my ($num_disabled, $log_text) = (0, "\nChecking optional features...\n"); for my $name ( sort keys %$features ) { $log_text .= $self->_feature_deps_msg($name, $max_name_len); } $num_disabled = () = $log_text =~ /disabled/g; # warn user if features disabled if ( $num_disabled ) { $self->log_warn( $log_text ); return 0; } else { $self->log_verbose( $log_text ); return 1; } } sub _feature_deps_msg { my ($self, $name, $max_name_len) = @_; $max_name_len ||= length $name; my $features = $self->auto_features; my $info = $features->{$name}; my $feature_text = "$name" . '.' x ($max_name_len - length($name) + 4); my ($log_text, $disabled) = ('',''); if ( my $failures = $self->prereq_failures($info) ) { $disabled = grep( /^(?:\w+_)?(?:requires|conflicts)$/, keys %$failures ) ? 1 : 0; $feature_text .= $disabled ? "disabled\n" : "enabled\n"; for my $type ( @{ $self->prereq_action_types } ) { next unless exists $failures->{$type}; $feature_text .= " $type:\n"; my $prereqs = $failures->{$type}; for my $module ( sort keys %$prereqs ) { my $status = $prereqs->{$module}; my $required = ($type =~ /^(?:\w+_)?(?:requires|conflicts)$/) ? 1 : 0; my $prefix = ($required) ? '!' : '*'; $feature_text .= " $prefix $status->{message}\n"; } } } else { $feature_text .= "enabled\n"; } $log_text .= $feature_text if $disabled || $self->verbose; return $log_text; } # Automatically detect configure_requires prereqs sub auto_config_requires { my ($self) = @_; my $p = $self->{properties}; # add current Module::Build to configure_requires if there # isn't one already specified (but not ourself, so we're not circular) if ( $self->dist_name ne 'Module-Build' && $self->auto_configure_requires && ! exists $p->{configure_requires}{'Module::Build'} ) { (my $ver = $VERSION) =~ s/^(\d+\.\d\d).*$/$1/; # last major release only $self->log_warn(< { 'Module::Build' => $ver } EOM $self->_add_prereq('configure_requires', 'Module::Build', $ver); } # if we're in author mode, add inc::latest modules to # configure_requires if not already set. If we're not in author mode # then configure_requires will have been satisfied, or we'll just # live with what we've bundled if ( inc::latest->can('loaded_module') ) { for my $mod ( inc::latest->loaded_modules ) { next if exists $p->{configure_requires}{$mod}; $self->_add_prereq('configure_requires', $mod, $mod->VERSION); } } return; } # Automatically detect and add prerequisites based on configuration sub auto_require { my ($self) = @_; my $p = $self->{properties}; # If needs_compiler is not explicitly set, automatically set it # If set, we need ExtUtils::CBuilder (and a compiler) my $xs_files = $self->find_xs_files; if ( ! defined $p->{needs_compiler} ) { if ( $self->pureperl_only && $self->allow_pureperl ) { $self->needs_compiler( 0 ); } else { $self->needs_compiler( keys %$xs_files || ( defined $self->c_source && ( ref($self->c_source) ne 'ARRAY' || @{$self->c_source} ) ) ); } } if ($self->needs_compiler) { $self->_add_prereq('build_requires', 'ExtUtils::CBuilder', 0); if ( ! $self->have_c_compiler ) { $self->log_warn(<<'EOM'); Warning: ExtUtils::CBuilder not installed or no compiler detected Proceeding with configuration, but compilation may fail during Build EOM } } # If using share_dir, require File::ShareDir if ( $self->share_dir ) { $self->_add_prereq( 'requires', 'File::ShareDir', '1.00' ); } return; } sub _add_prereq { my ($self, $type, $module, $version) = @_; my $p = $self->{properties}; $version = 0 unless defined $version; if ( exists $p->{$type}{$module} ) { return if $self->compare_versions( $version, '<=', $p->{$type}{$module} ); } $self->log_verbose("Adding to $type\: $module => $version\n"); $p->{$type}{$module} = $version; return 1; } sub prereq_failures { my ($self, $info) = @_; my @types = @{ $self->prereq_action_types }; $info ||= {map {$_, $self->$_()} @types}; my $out; foreach my $type (@types) { my $prereqs = $info->{$type}; for my $modname ( keys %$prereqs ) { my $spec = $prereqs->{$modname}; my $status = $self->check_installed_status($modname, $spec); if ($type =~ /^(?:\w+_)?conflicts$/) { next if !$status->{ok}; $status->{conflicts} = delete $status->{need}; $status->{message} = "$modname ($status->{have}) conflicts with this distribution"; } elsif ($type =~ /^(?:\w+_)?recommends$/) { next if $status->{ok}; $status->{message} = (!ref($status->{have}) && $status->{have} eq '' ? "$modname is not installed" : "$modname ($status->{have}) is installed, but we prefer to have $spec"); } else { next if $status->{ok}; } $out->{$type}{$modname} = $status; } } return $out; } # returns a hash of defined prerequisites; i.e. only prereq types with values sub _enum_prereqs { my $self = shift; my %prereqs; foreach my $type ( @{ $self->prereq_action_types } ) { if ( $self->can( $type ) ) { my $prereq = $self->$type() || {}; $prereqs{$type} = $prereq if %$prereq; } } return \%prereqs; } sub check_prereq { my $self = shift; # Check to see if there are any prereqs to check my $info = $self->_enum_prereqs; return 1 unless $info; my $log_text = "Checking prerequisites...\n"; my $failures = $self->prereq_failures($info); if ( $failures ) { $self->log_warn($log_text); for my $type ( @{ $self->prereq_action_types } ) { my $prereqs = $failures->{$type}; $self->log_warn(" ${type}:\n") if keys %$prereqs; for my $module ( sort keys %$prereqs ) { my $status = $prereqs->{$module}; my $prefix = ($type =~ /^(?:\w+_)?recommends$/) ? "* " : "! "; $self->log_warn(" $prefix $status->{message}\n"); } } return 0; } else { $self->log_verbose($log_text . "Looks good\n\n"); return 1; } } sub perl_version { my ($self) = @_; # Check the current perl interpreter # It's much more convenient to use $] here than $^V, but 'man # perlvar' says I'm not supposed to. Bloody tyrant. return $^V ? $self->perl_version_to_float(sprintf "%vd", $^V) : $]; } sub perl_version_to_float { my ($self, $version) = @_; return $version if grep( /\./, $version ) < 2; $version =~ s/\./../; $version =~ s/\.(\d+)/sprintf '%03d', $1/eg; return $version; } sub _parse_conditions { my ($self, $spec) = @_; return ">= 0" if not defined $spec; if ($spec =~ /^\s*([\w.]+)\s*$/) { # A plain number, maybe with dots, letters, and underscores return (">= $spec"); } else { return split /\s*,\s*/, $spec; } } sub try_require { my ($self, $modname, $spec) = @_; my $status = $self->check_installed_status($modname, defined($spec) ? $spec : 0); return unless $status->{ok}; my $path = $modname; $path =~ s{::}{/}g; $path .= ".pm"; if ( defined $INC{$path} ) { return 1; } elsif ( exists $INC{$path} ) { # failed before, don't try again return; } else { return eval "require $modname"; } } sub check_installed_status { my ($self, $modname, $spec) = @_; my %status = (need => $spec); if ($modname eq 'perl') { $status{have} = $self->perl_version; } elsif (eval { no strict; $status{have} = ${"${modname}::VERSION"} }) { # Don't try to load if it's already loaded } else { my $pm_info = Module::Metadata->new_from_module( $modname ); unless (defined( $pm_info )) { @status{ qw(have message) } = ('', "$modname is not installed"); return \%status; } $status{have} = eval { $pm_info->version() }; if ($spec and !defined($status{have})) { @status{ qw(have message) } = (undef, "Couldn't find a \$VERSION in prerequisite $modname"); return \%status; } } my @conditions = $self->_parse_conditions($spec); foreach (@conditions) { my ($op, $version) = /^\s* (<=?|>=?|==|!=) \s* ([\w.]+) \s*$/x or die "Invalid prerequisite condition '$_' for $modname"; $version = $self->perl_version_to_float($version) if $modname eq 'perl'; next if $op eq '>=' and !$version; # Module doesn't have to actually define a $VERSION unless ($self->compare_versions( $status{have}, $op, $version )) { $status{message} = "$modname ($status{have}) is installed, but we need version $op $version"; return \%status; } } $status{ok} = 1; return \%status; } sub compare_versions { my $self = shift; my ($v1, $op, $v2) = @_; $v1 = version->new($v1) unless eval { $v1->isa('version') }; my $eval_str = "\$v1 $op \$v2"; my $result = eval $eval_str; $self->log_warn("error comparing versions: '$eval_str' $@") if $@; return $result; } # I wish I could set $! to a string, but I can't, so I use $@ sub check_installed_version { my ($self, $modname, $spec) = @_; my $status = $self->check_installed_status($modname, $spec); if ($status->{ok}) { return $status->{have} if $status->{have} and "$status->{have}" ne ''; return '0 but true'; } $@ = $status->{message}; return 0; } sub make_executable { # Perl's chmod() is mapped to useful things on various non-Unix # platforms, so we use it in the base class even though it looks # Unixish. my $self = shift; foreach (@_) { my $current_mode = (stat $_)[2]; chmod $current_mode | oct(111), $_; } } sub is_executable { # We assume this does the right thing on generic platforms, though # we do some other more specific stuff on Unixish platforms. my ($self, $file) = @_; return -x $file; } sub _startperl { shift()->config('startperl') } # Return any directories in @INC which are not in the default @INC for # this perl. For example, stuff passed in with -I or loaded with "use lib". sub _added_to_INC { my $self = shift; my %seen; $seen{$_}++ foreach $self->_default_INC; return grep !$seen{$_}++, @INC; } # Determine the default @INC for this Perl { my @default_inc; # Memoize sub _default_INC { my $self = shift; return @default_inc if @default_inc; local $ENV{PERL5LIB}; # this is not considered part of the default. my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter; my @inc = $self->_backticks($perl, '-le', 'print for @INC'); chomp @inc; return @default_inc = @inc; } } sub print_build_script { my ($self, $fh) = @_; my $build_package = $self->build_class; my $closedata=""; my $config_requires; if ( -f $self->metafile ) { my $meta = eval { $self->read_metafile( $self->metafile ) }; $config_requires = $meta && $meta->{prereqs}{configure}{requires}{'Module::Build'}; } $config_requires ||= 0; my %q = map {$_, $self->$_()} qw(config_dir base_dir); $q{base_dir} = Win32::GetShortPathName($q{base_dir}) if $self->is_windowsish; $q{magic_numfile} = $self->config_file('magicnum'); my @myINC = $self->_added_to_INC; for (@myINC, values %q) { $_ = File::Spec->canonpath( $_ ) unless $self->is_vmsish; s/([\\\'])/\\$1/g; } my $quoted_INC = join ",\n", map " '$_'", @myINC; my $shebang = $self->_startperl; my $magic_number = $self->magic_number; my $dot_in_inc_code = $INC[-1] eq '.' ? <<'END' : ''; if ($INC[-1] ne '.') { push @INC, '.'; } END print $fh <; close \$FH; return \$filenum == $magic_number; } my \$progname; my \$orig_dir; BEGIN { \$^W = 1; # Use warnings \$progname = basename(\$0); \$orig_dir = Cwd::cwd(); my \$base_dir = '$q{base_dir}'; if (!magic_number_matches()) { unless (chdir(\$base_dir)) { die ("Couldn't chdir(\$base_dir), aborting\\n"); } unless (magic_number_matches()) { die ("Configuration seems to be out of date, please re-run 'perl Build.PL' again.\\n"); } } unshift \@INC, ( $quoted_INC ); $dot_in_inc_code } close(*DATA) unless eof(*DATA); # ensure no open handles to this script use $build_package; Module::Build->VERSION(q{$config_requires}); # Some platforms have problems setting \$^X in shebang contexts, fix it up here \$^X = Module::Build->find_perl_interpreter; if (-e 'Build.PL' and not $build_package->up_to_date('Build.PL', \$progname)) { warn "Warning: Build.PL has been altered. You may need to run 'perl Build.PL' again.\\n"; } # This should have just enough arguments to be able to bootstrap the rest. my \$build = $build_package->resume ( properties => { config_dir => '$q{config_dir}', orig_dir => \$orig_dir, }, ); \$build->dispatch; EOF } sub create_mymeta { my ($self) = @_; my ($meta_obj, $mymeta); my @metafiles = ( $self->metafile2, $self->metafile, ); my @mymetafiles = ( $self->mymetafile2, $self->mymetafile, ); # cleanup old MYMETA for my $f ( @mymetafiles ) { if ( $self->delete_filetree($f) ) { $self->log_verbose("Removed previous '$f'\n"); } } # Try loading META.json or META.yml if ( $self->try_require("CPAN::Meta", "2.142060") ) { for my $file ( @metafiles ) { next unless -f $file; $meta_obj = eval { CPAN::Meta->load_file($file, { lazy_validation => 0 }) }; last if $meta_obj; } } # maybe get a copy in spec v2 format (regardless of original source) my $mymeta_obj; if ($meta_obj) { # if we have metadata, just update it my %updated = ( %{ $meta_obj->as_struct({ version => 2.0 }) }, prereqs => $self->_normalize_prereqs, dynamic_config => 0, generated_by => "Module::Build version $Module::Build::VERSION", ); $mymeta_obj = CPAN::Meta->new( \%updated, { lazy_validation => 0 } ); } else { $mymeta_obj = $self->_get_meta_object(quiet => 0, dynamic => 0, fatal => 1, auto => 0); } my @created = $self->_write_meta_files( $mymeta_obj, 'MYMETA' ); $self->log_warn("Could not create MYMETA files\n") unless @created; return 1; } sub create_build_script { my ($self) = @_; $self->write_config; $self->create_mymeta; # Create Build my ($build_script, $dist_name, $dist_version) = map $self->$_(), qw(build_script dist_name dist_version); if ( $self->delete_filetree($build_script) ) { $self->log_verbose("Removed previous script '$build_script'\n"); } $self->log_info("Creating new '$build_script' script for ", "'$dist_name' version '$dist_version'\n"); open(my $fh, '>', $build_script) or die "Can't create '$build_script': $!"; $self->print_build_script($fh); close $fh; $self->make_executable($build_script); return 1; } sub check_manifest { my $self = shift; return unless -e 'MANIFEST'; # Stolen nearly verbatim from MakeMaker. But ExtUtils::Manifest # could easily be re-written into a modern Perl dialect. require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean. local ($^W, $ExtUtils::Manifest::Quiet) = (0,1); $self->log_verbose("Checking whether your kit is complete...\n"); if (my @missed = ExtUtils::Manifest::manicheck()) { $self->log_warn("WARNING: the following files are missing in your kit:\n", "\t", join("\n\t", @missed), "\n", "Please inform the author.\n\n"); } else { $self->log_verbose("Looks good\n\n"); } } sub dispatch { my $self = shift; local $self->{_completed_actions} = {}; if (@_) { my ($action, %p) = @_; my $args = $p{args} ? delete($p{args}) : {}; local $self->{invoked_action} = $action; local $self->{args} = {%{$self->{args}}, %$args}; local $self->{properties} = {%{$self->{properties}}, %p}; return $self->_call_action($action); } die "No build action specified" unless $self->{action}; local $self->{invoked_action} = $self->{action}; $self->_call_action($self->{action}); } sub _call_action { my ($self, $action) = @_; return if $self->{_completed_actions}{$action}++; local $self->{action} = $action; my $method = $self->can_action( $action ); die "No action '$action' defined, try running the 'help' action.\n" unless $method; $self->log_debug("Starting ACTION_$action\n"); my $rc = $self->$method(); $self->log_debug("Finished ACTION_$action\n"); return $rc; } sub can_action { my ($self, $action) = @_; return $self->can( "ACTION_$action" ); } # cuts the user-specified options out of the command-line args sub cull_options { my $self = shift; my (@argv) = @_; # XXX is it even valid to call this as a class method? return({}, @argv) unless(ref($self)); # no object my $specs = $self->get_options; return({}, @argv) unless($specs and %$specs); # no user options require Getopt::Long; # XXX Should we let Getopt::Long handle M::B's options? That would # be easy-ish to add to @specs right here, but wouldn't handle options # passed without "--" as M::B currently allows. We might be able to # get around this by setting the "prefix_pattern" Configure option. my @specs; my $args = {}; # Construct the specifications for GetOptions. foreach my $k (sort keys %$specs) { my $v = $specs->{$k}; # Throw an error if specs conflict with our own. die "Option specification '$k' conflicts with a " . ref $self . " option of the same name" if $self->valid_property($k); push @specs, $k . (defined $v->{type} ? $v->{type} : ''); push @specs, $v->{store} if exists $v->{store}; $args->{$k} = $v->{default} if exists $v->{default}; } local @ARGV = @argv; # No other way to dupe Getopt::Long # Get the options values and return them. # XXX Add option to allow users to set options? if ( @specs ) { Getopt::Long::Configure('pass_through'); Getopt::Long::GetOptions($args, @specs); } return $args, @ARGV; } sub unparse_args { my ($self, $args) = @_; my @out; foreach my $k (sort keys %$args) { my $v = $args->{$k}; push @out, (ref $v eq 'HASH' ? map {+"--$k", "$_=$v->{$_}"} sort keys %$v : ref $v eq 'ARRAY' ? map {+"--$k", $_} @$v : ("--$k", $v)); } return @out; } sub args { my $self = shift; return wantarray ? %{ $self->{args} } : $self->{args} unless @_; my $key = shift; $self->{args}{$key} = shift if @_; return $self->{args}{$key}; } # allows select parameters (with underscores) to be spoken with dashes # when used as command-line options sub _translate_option { my $self = shift; my $opt = shift; (my $tr_opt = $opt) =~ tr/-/_/; return $tr_opt if grep $tr_opt =~ /^(?:no_?)?$_$/, qw( create_license create_makefile_pl create_readme extra_compiler_flags extra_linker_flags install_base install_path meta_add meta_merge test_files use_rcfile use_tap_harness tap_harness_args cpan_client pureperl_only allow_pureperl ); # normalize only selected option names return $opt; } my %singular_argument = map { ($_ => 1) } qw/install_base prefix destdir installdirs verbose quiet uninst debug sign/; sub _read_arg { my ($self, $args, $key, $val) = @_; $key = $self->_translate_option($key); if ( exists $args->{$key} and not $singular_argument{$key} ) { $args->{$key} = [ $args->{$key} ] unless ref $args->{$key}; push @{$args->{$key}}, $val; } else { $args->{$key} = $val; } } # decide whether or not an option requires/has an operand sub _optional_arg { my $self = shift; my $opt = shift; my $argv = shift; $opt = $self->_translate_option($opt); my @bool_opts = qw( build_bat create_license create_readme pollute quiet uninst use_rcfile verbose debug sign use_tap_harness pureperl_only allow_pureperl ); # inverted boolean options; eg --noverbose or --no-verbose # converted to proper name & returned with false value (verbose, 0) if ( grep $opt =~ /^no[-_]?$_$/, @bool_opts ) { $opt =~ s/^no-?//; return ($opt, 0); } # non-boolean option; return option unchanged along with its argument return ($opt, shift(@$argv)) unless grep $_ eq $opt, @bool_opts; # we're punting a bit here, if an option appears followed by a digit # we take the digit as the argument for the option. If there is # nothing that looks like a digit, we pretend the option is a flag # that is being set and has no argument. my $arg = 1; $arg = shift(@$argv) if @$argv && $argv->[0] =~ /^\d+$/; return ($opt, $arg); } sub read_args { my $self = shift; (my $args, @_) = $self->cull_options(@_); my %args = %$args; my $opt_re = qr/[\w\-]+/; my ($action, @argv); while (@_) { local $_ = shift; if ( /^(?:--)?($opt_re)=(.*)$/ ) { $self->_read_arg(\%args, $1, $2); } elsif ( /^--($opt_re)$/ ) { my($opt, $arg) = $self->_optional_arg($1, \@_); $self->_read_arg(\%args, $opt, $arg); } elsif ( /^($opt_re)$/ and !defined($action)) { $action = $1; } else { push @argv, $_; } } $args{ARGV} = \@argv; for ('extra_compiler_flags', 'extra_linker_flags') { $args{$_} = [ $self->split_like_shell($args{$_}) ] if exists $args{$_}; } # Convert to arrays for ('include_dirs') { $args{$_} = [ $args{$_} ] if exists $args{$_} && !ref $args{$_} } # Hashify these parameters for ($self->hash_properties, 'config') { next unless exists $args{$_}; my %hash; $args{$_} ||= []; $args{$_} = [ $args{$_} ] unless ref $args{$_}; foreach my $arg ( @{$args{$_}} ) { $arg =~ /($opt_re)=(.*)/ or die "Malformed '$_' argument: '$arg' should be something like 'foo=bar'"; $hash{$1} = $2; } $args{$_} = \%hash; } # De-tilde-ify any path parameters for my $key (qw(prefix install_base destdir)) { next if !defined $args{$key}; $args{$key} = $self->_detildefy($args{$key}); } for my $key (qw(install_path)) { next if !defined $args{$key}; for my $subkey (keys %{$args{$key}}) { next if !defined $args{$key}{$subkey}; my $subkey_ext = $self->_detildefy($args{$key}{$subkey}); if ( $subkey eq 'html' ) { # translate for compatibility $args{$key}{binhtml} = $subkey_ext; $args{$key}{libhtml} = $subkey_ext; } else { $args{$key}{$subkey} = $subkey_ext; } } } if ($args{makefile_env_macros}) { require Module::Build::Compat; %args = (%args, Module::Build::Compat->makefile_to_build_macros); } return \%args, $action; } # Default: do nothing. Overridden for Unix & Windows. sub _detildefy {} # merge Module::Build argument lists that have already been parsed # by read_args(). Takes two references to option hashes and merges # the contents, giving priority to the first. sub _merge_arglist { my( $self, $opts1, $opts2 ) = @_; $opts1 ||= {}; $opts2 ||= {}; my %new_opts = %$opts1; while (my ($key, $val) = each %$opts2) { if ( exists( $opts1->{$key} ) ) { if ( ref( $val ) eq 'HASH' ) { while (my ($k, $v) = each %$val) { $new_opts{$key}{$k} = $v unless exists( $opts1->{$key}{$k} ); } } } else { $new_opts{$key} = $val } } return %new_opts; } # Look for a home directory on various systems. sub _home_dir { my @home_dirs; push( @home_dirs, $ENV{HOME} ) if $ENV{HOME}; push( @home_dirs, File::Spec->catpath($ENV{HOMEDRIVE}, $ENV{HOMEPATH}, '') ) if $ENV{HOMEDRIVE} && $ENV{HOMEPATH}; my @other_home_envs = qw( USERPROFILE APPDATA WINDIR SYS$LOGIN ); push( @home_dirs, map $ENV{$_}, grep $ENV{$_}, @other_home_envs ); my @real_home_dirs = grep -d, @home_dirs; return wantarray ? @real_home_dirs : shift( @real_home_dirs ); } sub _find_user_config { my $self = shift; my $file = shift; foreach my $dir ( $self->_home_dir ) { my $path = File::Spec->catfile( $dir, $file ); return $path if -e $path; } return undef; } # read ~/.modulebuildrc returning global options '*' and # options specific to the currently executing $action. sub read_modulebuildrc { my( $self, $action ) = @_; return () unless $self->use_rcfile; my $modulebuildrc; if ( exists($ENV{MODULEBUILDRC}) && $ENV{MODULEBUILDRC} eq 'NONE' ) { return (); } elsif ( exists($ENV{MODULEBUILDRC}) && -e $ENV{MODULEBUILDRC} ) { $modulebuildrc = $ENV{MODULEBUILDRC}; } elsif ( exists($ENV{MODULEBUILDRC}) ) { $self->log_warn("WARNING: Can't find resource file " . "'$ENV{MODULEBUILDRC}' defined in environment.\n" . "No options loaded\n"); return (); } else { $modulebuildrc = $self->_find_user_config( '.modulebuildrc' ); return () unless $modulebuildrc; } open(my $fh, '<', $modulebuildrc ) or die "Can't open $modulebuildrc: $!"; my %options; my $buffer = ''; while (defined( my $line = <$fh> )) { chomp( $line ); $line =~ s/#.*$//; next unless length( $line ); if ( $line =~ /^\S/ ) { if ( $buffer ) { my( $action, $options ) = split( /\s+/, $buffer, 2 ); $options{$action} .= $options . ' '; $buffer = ''; } $buffer = $line; } else { $buffer .= $line; } } if ( $buffer ) { # anything left in $buffer ? my( $action, $options ) = split( /\s+/, $buffer, 2 ); $options{$action} .= $options . ' '; # merge if more than one line } my ($global_opts) = $self->read_args( $self->split_like_shell( $options{'*'} || '' ) ); # let fakeinstall act like install if not provided if ( $action eq 'fakeinstall' && ! exists $options{fakeinstall} ) { $action = 'install'; } my ($action_opts) = $self->read_args( $self->split_like_shell( $options{$action} || '' ) ); # specific $action options take priority over global options '*' return $self->_merge_arglist( $action_opts, $global_opts ); } # merge the relevant options in ~/.modulebuildrc into Module::Build's # option list where they do not conflict with commandline options. sub merge_modulebuildrc { my( $self, $action, %cmdline_opts ) = @_; my %rc_opts = $self->read_modulebuildrc( $action || $self->{action} || 'build' ); my %new_opts = $self->_merge_arglist( \%cmdline_opts, \%rc_opts ); $self->merge_args( $action, %new_opts ); } sub merge_args { my ($self, $action, %args) = @_; $self->{action} = $action if defined $action; my %additive = map { $_ => 1 } $self->hash_properties; # Extract our 'properties' from $cmd_args, the rest are put in 'args'. while (my ($key, $val) = each %args) { $self->{phash}{runtime_params}->access( $key => $val ) if $self->valid_property($key); if ($key eq 'config') { $self->config($_ => $val->{$_}) foreach keys %$val; } else { my $add_to = $additive{$key} ? $self->{properties}{$key} : $self->valid_property($key) ? $self->{properties} : $self->{args} ; if ($additive{$key}) { $add_to->{$_} = $val->{$_} foreach keys %$val; } else { $add_to->{$key} = $val; } } } } sub cull_args { my $self = shift; my @arg_list = @_; unshift @arg_list, $self->split_like_shell($ENV{PERL_MB_OPT}) if $ENV{PERL_MB_OPT}; my ($args, $action) = $self->read_args(@arg_list); $self->merge_args($action, %$args); $self->merge_modulebuildrc( $action, %$args ); } sub super_classes { my ($self, $class, $seen) = @_; $class ||= ref($self) || $self; $seen ||= {}; no strict 'refs'; my @super = grep {not $seen->{$_}++} $class, @{ $class . '::ISA' }; return @super, map {$self->super_classes($_,$seen)} @super; } sub known_actions { my ($self) = @_; my %actions; no strict 'refs'; foreach my $class ($self->super_classes) { foreach ( keys %{ $class . '::' } ) { $actions{$1}++ if /^ACTION_(\w+)/; } } return wantarray ? sort keys %actions : \%actions; } sub get_action_docs { my ($self, $action) = @_; my $actions = $self->known_actions; die "No known action '$action'" unless $actions->{$action}; my ($files_found, @docs) = (0); foreach my $class ($self->super_classes) { (my $file = $class) =~ s{::}{/}g; # NOTE: silently skipping relative paths if any chdir() happened $file = $INC{$file . '.pm'} or next; open(my $fh, '<', $file) or next; $files_found++; # Code below modified from /usr/bin/perldoc # Skip to ACTIONS section local $_; while (<$fh>) { last if /^=head1 ACTIONS\s/; } # Look for our action and determine the style my $style; while (<$fh>) { last if /^=head1 /; # only item and head2 are allowed (3&4 are not in 5.005) if(/^=(item|head2)\s+\Q$action\E\b/) { $style = $1; push @docs, $_; last; } } $style or next; # not here # and the content if($style eq 'item') { my ($found, $inlist) = (0, 0); while (<$fh>) { if (/^=(item|back)/) { last unless $inlist; } push @docs, $_; ++$inlist if /^=over/; --$inlist if /^=back/; } } else { # head2 style # stop at anything equal or greater than the found level while (<$fh>) { last if(/^=(?:head[12]|cut)/); push @docs, $_; } } # TODO maybe disallow overriding just pod for an action # TODO and possibly: @docs and last; } unless ($files_found) { $@ = "Couldn't find any documentation to search"; return; } unless (@docs) { $@ = "Couldn't find any docs for action '$action'"; return; } return join '', @docs; } sub ACTION_prereq_report { my $self = shift; $self->log_info( $self->prereq_report ); } sub ACTION_prereq_data { my $self = shift; $self->log_info( Module::Build::Dumper->_data_dump( $self->prereq_data ) ); } sub prereq_data { my $self = shift; my @types = ('configure_requires', @{ $self->prereq_action_types } ); my $info = { map { $_ => $self->$_() } grep { %{$self->$_()} } @types }; return $info; } sub prereq_report { my $self = shift; my $info = $self->prereq_data; my $output = ''; foreach my $type (sort keys %$info) { my $prereqs = $info->{$type}; $output .= "\n$type:\n"; my $mod_len = 2; my $ver_len = 4; my %mods; foreach my $modname (sort keys %$prereqs) { my $spec = $prereqs->{$modname}; my $len = length $modname; $mod_len = $len if $len > $mod_len; $spec ||= '0'; $len = length $spec; $ver_len = $len if $len > $ver_len; my $mod = $self->check_installed_status($modname, $spec); $mod->{name} = $modname; $mod->{ok} ||= 0; $mod->{ok} = ! $mod->{ok} if $type =~ /^(\w+_)?conflicts$/; $mods{lc $modname} = $mod; } my $space = q{ } x ($mod_len - 3); my $vspace = q{ } x ($ver_len - 3); my $sline = q{-} x ($mod_len - 3); my $vline = q{-} x ($ver_len - 3); my $disposition = ($type =~ /^(\w+_)?conflicts$/) ? 'Clash' : 'Need'; $output .= " Module $space $disposition $vspace Have\n". " ------$sline+------$vline-+----------\n"; for my $k (sort keys %mods) { my $mod = $mods{$k}; my $space = q{ } x ($mod_len - length $k); my $vspace = q{ } x ($ver_len - length $mod->{need}); my $f = $mod->{ok} ? ' ' : '!'; $output .= " $f $mod->{name} $space $mod->{need} $vspace ". (defined($mod->{have}) ? $mod->{have} : "")."\n"; } } return $output; } sub ACTION_help { my ($self) = @_; my $actions = $self->known_actions; if (@{$self->{args}{ARGV}}) { my $msg = eval {$self->get_action_docs($self->{args}{ARGV}[0], $actions)}; print $@ ? "$@\n" : $msg; return; } print < --arg1=value --arg2=value ... Example: $0 test --verbose=1 Actions defined: EOF print $self->_action_listing($actions); print "\nRun `Build help ` for details on an individual action.\n"; print "See `perldoc Module::Build` for complete documentation.\n"; } sub _action_listing { my ($self, $actions) = @_; # Flow down columns, not across rows my @actions = sort keys %$actions; @actions = map $actions[($_ + ($_ % 2) * @actions) / 2], 0..$#actions; my $out = ''; while (my ($one, $two) = splice @actions, 0, 2) { $out .= sprintf(" %-12s %-12s\n", $one, $two||''); } $out =~ s{\s*$}{}mg; # remove trailing spaces return $out; } sub ACTION_retest { my ($self) = @_; # Protect others against our @INC changes local @INC = @INC; # Filter out nonsensical @INC entries - some versions of # Test::Harness will really explode the number of entries here @INC = grep {ref() || -d} @INC if @INC > 100; $self->do_tests; } sub ACTION_testall { my ($self) = @_; my @types; for my $action (grep { $_ ne 'all' } $self->get_test_types) { # XXX We can't just dispatch because we get multiple summaries but # we'll need to dispatch to support custom setup/teardown in the # action. To support that, we'll need to call something besides # Harness::runtests() because we'll need to collect the results in # parts, then run the summary. push(@types, $action); #$self->_call_action( "test$action" ); } $self->generic_test(types => ['default', @types]); } sub get_test_types { my ($self) = @_; my $t = $self->{properties}->{test_types}; return ( defined $t ? ( wantarray ? sort keys %$t : keys %$t ) : () ); } sub ACTION_test { my ($self) = @_; $self->generic_test(type => 'default'); } sub generic_test { my $self = shift; (@_ % 2) and croak('Odd number of elements in argument hash'); my %args = @_; my $p = $self->{properties}; my @types = ( (exists($args{type}) ? $args{type} : ()), (exists($args{types}) ? @{$args{types}} : ()), ); @types or croak "need some types of tests to check"; my %test_types = ( default => $p->{test_file_exts}, (defined($p->{test_types}) ? %{$p->{test_types}} : ()), ); for my $type (@types) { croak "$type not defined in test_types!" unless defined $test_types{ $type }; } # we use local here because it ends up two method calls deep local $p->{test_file_exts} = [ map { ref $_ ? @$_ : $_ } @test_types{@types} ]; $self->depends_on('code'); # Protect others against our @INC changes local @INC = @INC; # Make sure we test the module in blib/ unshift @INC, (File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'), File::Spec->catdir($p->{base_dir}, $self->blib, 'arch')); # Filter out nonsensical @INC entries - some versions of # Test::Harness will really explode the number of entries here @INC = grep {ref() || -d} @INC if @INC > 100; $self->do_tests; } # Test::Harness dies on failure but TAP::Harness does not, so we must # die if running under TAP::Harness sub do_tests { my $self = shift; my $tests = $self->find_test_files; local $ENV{PERL_DL_NONLAZY} = 1; if(@$tests) { my $args = $self->tap_harness_args; if($self->use_tap_harness or ($args and %$args)) { my $aggregate = $self->run_tap_harness($tests); if ( $aggregate->has_errors ) { die "Errors in testing. Cannot continue.\n"; } } else { $self->run_test_harness($tests); } } else { $self->log_info("No tests defined.\n"); } $self->run_visual_script; } sub run_tap_harness { my ($self, $tests) = @_; require TAP::Harness::Env; # TODO allow the test @INC to be set via our API? my $aggregate = TAP::Harness::Env->create({ lib => [@INC], verbosity => $self->{properties}{verbose}, switches => [ $self->harness_switches ], %{ $self->tap_harness_args }, })->runtests(@$tests); return $aggregate; } sub run_test_harness { my ($self, $tests) = @_; require Test::Harness; local $Test::Harness::verbose = $self->verbose || 0; local $Test::Harness::switches = join ' ', $self->harness_switches; Test::Harness::runtests(@$tests); } sub run_visual_script { my $self = shift; # This will get run and the user will see the output. It doesn't # emit Test::Harness-style output. $self->run_perl_script('visual.pl', '-Mblib='.$self->blib) if -e 'visual.pl'; } sub harness_switches { my $self = shift; my @res; push @res, qw(-w -d) if $self->{properties}{debugger}; push @res, '-MDevel::Cover' if $self->{properties}{cover}; return @res; } sub test_files { my $self = shift; my $p = $self->{properties}; if (@_) { return $p->{test_files} = (@_ == 1 ? shift : [@_]); } return $self->find_test_files; } sub expand_test_dir { my ($self, $dir) = @_; my $exts = $self->{properties}{test_file_exts}; return sort map { @{$self->rscan_dir($dir, qr{^[^.].*\Q$_\E$})} } @$exts if $self->recursive_test_files; return sort map { glob File::Spec->catfile($dir, "*$_") } @$exts; } sub ACTION_testdb { my ($self) = @_; local $self->{properties}{debugger} = 1; $self->depends_on('test'); } sub ACTION_testcover { my ($self) = @_; unless (Module::Metadata->find_module_by_name('Devel::Cover')) { warn("Cannot run testcover action unless Devel::Cover is installed.\n"); return; } $self->add_to_cleanup('coverage', 'cover_db'); $self->depends_on('code'); # See whether any of the *.pm files have changed since last time # testcover was run. If so, start over. if (-e 'cover_db') { my $pm_files = $self->rscan_dir (File::Spec->catdir($self->blib, 'lib'), $self->file_qr('\.pm$') ); my $cover_files = $self->rscan_dir('cover_db', sub {-f $_ and not /\.html$/}); $self->do_system(qw(cover -delete)) unless $self->up_to_date($pm_files, $cover_files) && $self->up_to_date($self->test_files, $cover_files); } local $self->{properties}{cover} = 1; $self->depends_on('test'); $self->do_system('cover'); } sub ACTION_code { my ($self) = @_; # All installable stuff gets created in blib/ . # Create blib/arch to keep blib.pm happy my $blib = $self->blib; $self->add_to_cleanup($blib); File::Path::mkpath( File::Spec->catdir($blib, 'arch') ); if (my $split = $self->autosplit) { $self->autosplit_file($_, $blib) for ref($split) ? @$split : ($split); } foreach my $element (@{$self->build_elements}) { my $method = "process_${element}_files"; $method = "process_files_by_extension" unless $self->can($method); $self->$method($element); } $self->depends_on('config_data'); } sub ACTION_build { my $self = shift; $self->log_info("Building " . $self->dist_name . "\n"); $self->depends_on('code'); $self->depends_on('docs'); } sub process_files_by_extension { my ($self, $ext) = @_; my $method = "find_${ext}_files"; my $files = $self->can($method) ? $self->$method() : $self->_find_file_by_type($ext, 'lib'); foreach my $file (sort keys %$files) { $self->copy_if_modified(from => $file, to => File::Spec->catfile($self->blib, $files->{$file}) ); } } sub process_support_files { my $self = shift; my $p = $self->{properties}; return unless $p->{c_source}; return if $self->pureperl_only && $self->allow_pureperl; my $files; if (ref($p->{c_source}) eq "ARRAY") { push @{$p->{include_dirs}}, @{$p->{c_source}}; for my $path (@{$p->{c_source}}) { push @$files, @{ $self->rscan_dir($path, $self->file_qr('\.c(c|p|pp|xx|\+\+)?$')) }; } } else { push @{$p->{include_dirs}}, $p->{c_source}; $files = $self->rscan_dir($p->{c_source}, $self->file_qr('\.c(c|p|pp|xx|\+\+)?$')); } foreach my $file (@$files) { push @{$p->{objects}}, $self->compile_c($file); } } sub process_share_dir_files { my $self = shift; my $files = $self->_find_share_dir_files; return unless $files; # root for all File::ShareDir paths my $share_prefix = File::Spec->catdir($self->blib, qw/lib auto share/); # copy all share files to blib foreach my $file (sort keys %$files) { $self->copy_if_modified( from => $file, to => File::Spec->catfile( $share_prefix, $files->{$file} ) ); } } sub _find_share_dir_files { my $self = shift; my $share_dir = $self->share_dir; return unless $share_dir; my @file_map; if ( $share_dir->{dist} ) { my $prefix = "dist/".$self->dist_name; push @file_map, $self->_share_dir_map( $prefix, $share_dir->{dist} ); } if ( $share_dir->{module} ) { for my $mod ( sort keys %{ $share_dir->{module} } ) { (my $altmod = $mod) =~ s{::}{-}g; my $prefix = "module/$altmod"; push @file_map, $self->_share_dir_map($prefix, $share_dir->{module}{$mod}); } } return { @file_map }; } sub _share_dir_map { my ($self, $prefix, $list) = @_; my %files; for my $dir ( @$list ) { for my $f ( @{ $self->rscan_dir( $dir, sub {-f} )} ) { $f =~ s{\A.*?\Q$dir\E/}{}; $files{"$dir/$f"} = "$prefix/$f"; } } return %files; } sub process_PL_files { my ($self) = @_; my $files = $self->find_PL_files; foreach my $file (sort keys %$files) { my $to = $files->{$file}; unless ($self->up_to_date( $file, $to )) { $self->run_perl_script($file, [], [@$to]) or die "$file failed"; $self->add_to_cleanup(@$to); } } } sub process_xs_files { my $self = shift; return if $self->pureperl_only && $self->allow_pureperl; my $files = $self->find_xs_files; croak 'Can\'t build xs files under --pureperl-only' if %$files && $self->pureperl_only; foreach my $from (sort keys %$files) { my $to = $files->{$from}; unless ($from eq $to) { $self->add_to_cleanup($to); $self->copy_if_modified( from => $from, to => $to ); } $self->process_xs($to); } } sub process_pod_files { shift()->process_files_by_extension(shift()) } sub process_pm_files { shift()->process_files_by_extension(shift()) } sub process_script_files { my $self = shift; my $files = $self->find_script_files; return unless keys %$files; my $script_dir = File::Spec->catdir($self->blib, 'script'); File::Path::mkpath( $script_dir ); foreach my $file (sort keys %$files) { my $result = $self->copy_if_modified($file, $script_dir, 'flatten') or next; $self->fix_shebang_line($result) unless $self->is_vmsish; $self->make_executable($result); } } sub find_PL_files { my $self = shift; if (my $files = $self->{properties}{PL_files}) { # 'PL_files' is given as a Unix file spec, so we localize_file_path(). if (ref $files eq 'ARRAY') { return { map {$_, [/^(.*)\.PL$/]} map $self->localize_file_path($_), @$files }; } elsif (ref $files eq 'HASH') { my %out; while (my ($file, $to) = each %$files) { $out{ $self->localize_file_path($file) } = [ map $self->localize_file_path($_), ref $to ? @$to : ($to) ]; } return \%out; } else { die "'PL_files' must be a hash reference or array reference"; } } return unless -d 'lib'; return { map {$_, [/^(.*)\.PL$/i ]} @{ $self->rscan_dir('lib', $self->file_qr('\.PL$')) } }; } sub find_pm_files { shift->_find_file_by_type('pm', 'lib') } sub find_pod_files { shift->_find_file_by_type('pod', 'lib') } sub find_xs_files { shift->_find_file_by_type('xs', 'lib') } sub find_script_files { my $self = shift; if (my $files = $self->script_files) { # Always given as a Unix file spec. Values in the hash are # meaningless, but we preserve if present. return { map {$self->localize_file_path($_), $files->{$_}} keys %$files }; } # No default location for script files return {}; } sub find_test_files { my $self = shift; my $p = $self->{properties}; if (my $files = $p->{test_files}) { $files = [sort keys %$files] if ref $files eq 'HASH'; $files = [map { -d $_ ? $self->expand_test_dir($_) : $_ } map glob, $self->split_like_shell($files)]; # Always given as a Unix file spec. return [ map $self->localize_file_path($_), @$files ]; } else { # Find all possible tests in t/ or test.pl my @tests; push @tests, 'test.pl' if -e 'test.pl'; push @tests, $self->expand_test_dir('t') if -e 't' and -d _; return \@tests; } } sub _find_file_by_type { my ($self, $type, $dir) = @_; if (my $files = $self->{properties}{"${type}_files"}) { # Always given as a Unix file spec return { map $self->localize_file_path($_), %$files }; } return {} unless -d $dir; return { map {$_, $_} map $self->localize_file_path($_), grep !/\.\#/, @{ $self->rscan_dir($dir, $self->file_qr("\\.$type\$")) } }; } sub localize_file_path { my ($self, $path) = @_; return File::Spec->catfile( split m{/}, $path ); } sub localize_dir_path { my ($self, $path) = @_; return File::Spec->catdir( split m{/}, $path ); } sub fix_shebang_line { # Adapted from fixin() in ExtUtils::MM_Unix 1.35 my ($self, @files) = @_; my $c = ref($self) ? $self->{config} : 'Module::Build::Config'; my ($does_shbang) = $c->get('sharpbang') =~ /^\s*\#\!/; for my $file (@files) { open(my $FIXIN, '<', $file) or die "Can't process '$file': $!"; local $/ = "\n"; chomp(my $line = <$FIXIN>); next unless $line =~ s/^\s*\#!\s*//; # Not a shebang file. my ($cmd, $arg) = (split(' ', $line, 2), ''); next unless $cmd =~ /perl/i; my $interpreter = $self->{properties}{perl}; $self->log_verbose("Changing sharpbang in $file to $interpreter\n"); my $shb = ''; $shb .= $c->get('sharpbang')."$interpreter $arg\n" if $does_shbang; open(my $FIXOUT, '>', "$file.new") or die "Can't create new $file: $!\n"; # Print out the new #! line (or equivalent). local $\; undef $/; # Was localized above print $FIXOUT $shb, <$FIXIN>; close $FIXIN; close $FIXOUT; rename($file, "$file.bak") or die "Can't rename $file to $file.bak: $!"; rename("$file.new", $file) or die "Can't rename $file.new to $file: $!"; $self->delete_filetree("$file.bak") or $self->log_warn("Couldn't clean up $file.bak, leaving it there"); $self->do_system($c->get('eunicefix'), $file) if $c->get('eunicefix') ne ':'; } } sub ACTION_testpod { my $self = shift; $self->depends_on('docs'); eval q{use Test::Pod 0.95; 1} or die "The 'testpod' action requires Test::Pod version 0.95"; my @files = sort keys %{$self->_find_pods($self->libdoc_dirs)}, keys %{$self->_find_pods ($self->bindoc_dirs, exclude => [ $self->file_qr('\.bat$') ])} or die "Couldn't find any POD files to test\n"; { package # hide from PAUSE Module::Build::PodTester; # Don't want to pollute the main namespace Test::Pod->import( tests => scalar @files ); pod_file_ok($_) foreach @files; } } sub ACTION_testpodcoverage { my $self = shift; $self->depends_on('docs'); eval q{use Test::Pod::Coverage 1.00; 1} or die "The 'testpodcoverage' action requires ", "Test::Pod::Coverage version 1.00"; # TODO this needs test coverage! # XXX work-around a bug in Test::Pod::Coverage previous to v1.09 # Make sure we test the module in blib/ local @INC = @INC; my $p = $self->{properties}; unshift(@INC, # XXX any reason to include arch? File::Spec->catdir($p->{base_dir}, $self->blib, 'lib'), #File::Spec->catdir($p->{base_dir}, $self->blib, 'arch') ); all_pod_coverage_ok(); } sub ACTION_docs { my $self = shift; $self->depends_on('code'); $self->depends_on('manpages', 'html'); } # Given a file type, will return true if the file type would normally # be installed when neither install-base nor prefix has been set. # I.e. it will be true only if the path is set from Config.pm or # set explicitly by the user via install-path. sub _is_default_installable { my $self = shift; my $type = shift; return ( $self->install_destination($type) && ( $self->install_path($type) || $self->install_sets($self->installdirs)->{$type} ) ) ? 1 : 0; } sub _is_ActivePerl { # return 0; my $self = shift; unless (exists($self->{_is_ActivePerl})) { $self->{_is_ActivePerl} = (eval { require ActivePerl::DocTools; } || 0); } return $self->{_is_ActivePerl}; } sub _is_ActivePPM { # return 0; my $self = shift; unless (exists($self->{_is_ActivePPM})) { $self->{_is_ActivePPM} = (eval { require ActivePerl::PPM; } || 0); } return $self->{_is_ActivePPM}; } sub ACTION_manpages { my $self = shift; return unless $self->_mb_feature('manpage_support'); $self->depends_on('code'); my %extra_manify_args = $self->{properties}{'extra_manify_args'} ? %{ $self->{properties}{'extra_manify_args'} } : (); foreach my $type ( qw(bin lib) ) { next unless ( $self->invoked_action eq 'manpages' || $self->_is_default_installable("${type}doc")); my $files = $self->_find_pods( $self->{properties}{"${type}doc_dirs"}, exclude => [ $self->file_qr('\.bat$') ] ); next unless %$files; my $sub = $self->can("manify_${type}_pods"); $self->$sub( %extra_manify_args ) if defined( $sub ); } } sub manify_bin_pods { my $self = shift; my $section = $self->config('man1ext'); my %podman_args = (section => $section, @_); my $files = $self->_find_pods( $self->{properties}{bindoc_dirs}, exclude => [ $self->file_qr('\.bat$') ] ); return unless keys %$files; my $mandir = File::Spec->catdir( $self->blib, 'bindoc' ); File::Path::mkpath( $mandir, 0, oct(777) ); require Pod::Man; foreach my $file (sort keys %$files) { # Pod::Simple based parsers only support one document per instance. # This is expected to change in a future version (Pod::Simple > 3.03). my $parser = Pod::Man->new( %podman_args ); my $manpage = $self->man1page_name( $file ) . '.' . $self->config( 'man1ext' ); my $outfile = File::Spec->catfile($mandir, $manpage); next if $self->up_to_date( $file, $outfile ); $self->log_verbose("Manifying $file -> $outfile\n"); eval { $parser->parse_from_file( $file, $outfile ); 1 } or $self->log_warn("Error creating '$outfile': $@\n"); $files->{$file} = $outfile; } } sub manify_lib_pods { my $self = shift; my $section = $self->config('man3ext'); my %podman_args = (section => $section, @_); my $files = $self->_find_pods($self->{properties}{libdoc_dirs}); return unless keys %$files; my $mandir = File::Spec->catdir( $self->blib, 'libdoc' ); File::Path::mkpath( $mandir, 0, oct(777) ); require Pod::Man; foreach my $file (sort keys %$files) { # Pod::Simple based parsers only support one document per instance. # This is expected to change in a future version (Pod::Simple > 3.03). my $parser = Pod::Man->new( %podman_args ); my $manpage = $self->man3page_name( $files->{$file} ) . '.' . $self->config( 'man3ext' ); my $outfile = File::Spec->catfile( $mandir, $manpage); next if $self->up_to_date( $file, $outfile ); $self->log_verbose("Manifying $file -> $outfile\n"); eval { $parser->parse_from_file( $file, $outfile ); 1 } or $self->log_warn("Error creating '$outfile': $@\n"); $files->{$file} = $outfile; } } sub _find_pods { my ($self, $dirs, %args) = @_; my %files; foreach my $spec (@$dirs) { my $dir = $self->localize_dir_path($spec); next unless -e $dir; FILE: foreach my $file ( @{ $self->rscan_dir( $dir ) } ) { foreach my $regexp ( @{ $args{exclude} } ) { next FILE if $file =~ $regexp; } $file = $self->localize_file_path($file); $files{$file} = File::Spec->abs2rel($file, $dir) if $self->contains_pod( $file ) } } return \%files; } sub contains_pod { my ($self, $file) = @_; return '' unless -T $file; # Only look at text files open(my $fh, '<', $file ) or die "Can't open $file: $!"; while (my $line = <$fh>) { return 1 if $line =~ /^\=(?:head|pod|item)/; } return ''; } sub ACTION_html { my $self = shift; return unless $self->_mb_feature('HTML_support'); $self->depends_on('code'); foreach my $type ( qw(bin lib) ) { next unless ( $self->invoked_action eq 'html' || $self->_is_default_installable("${type}html")); $self->htmlify_pods( $type ); } } # 1) If it's an ActiveState perl install, we need to run # ActivePerl::DocTools->UpdateTOC; # 2) Links to other modules are not being generated sub htmlify_pods { my $self = shift; my $type = shift; my $htmldir = shift || File::Spec->catdir($self->blib, "${type}html"); $self->add_to_cleanup('pod2htm*'); my $pods = $self->_find_pods( $self->{properties}{"${type}doc_dirs"}, exclude => [ $self->file_qr('\.(?:bat|com|html)$') ] ); return unless %$pods; # nothing to do unless ( -d $htmldir ) { File::Path::mkpath($htmldir, 0, oct(755)) or die "Couldn't mkdir $htmldir: $!"; } my @rootdirs = ($type eq 'bin') ? qw(bin) : $self->installdirs eq 'core' ? qw(lib) : qw(site lib); my $podroot = $ENV{PERL_CORE} ? File::Basename::dirname($ENV{PERL_CORE}) : $self->original_prefix('core'); my $htmlroot = $self->install_sets('core')->{libhtml}; my $podpath; unless (defined $self->args('html_links') and !$self->args('html_links')) { my @podpath = ( (map { File::Spec->abs2rel($_ ,$podroot) } grep { -d } ( $self->install_sets('core', 'lib'), # lib $self->install_sets('core', 'bin'), # bin $self->install_sets('site', 'lib'), # site/lib ) ), File::Spec->rel2abs($self->blib) ); $podpath = $ENV{PERL_CORE} ? File::Spec->catdir($podroot, 'lib') : join(":", map { tr,:\\,|/,; $_ } @podpath); } my $blibdir = join('/', File::Spec->splitdir( (File::Spec->splitpath(File::Spec->rel2abs($htmldir),1))[1]),'' ); my ($with_ActiveState, $htmltool); if ( $with_ActiveState = $self->_is_ActivePerl && eval { require ActivePerl::DocTools::Pod; 1 } ) { my $tool_v = ActiveState::DocTools::Pod->VERSION; $htmltool = "ActiveState::DocTools::Pod"; $htmltool .= " $tool_v" if $tool_v && length $tool_v; } else { require Module::Build::PodParser; require Pod::Html; $htmltool = "Pod::Html " . Pod::Html->VERSION; } $self->log_verbose("Converting Pod to HTML with $htmltool\n"); my $errors = 0; POD: foreach my $pod ( sort keys %$pods ) { my ($name, $path) = File::Basename::fileparse($pods->{$pod}, $self->file_qr('\.(?:pm|plx?|pod)$') ); my @dirs = File::Spec->splitdir( File::Spec->canonpath( $path ) ); pop( @dirs ) if scalar(@dirs) && $dirs[-1] eq File::Spec->curdir; my $fulldir = File::Spec->catdir($htmldir, @rootdirs, @dirs); my $tmpfile = File::Spec->catfile($fulldir, "${name}.tmp"); my $outfile = File::Spec->catfile($fulldir, "${name}.html"); my $infile = File::Spec->abs2rel($pod); next if $self->up_to_date($infile, $outfile); unless ( -d $fulldir ){ File::Path::mkpath($fulldir, 0, oct(755)) or die "Couldn't mkdir $fulldir: $!"; } $self->log_verbose("HTMLifying $infile -> $outfile\n"); if ( $with_ActiveState ) { my $depth = @rootdirs + @dirs; my %opts = ( infile => $infile, outfile => $tmpfile, ( defined($podpath) ? (podpath => $podpath) : ()), podroot => $podroot, index => 1, depth => $depth, ); eval { ActivePerl::DocTools::Pod::pod2html(map { ($_, $opts{$_}) } sort keys %opts); 1; } or $self->log_warn("[$htmltool] pod2html (" . join(", ", map { "q{$_} => q{$opts{$_}}" } (sort keys %opts)) . ") failed: $@"); } else { my $path2root = File::Spec->catdir((File::Spec->updir) x @dirs); open(my $fh, '<', $infile) or die "Can't read $infile: $!"; my $abstract = Module::Build::PodParser->new(fh => $fh)->get_abstract(); my $title = join( '::', (@dirs, $name) ); $title .= " - $abstract" if $abstract; my @opts = ( "--title=$title", ( defined($podpath) ? "--podpath=$podpath" : ()), "--infile=$infile", "--outfile=$tmpfile", "--podroot=$podroot", ($path2root ? "--htmlroot=$path2root" : ()), ); unless ( eval{Pod::Html->VERSION(1.12)} ) { push( @opts, ('--flush') ); # caching removed in 1.12 } if ( eval{Pod::Html->VERSION(1.12)} ) { push( @opts, ('--header', '--backlink') ); } elsif ( eval{Pod::Html->VERSION(1.03)} ) { push( @opts, ('--header', '--backlink=Back to Top') ); } $self->log_verbose("P::H::pod2html @opts\n"); { my $orig = Cwd::getcwd(); eval { Pod::Html::pod2html(@opts); 1 } or $self->log_warn("[$htmltool] pod2html( " . join(", ", map { "q{$_}" } @opts) . ") failed: $@"); chdir($orig); } } # We now have to cleanup the resulting html file if ( ! -r $tmpfile ) { $errors++; next POD; } open(my $fh, '<', $tmpfile) or die "Can't read $tmpfile: $!"; my $html = join('',<$fh>); close $fh; if (!$self->_is_ActivePerl) { # These fixups are already done by AP::DT:P:pod2html # The output from pod2html is NOT XHTML! # IE6+ will display content that is not valid for DOCTYPE $html =~ s#^##im; $html =~ s###i; # IE6+ will not display local HTML files with strict # security without this comment $html =~ s##\n#i; } # Fixup links that point to our temp blib $html =~ s/\Q$blibdir\E//g; open($fh, '>', $outfile) or die "Can't write $outfile: $!"; print $fh $html; close $fh; unlink($tmpfile); } return ! $errors; } # Adapted from ExtUtils::MM_Unix sub man1page_name { my $self = shift; return File::Basename::basename( shift ); } # Adapted from ExtUtils::MM_Unix and Pod::Man # Depending on M::B's dependency policy, it might make more sense to refactor # Pod::Man::begin_pod() to extract a name() methods, and use them... # -spurkis sub man3page_name { my $self = shift; my ($vol, $dirs, $file) = File::Spec->splitpath( shift ); my @dirs = File::Spec->splitdir( File::Spec->canonpath($dirs) ); # Remove known exts from the base name $file =~ s/\.p(?:od|m|l)\z//i; return join( $self->manpage_separator, @dirs, $file ); } sub manpage_separator { return '::'; } # For systems that don't have 'diff' executable, should use Algorithm::Diff sub ACTION_diff { my $self = shift; $self->depends_on('build'); my $local_lib = File::Spec->rel2abs('lib'); my @myINC = grep {$_ ne $local_lib} @INC; # The actual install destination might not be in @INC, so check there too. push @myINC, map $self->install_destination($_), qw(lib arch); my @flags = @{$self->{args}{ARGV}}; @flags = $self->split_like_shell($self->{args}{flags} || '') unless @flags; my $installmap = $self->install_map; delete $installmap->{read}; delete $installmap->{write}; my $text_suffix = $self->file_qr('\.(pm|pod)$'); foreach my $localdir (sort keys %$installmap) { my @localparts = File::Spec->splitdir($localdir); my $files = $self->rscan_dir($localdir, sub {-f}); foreach my $file (@$files) { my @parts = File::Spec->splitdir($file); @parts = @parts[@localparts .. $#parts]; # Get rid of blib/lib or similar my $installed = Module::Metadata->find_module_by_name( join('::', @parts), \@myINC ); if (not $installed) { print "Only in lib: $file\n"; next; } my $status = File::Compare::compare($installed, $file); next if $status == 0; # Files are the same die "Can't compare $installed and $file: $!" if $status == -1; if ($file =~ $text_suffix) { $self->do_system('diff', @flags, $installed, $file); } else { print "Binary files $file and $installed differ\n"; } } } } sub ACTION_pure_install { shift()->depends_on('install'); } sub ACTION_install { my ($self) = @_; require ExtUtils::Install; $self->depends_on('build'); # RT#63003 suggest that odd circumstances that we might wind up # in a different directory than we started, so wrap with _do_in_dir to # ensure we get back to where we started; hope this fixes it! $self->_do_in_dir( ".", sub { ExtUtils::Install::install( $self->install_map, $self->verbose, 0, $self->{args}{uninst}||0 ); }); if ($self->_is_ActivePerl && $self->{_completed_actions}{html}) { $self->log_info("Building ActivePerl Table of Contents\n"); eval { ActivePerl::DocTools::WriteTOC(verbose => $self->verbose ? 1 : 0); 1; } or $self->log_warn("AP::DT:: WriteTOC() failed: $@"); } if ($self->_is_ActivePPM) { # We touch 'lib/perllocal.pod'. There is an existing logic in subroutine _init_db() # of 'ActivePerl/PPM/InstallArea.pm' that says that if 'lib/perllocal.pod' has a 'date-last-touched' # greater than that of the PPM SQLite databases ('etc/ppm-perl-area.db' and/or # 'site/etc/ppm-site-area.db') then the PPM SQLite databases are rebuilt from scratch. # in the following line, 'perllocal.pod' this is *always* 'lib/perllocal.pod', never 'site/lib/perllocal.pod' my $F_perllocal = File::Spec->catfile($self->install_sets('core', 'lib'), 'perllocal.pod'); my $dt_stamp = time; $self->log_info("For ActivePerl's PPM: touch '$F_perllocal'\n"); open my $perllocal, ">>", $F_perllocal; close $perllocal; utime($dt_stamp, $dt_stamp, $F_perllocal); } } sub ACTION_fakeinstall { my ($self) = @_; require ExtUtils::Install; my $eui_version = ExtUtils::Install->VERSION; if ( $eui_version < 1.32 ) { $self->log_warn( "The 'fakeinstall' action requires Extutils::Install 1.32 or later.\n" . "(You only have version $eui_version)." ); return; } $self->depends_on('build'); ExtUtils::Install::install($self->install_map, !$self->quiet, 1, $self->{args}{uninst}||0); } sub ACTION_versioninstall { my ($self) = @_; die "You must have only.pm 0.25 or greater installed for this operation: $@\n" unless eval { require only; 'only'->VERSION(0.25); 1 }; $self->depends_on('build'); my %onlyargs = map {exists($self->{args}{$_}) ? ($_ => $self->{args}{$_}) : ()} qw(version versionlib); only::install::install(%onlyargs); } sub ACTION_installdeps { my ($self) = @_; # XXX include feature prerequisites as optional prereqs? my $info = $self->_enum_prereqs; if (! $info ) { $self->log_info( "No prerequisites detected\n" ); return; } my $failures = $self->prereq_failures($info); if ( ! $failures ) { $self->log_info( "All prerequisites satisfied\n" ); return; } my @install; foreach my $type (sort keys %$failures) { my $prereqs = $failures->{$type}; if($type =~ m/^(?:\w+_)?requires$/) { push(@install, sort keys %$prereqs); next; } $self->log_info("Checking optional dependencies:\n"); foreach my $module (sort keys %$prereqs) { push(@install, $module) if($self->y_n("Install $module?", 'y')); } } return unless @install; my ($command, @opts) = $self->split_like_shell($self->cpan_client); # relative command should be relative to our active Perl # so we need to locate that command if ( ! File::Spec->file_name_is_absolute( $command ) ) { # prefer site to vendor to core my @loc = ( 'site', 'vendor', '' ); my @bindirs = File::Basename::dirname($self->perl); push @bindirs, map { ($self->config->{"install${_}bin"}, $self->config->{"install${_}script"}) } @loc; for my $d ( @bindirs ) { my $abs_cmd = $self->find_command(File::Spec->catfile( $d, $command )); if ( defined $abs_cmd ) { $command = $abs_cmd; last; } } } $self->do_system($command, @opts, @install); } sub ACTION_clean { my ($self) = @_; $self->log_info("Cleaning up build files\n"); foreach my $item (map glob($_), $self->cleanup) { $self->delete_filetree($item); } } sub ACTION_realclean { my ($self) = @_; $self->depends_on('clean'); $self->log_info("Cleaning up configuration files\n"); $self->delete_filetree( $self->config_dir, $self->mymetafile, $self->mymetafile2, $self->build_script ); } sub ACTION_ppd { my ($self) = @_; require Module::Build::PPMMaker; my $ppd = Module::Build::PPMMaker->new(); my $file = $ppd->make_ppd(%{$self->{args}}, build => $self); $self->add_to_cleanup($file); } sub ACTION_ppmdist { my ($self) = @_; $self->depends_on( 'build' ); my $ppm = $self->ppm_name; $self->delete_filetree( $ppm ); $self->log_info( "Creating $ppm\n" ); $self->add_to_cleanup( $ppm, "$ppm.tar.gz" ); my %types = ( # translate types/dirs to those expected by ppm lib => 'lib', arch => 'arch', bin => 'bin', script => 'script', bindoc => 'man1', libdoc => 'man3', binhtml => undef, libhtml => undef, ); foreach my $type ($self->install_types) { next if exists( $types{$type} ) && !defined( $types{$type} ); my $dir = File::Spec->catdir( $self->blib, $type ); next unless -e $dir; my $files = $self->rscan_dir( $dir ); foreach my $file ( @$files ) { next unless -f $file; my $rel_file = File::Spec->abs2rel( File::Spec->rel2abs( $file ), File::Spec->rel2abs( $dir ) ); my $to_file = File::Spec->catfile( $ppm, 'blib', exists( $types{$type} ) ? $types{$type} : $type, $rel_file ); $self->copy_if_modified( from => $file, to => $to_file ); } } foreach my $type ( qw(bin lib) ) { $self->htmlify_pods( $type, File::Spec->catdir($ppm, 'blib', 'html') ); } # create a tarball; # the directory tar'ed must be blib so we need to do a chdir first my $target = File::Spec->catfile( File::Spec->updir, $ppm ); $self->_do_in_dir( $ppm, sub { $self->make_tarball( 'blib', $target ) } ); $self->depends_on( 'ppd' ); $self->delete_filetree( $ppm ); } sub ACTION_pardist { my ($self) = @_; # Need PAR::Dist if ( not eval { require PAR::Dist; PAR::Dist->VERSION(0.17) } ) { $self->log_warn( "In order to create .par distributions, you need to\n" . "install PAR::Dist first." ); return(); } $self->depends_on( 'build' ); return PAR::Dist::blib_to_par( name => $self->dist_name, version => $self->dist_version, ); } sub ACTION_dist { my ($self) = @_; # MUST dispatch() and not depends_ok() so we generate a clean distdir $self->dispatch('distdir'); my $dist_dir = $self->dist_dir; $self->make_tarball($dist_dir); $self->delete_filetree($dist_dir); } sub ACTION_distcheck { my ($self) = @_; $self->_check_manifest_skip unless $self->invoked_action eq 'distclean'; require ExtUtils::Manifest; local $^W; # ExtUtils::Manifest is not warnings clean. my ($missing, $extra) = ExtUtils::Manifest::fullcheck(); return unless @$missing || @$extra; my $msg = "MANIFEST appears to be out of sync with the distribution\n"; if ( $self->invoked_action eq 'distcheck' ) { die $msg; } else { warn $msg; } } sub _check_mymeta_skip { my $self = shift; my $maniskip = shift || 'MANIFEST.SKIP'; require ExtUtils::Manifest; local $^W; # ExtUtils::Manifest is not warnings clean. # older ExtUtils::Manifest had a private _maniskip my $skip_factory = ExtUtils::Manifest->can('maniskip') || ExtUtils::Manifest->can('_maniskip'); my $mymetafile = $self->mymetafile; # we can't check it, just add it anyway to be safe for my $file ( $self->mymetafile, $self->mymetafile2 ) { unless ( $skip_factory && $skip_factory->($maniskip)->($file) ) { $self->log_warn("File '$maniskip' does not include '$file'. Adding it now.\n"); my $safe = quotemeta($file); $self->_append_maniskip("^$safe\$", $maniskip); } } } sub _add_to_manifest { my ($self, $manifest, $lines) = @_; $lines = [$lines] unless ref $lines; my $existing_files = $self->_read_manifest($manifest); return unless defined( $existing_files ); @$lines = grep {!exists $existing_files->{$_}} @$lines or return; my $mode = (stat $manifest)[2]; chmod($mode | oct(222), $manifest) or die "Can't make $manifest writable: $!"; open(my $fh, '<', $manifest) or die "Can't read $manifest: $!"; my $last_line = (<$fh>)[-1] || "\n"; my $has_newline = $last_line =~ /\n$/; close $fh; open($fh, '>>', $manifest) or die "Can't write to $manifest: $!"; print $fh "\n" unless $has_newline; print $fh map "$_\n", @$lines; close $fh; chmod($mode, $manifest); $self->log_verbose(map "Added to $manifest: $_\n", @$lines); } sub _sign_dir { my ($self, $dir) = @_; unless (eval { require Module::Signature; 1 }) { $self->log_warn("Couldn't load Module::Signature for 'distsign' action:\n $@\n"); return; } # Add SIGNATURE to the MANIFEST { my $manifest = File::Spec->catfile($dir, 'MANIFEST'); die "Signing a distribution requires a MANIFEST file" unless -e $manifest; $self->_add_to_manifest($manifest, "SIGNATURE Added here by Module::Build"); } # Would be nice if Module::Signature took a directory argument. $self->_do_in_dir($dir, sub {local $Module::Signature::Quiet = 1; Module::Signature::sign()}); } sub _do_in_dir { my ($self, $dir, $do) = @_; my $start_dir = File::Spec->rel2abs($self->cwd); chdir $dir or die "Can't chdir() to $dir: $!"; eval {$do->()}; my @err = $@ ? ($@) : (); chdir $start_dir or push @err, "Can't chdir() back to $start_dir: $!"; die join "\n", @err if @err; } sub ACTION_distsign { my ($self) = @_; { local $self->{properties}{sign} = 0; # We'll sign it ourselves $self->depends_on('distdir') unless -d $self->dist_dir; } $self->_sign_dir($self->dist_dir); } sub ACTION_skipcheck { my ($self) = @_; require ExtUtils::Manifest; local $^W; # ExtUtils::Manifest is not warnings clean. ExtUtils::Manifest::skipcheck(); } sub ACTION_distclean { my ($self) = @_; $self->depends_on('realclean'); $self->depends_on('distcheck'); } sub do_create_makefile_pl { my $self = shift; require Module::Build::Compat; $self->log_info("Creating Makefile.PL\n"); eval { Module::Build::Compat->create_makefile_pl($self->create_makefile_pl, $self, @_) }; if ( $@ ) { 1 while unlink 'Makefile.PL'; die "$@\n"; } $self->_add_to_manifest('MANIFEST', 'Makefile.PL'); } sub do_create_license { my $self = shift; $self->log_info("Creating LICENSE file\n"); if ( ! $self->_mb_feature('license_creation') ) { $self->_warn_mb_feature_deps('license_creation'); die "Aborting.\n"; } my $l = $self->license or die "Can't create LICENSE file: No license specified\n"; my $license = $self->_software_license_object or die << "HERE"; Can't create LICENSE file: '$l' is not a valid license key or Software::License subclass; HERE $self->delete_filetree('LICENSE'); open(my $fh, '>', 'LICENSE') or die "Can't write LICENSE file: $!"; print $fh $license->fulltext; close $fh; $self->_add_to_manifest('MANIFEST', 'LICENSE'); } sub do_create_readme { my $self = shift; $self->delete_filetree('README'); my $docfile = $self->_main_docfile; unless ( $docfile ) { $self->log_warn(<new() failures in test reports by # confirming that new() is available if ( eval {require Pod::Readme; Pod::Readme->can('new') } ) { $self->log_info("Creating README using Pod::Readme\n"); my $parser = Pod::Readme->new; $parser->parse_from_file($docfile, 'README', @_); } elsif ( eval {require Pod::Text; 1} ) { $self->log_info("Creating README using Pod::Text\n"); if ( open(my $fh, '>', 'README') ) { local $^W = 0; no strict "refs"; # work around bug in Pod::Text 3.01, which expects # Pod::Simple::parse_file to take input and output filehandles # when it actually only takes an input filehandle my $old_parse_file; $old_parse_file = \&{"Pod::Simple::parse_file"} and local *{"Pod::Simple::parse_file"} = sub { my $self = shift; $self->output_fh($_[1]) if $_[1]; $self->$old_parse_file($_[0]); } if $Pod::Text::VERSION == 3.01; # Split line to avoid evil version-finder Pod::Text::pod2text( $docfile, $fh ); close $fh; } else { $self->log_warn( "Cannot create 'README' file: Can't open file for writing\n" ); return; } } else { $self->log_warn("Can't load Pod::Readme or Pod::Text to create README\n"); return; } $self->_add_to_manifest('MANIFEST', 'README'); } sub _main_docfile { my $self = shift; if ( my $pm_file = $self->dist_version_from ) { (my $pod_file = $pm_file) =~ s/.pm$/.pod/; return (-e $pod_file ? $pod_file : $pm_file); } else { return undef; } } sub do_create_bundle_inc { my $self = shift; my $dist_inc = File::Spec->catdir( $self->dist_dir, 'inc' ); require inc::latest; inc::latest->write($dist_inc, @{$self->bundle_inc_preload}); inc::latest->bundle_module($_, $dist_inc) for @{$self->bundle_inc}; return 1; } sub ACTION_distdir { my ($self) = @_; if ( @{$self->bundle_inc} && ! $self->_mb_feature('inc_bundling_support') ) { $self->_warn_mb_feature_deps('inc_bundling_support'); die "Aborting.\n"; } $self->depends_on('distmeta'); my $dist_files = $self->_read_manifest('MANIFEST') or die "Can't create distdir without a MANIFEST file - run 'manifest' action first.\n"; delete $dist_files->{SIGNATURE}; # Don't copy, create a fresh one die "No files found in MANIFEST - try running 'manifest' action?\n" unless ($dist_files and keys %$dist_files); my $metafile = $self->metafile; $self->log_warn("*** Did you forget to add $metafile to the MANIFEST?\n") unless exists $dist_files->{$metafile}; my $dist_dir = $self->dist_dir; $self->delete_filetree($dist_dir); $self->log_info("Creating $dist_dir\n"); $self->add_to_cleanup($dist_dir); foreach my $file (sort keys %$dist_files) { next if $file =~ m{^MYMETA\.}; # Double check that we skip MYMETA.* my $new = $self->copy_if_modified(from => $file, to_dir => $dist_dir, verbose => 0); } $self->do_create_bundle_inc if @{$self->bundle_inc}; $self->_sign_dir($dist_dir) if $self->{properties}{sign}; } sub ACTION_disttest { my ($self) = @_; $self->depends_on('distdir'); $self->_do_in_dir ( $self->dist_dir, sub { local $ENV{AUTHOR_TESTING} = 1; local $ENV{RELEASE_TESTING} = 1; # XXX could be different names for scripts $self->run_perl_script('Build.PL') # XXX Should this be run w/ --nouse-rcfile or die "Error executing 'Build.PL' in dist directory: $!"; $self->run_perl_script($self->build_script) or die "Error executing $self->build_script in dist directory: $!"; $self->run_perl_script($self->build_script, [], ['test']) or die "Error executing 'Build test' in dist directory"; }); } sub ACTION_distinstall { my ($self, @args) = @_; $self->depends_on('distdir'); $self->_do_in_dir ( $self->dist_dir, sub { $self->run_perl_script('Build.PL') or die "Error executing 'Build.PL' in dist directory: $!"; $self->run_perl_script($self->build_script) or die "Error executing $self->build_script in dist directory: $!"; $self->run_perl_script($self->build_script, [], ['install']) or die "Error executing 'Build install' in dist directory"; } ); } =begin private my $has_include = $build->_eumanifest_has_include; Returns true if the installed version of ExtUtils::Manifest supports #include and #include_default directives. False otherwise. =end private =cut # #!include and #!include_default were added in 1.50 sub _eumanifest_has_include { my $self = shift; require ExtUtils::Manifest; return eval { ExtUtils::Manifest->VERSION(1.50); 1 }; } =begin private my $maniskip_file = $build->_default_maniskip; Returns the location of the installed MANIFEST.SKIP file used by default. =end private =cut sub _default_maniskip { my $self = shift; my $default_maniskip; for my $dir (@INC) { $default_maniskip = File::Spec->catfile($dir, "ExtUtils", "MANIFEST.SKIP"); last if -r $default_maniskip; } return $default_maniskip; } =begin private my $content = $build->_slurp($file); Reads $file and returns the $content. =end private =cut sub _slurp { my $self = shift; my $file = shift; my $mode = shift || ""; open my $fh, "<$mode", $file or croak "Can't open $file for reading: $!"; local $/; return <$fh>; } sub _spew { my $self = shift; my $file = shift; my $content = shift || ""; my $mode = shift || ""; open my $fh, ">$mode", $file or croak "Can't open $file for writing: $!"; print {$fh} $content; close $fh; } sub _case_tolerant { my $self = shift; if ( ref $self ) { $self->{_case_tolerant} = File::Spec->case_tolerant unless defined($self->{_case_tolerant}); return $self->{_case_tolerant}; } else { return File::Spec->case_tolerant; } } sub _append_maniskip { my $self = shift; my $skip = shift; my $file = shift || 'MANIFEST.SKIP'; return unless defined $skip && length $skip; open(my $fh, '>>', $file) or die "Can't open $file: $!"; print $fh "$skip\n"; close $fh; } sub _write_default_maniskip { my $self = shift; my $file = shift || 'MANIFEST.SKIP'; open(my $fh, '>', $file) or die "Can't open $file: $!"; my $content = $self->_eumanifest_has_include ? "#!include_default\n" : $self->_slurp( $self->_default_maniskip ); $content .= <<'EOF'; # Avoid configuration metadata file ^MYMETA\. # Avoid Module::Build generated and utility files. \bBuild$ \bBuild.bat$ \b_build \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ ^MANIFEST\.SKIP # Avoid archives of this distribution EOF # Skip, for example, 'Module-Build-0.27.tar.gz' $content .= '\b'.$self->dist_name.'-[\d\.\_]+'."\n"; print $fh $content; close $fh; return; } sub _check_manifest_skip { my ($self) = @_; my $maniskip = 'MANIFEST.SKIP'; if ( ! -e $maniskip ) { $self->log_warn("File '$maniskip' does not exist: Creating a temporary '$maniskip'\n"); $self->_write_default_maniskip($maniskip); $self->_unlink_on_exit($maniskip); } else { # MYMETA must not be added to MANIFEST, so always confirm the skip $self->_check_mymeta_skip( $maniskip ); } return; } sub ACTION_manifest { my ($self) = @_; $self->_check_manifest_skip; require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean. local ($^W, $ExtUtils::Manifest::Quiet) = (0,1); ExtUtils::Manifest::mkmanifest(); } sub ACTION_manifest_skip { my ($self) = @_; if ( -e 'MANIFEST.SKIP' ) { $self->log_warn("MANIFEST.SKIP already exists.\n"); return 0; } $self->log_info("Creating a new MANIFEST.SKIP file\n"); return $self->_write_default_maniskip; return -e 'MANIFEST.SKIP' } # Case insensitive regex for files sub file_qr { return shift->{_case_tolerant} ? qr($_[0])i : qr($_[0]); } sub dist_dir { my ($self) = @_; my $dir = join "-", $self->dist_name, $self->dist_version; $dir .= "-" . $self->dist_suffix if $self->dist_suffix; return $dir; } sub ppm_name { my $self = shift; return 'PPM-' . $self->dist_dir; } sub _files_in { my ($self, $dir) = @_; return unless -d $dir; local *DH; opendir DH, $dir or die "Can't read directory $dir: $!"; my @files; while (defined (my $file = readdir DH)) { my $full_path = File::Spec->catfile($dir, $file); next if -d $full_path; push @files, $full_path; } return @files; } sub share_dir { my $self = shift; my $p = $self->{properties}; $p->{share_dir} = shift if @_; # Always coerce to proper hash form if ( ! defined $p->{share_dir} ) { return; } elsif ( ! ref $p->{share_dir} ) { # scalar -- treat as a single 'dist' directory $p->{share_dir} = { dist => [ $p->{share_dir} ] }; } elsif ( ref $p->{share_dir} eq 'ARRAY' ) { # array -- treat as a list of 'dist' directories $p->{share_dir} = { dist => $p->{share_dir} }; } elsif ( ref $p->{share_dir} eq 'HASH' ) { # hash -- check structure my $share_dir = $p->{share_dir}; # check dist key if ( defined $share_dir->{dist} ) { if ( ! ref $share_dir->{dist} ) { # scalar, so upgrade to arrayref $share_dir->{dist} = [ $share_dir->{dist} ]; } elsif ( ref $share_dir->{dist} ne 'ARRAY' ) { die "'dist' key in 'share_dir' must be scalar or arrayref"; } } # check module key if ( defined $share_dir->{module} ) { my $mod_hash = $share_dir->{module}; if ( ref $mod_hash eq 'HASH' ) { for my $k ( sort keys %$mod_hash ) { if ( ! ref $mod_hash->{$k} ) { $mod_hash->{$k} = [ $mod_hash->{$k} ]; } elsif( ref $mod_hash->{$k} ne 'ARRAY' ) { die "modules in 'module' key of 'share_dir' must be scalar or arrayref"; } } } else { die "'module' key in 'share_dir' must be hashref"; } } } else { die "'share_dir' must be hashref, arrayref or string"; } return $p->{share_dir}; } sub script_files { my $self = shift; for ($self->{properties}{script_files}) { $_ = shift if @_; next unless $_; # Always coerce into a hash return $_ if ref $_ eq 'HASH'; return $_ = { map {$_,1} @$_ } if ref $_ eq 'ARRAY'; die "'script_files' must be a hashref, arrayref, or string" if ref(); return $_ = { map {$_,1} $self->_files_in( $_ ) } if -d $_; return $_ = {$_ => 1}; } my %pl_files = map { File::Spec->canonpath( $_ ) => 1 } keys %{ $self->PL_files || {} }; my @bin_files = $self->_files_in('bin'); my %bin_map = map { $_ => File::Spec->canonpath( $_ ) } @bin_files; return $_ = { map {$_ => 1} grep !$pl_files{$bin_map{$_}}, @bin_files }; } BEGIN { *scripts = \&script_files; } { my %licenses = ( perl => 'Perl_5', apache => 'Apache_2_0', apache_1_1 => 'Apache_1_1', artistic => 'Artistic_1', artistic_2 => 'Artistic_2', lgpl => 'LGPL_2_1', lgpl2 => 'LGPL_2_1', lgpl3 => 'LGPL_3_0', bsd => 'BSD', gpl => 'GPL_1', gpl2 => 'GPL_2', gpl3 => 'GPL_3', mit => 'MIT', mozilla => 'Mozilla_1_1', restrictive => 'Restricted', open_source => undef, unrestricted => undef, unknown => undef, ); # TODO - would be nice to not have these here, since they're more # properly stored only in Software::License my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', restrictive => undef, open_source => undef, unrestricted => undef, unknown => undef, ); sub valid_licenses { return \%licenses; } sub _license_url { return $license_urls{$_[1]}; } } sub _software_license_class { my ($self, $license) = @_; if ($self->valid_licenses->{$license} && eval { require Software::LicenseUtils; Software::LicenseUtils->VERSION(0.103009) }) { my @classes = Software::LicenseUtils->guess_license_from_meta_key($license, 1); if (@classes == 1) { eval "require $classes[0]"; return $classes[0]; } } LICENSE: for my $l ( $self->valid_licenses->{ $license }, $license ) { next unless defined $l; my $trial = "Software::License::" . $l; if ( eval "require Software::License; Software::License->VERSION(0.014); require $trial; 1" ) { return $trial; } } return; } # use mapping or license name directly sub _software_license_object { my ($self) = @_; return unless defined( my $license = $self->license ); my $class = $self->_software_license_class($license) or return; # Software::License requires a 'holder' argument my $author = join( " & ", @{ $self->dist_author }) || 'unknown'; my $sl = eval { $class->new({holder=>$author}) }; if ( $@ ) { $self->log_warn( "Error getting '$class' object: $@" ); } return $sl; } sub _hash_merge { my ($self, $h, $k, $v) = @_; if (ref $h->{$k} eq 'ARRAY') { push @{$h->{$k}}, ref $v ? @$v : $v; } elsif (ref $h->{$k} eq 'HASH') { $h->{$k}{$_} = $v->{$_} foreach keys %$v; } else { $h->{$k} = $v; } } sub ACTION_distmeta { my ($self) = @_; $self->do_create_makefile_pl if $self->create_makefile_pl; $self->do_create_readme if $self->create_readme; $self->do_create_license if $self->create_license; $self->do_create_metafile; } sub do_create_metafile { my $self = shift; return if $self->{wrote_metadata}; my $p = $self->{properties}; unless ($p->{license}) { $self->log_warn("No license specified, setting license = 'unknown'\n"); $p->{license} = 'unknown'; } my @metafiles = ( $self->metafile, $self->metafile2 ); # If we're in the distdir, the metafile may exist and be non-writable. $self->delete_filetree($_) for @metafiles; # Since we're building ourself, we have to do some special stuff # here: the ConfigData module is found in blib/lib. local @INC = @INC; if (($self->module_name || '') eq 'Module::Build') { $self->depends_on('config_data'); push @INC, File::Spec->catdir($self->blib, 'lib'); } my $meta_obj = $self->_get_meta_object( quiet => 1, fatal => 1, auto => 1 ); my @created = $self->_write_meta_files( $meta_obj, 'META' ); if ( @created ) { $self->{wrote_metadata} = 1; $self->_add_to_manifest('MANIFEST', $_) for @created; } return 1; } sub _write_meta_files { my $self = shift; my ($meta, $file) = @_; $file =~ s{\.(?:yml|json)$}{}; my @created; push @created, "$file\.yml" if $meta && $meta->save( "$file\.yml", {version => "1.4"} ); push @created, "$file\.json" if $meta && $meta->save( "$file\.json" ); if ( @created ) { $self->log_info("Created " . join(" and ", @created) . "\n"); } return @created; } sub _get_meta_object { my $self = shift; my %args = @_; return unless $self->try_require("CPAN::Meta", "2.142060"); my $meta; eval { my $data = $self->get_metadata( fatal => $args{fatal}, auto => $args{auto}, ); $data->{dynamic_config} = $args{dynamic} if defined $args{dynamic}; $meta = CPAN::Meta->create($data); }; if ($@ && ! $args{quiet}) { $self->log_warn( "Could not get valid metadata. Error is: $@\n" ); } return $meta; } sub read_metafile { my $self = shift; my ($metafile) = @_; return unless $self->try_require("CPAN::Meta", "2.110420"); my $meta = CPAN::Meta->load_file($metafile); return $meta->as_struct( {version => "2.0"} ); } sub normalize_version { my ($self, $version) = @_; $version = 0 unless defined $version and length $version; if ( $version =~ /[=<>!,]/ ) { # logic, not just version # take as is without modification } elsif ( ref $version eq 'version') { # version objects $version = $version->is_qv ? $version->normal : $version->stringify; } elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots # normalize string tuples without "v": "1.2.3" -> "v1.2.3" $version = "v$version"; } else { # leave alone } return $version; } my %prereq_map = ( requires => [ qw/runtime requires/], configure_requires => [qw/configure requires/], build_requires => [ qw/build requires/ ], test_requires => [ qw/test requires/ ], test_recommends => [ qw/test recommends/ ], recommends => [ qw/runtime recommends/ ], conflicts => [ qw/runtime conflicts/ ], ); sub _normalize_prereqs { my ($self) = @_; my $p = $self->{properties}; # copy prereq data structures so we can modify them before writing to META my %prereq_types; for my $type ( 'configure_requires', @{$self->prereq_action_types} ) { if (exists $p->{$type} and keys %{ $p->{$type} }) { my ($phase, $relation) = @{ $prereq_map{$type} }; for my $mod ( keys %{ $p->{$type} } ) { $prereq_types{$phase}{$relation}{$mod} = $self->normalize_version($p->{$type}{$mod}); } } } return \%prereq_types; } sub _get_license { my $self = shift; my $license = $self->license; my ($meta_license, $meta_license_url); my $valid_licenses = $self->valid_licenses(); if ( my $sl = $self->_software_license_object ) { $meta_license = $sl->meta2_name; $meta_license_url = $sl->url; } elsif ( exists $valid_licenses->{$license} ) { $meta_license = $valid_licenses->{$license} ? lc $valid_licenses->{$license} : $license; $meta_license_url = $self->_license_url( $license ); } else { $self->log_warn( "Can not determine license type for '" . $self->license . "'\nSetting META license field to 'unknown'.\n"); $meta_license = 'unknown'; } return ($meta_license, $meta_license_url); } sub get_metadata { my ($self, %args) = @_; my $fatal = $args{fatal} || 0; my $p = $self->{properties}; $self->auto_config_requires if $args{auto}; # validate required fields foreach my $f (qw(dist_name dist_version dist_author dist_abstract license)) { my $field = $self->$f(); unless ( defined $field and length $field ) { my $err = "ERROR: Missing required field '$f' for metafile\n"; if ( $fatal ) { die $err; } else { $self->log_warn($err); } } } my %metadata = ( name => $self->dist_name, version => $self->normalize_version($self->dist_version), author => $self->dist_author, abstract => $self->dist_abstract, generated_by => "Module::Build version $Module::Build::VERSION", 'meta-spec' => { version => '2', url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', }, dynamic_config => exists $p->{dynamic_config} ? $p->{dynamic_config} : 1, release_status => $self->release_status, ); my ($meta_license, $meta_license_url) = $self->_get_license; $metadata{license} = [ $meta_license ]; $metadata{resources}{license} = [ $meta_license_url ] if defined $meta_license_url; $metadata{prereqs} = $self->_normalize_prereqs; if (exists $p->{no_index}) { $metadata{no_index} = $p->{no_index}; } elsif (my $pkgs = eval { $self->find_dist_packages }) { $metadata{provides} = $pkgs if %$pkgs; } else { $self->log_warn("$@\nWARNING: Possible missing or corrupt 'MANIFEST' file.\n" . "Nothing to enter for 'provides' field in metafile.\n"); } if (my $add = $self->meta_add) { if (not exists $add->{'meta-spec'} or $add->{'meta-spec'}{version} != 2) { require CPAN::Meta::Converter; if (CPAN::Meta::Converter->VERSION('2.141170')) { $add = CPAN::Meta::Converter->new($add)->upgrade_fragment; delete $add->{prereqs}; # XXX this would now overwrite all prereqs } else { $self->log_warn("Can't meta_add without CPAN::Meta 2.141170"); } } while (my($k, $v) = each %{$add}) { $metadata{$k} = $v; } } if (my $merge = $self->meta_merge) { if (eval { require CPAN::Meta::Merge }) { %metadata = %{ CPAN::Meta::Merge->new(default_version => '1.4')->merge(\%metadata, $merge) }; } else { $self->log_warn("Can't merge without CPAN::Meta::Merge"); } } return \%metadata; } # To preserve compatibility with old API, $node *must* be a hashref # passed in to prepare_metadata. $keys is an arrayref holding a # list of keys -- it's use is optional and generally no longer needed # but kept for back compatibility. $args is an optional parameter to # support the new 'fatal' toggle sub prepare_metadata { my ($self, $node, $keys, $args) = @_; unless ( ref $node eq 'HASH' ) { croak "prepare_metadata() requires a hashref argument to hold output\n"; } croak 'Keys argument to prepare_metadata is no longer supported' if $keys; %{$node} = %{ $self->get_meta(%{$args}) }; return $node; } sub _read_manifest { my ($self, $file) = @_; return undef unless -e $file; require ExtUtils::Manifest; # ExtUtils::Manifest is not warnings clean. local ($^W, $ExtUtils::Manifest::Quiet) = (0,1); return scalar ExtUtils::Manifest::maniread($file); } sub find_dist_packages { my $self = shift; # Only packages in .pm files are candidates for inclusion here. # Only include things in the MANIFEST, not things in developer's # private stock. my $manifest = $self->_read_manifest('MANIFEST') or die "Can't find dist packages without a MANIFEST file\nRun 'Build manifest' to generate one\n"; # Localize my %dist_files = map { $self->localize_file_path($_) => $_ } keys %$manifest; my @pm_files = sort grep { $_ !~ m{^t} } # skip things in t/ grep {exists $dist_files{$_}} keys %{ $self->find_pm_files }; return $self->find_packages_in_files(\@pm_files, \%dist_files); } # XXX Do not document this function; mst wrote it and now says the API is # stupid and needs to be fixed and it shouldn't become a public API until then sub find_packages_in_files { my ($self, $file_list, $filename_map) = @_; # First, we enumerate all packages & versions, # separating into primary & alternative candidates my( %prime, %alt ); foreach my $file (@{$file_list}) { my $mapped_filename = $filename_map->{$file}; my @path = split( /\//, $mapped_filename ); (my $prime_package = join( '::', @path[1..$#path] )) =~ s/\.pm$//; my $pm_info = Module::Metadata->new_from_file( $file ); foreach my $package ( $pm_info->packages_inside ) { next if $package eq 'main'; # main can appear numerous times, ignore next if $package eq 'DB'; # special debugging package, ignore next if grep /^_/, split( /::/, $package ); # private package, ignore my $version = $pm_info->version( $package ); if ( $package eq $prime_package ) { if ( exists( $prime{$package} ) ) { # Module::Metadata will handle this conflict die "Unexpected conflict in '$package'; multiple versions found.\n"; } else { $prime{$package}{file} = $mapped_filename; $prime{$package}{version} = $version if defined( $version ); } } else { push( @{$alt{$package}}, { file => $mapped_filename, version => $version, } ); } } } # Then we iterate over all the packages found above, identifying conflicts # and selecting the "best" candidate for recording the file & version # for each package. foreach my $package ( sort keys( %alt ) ) { my $result = $self->_resolve_module_versions( $alt{$package} ); if ( exists( $prime{$package} ) ) { # primary package selected if ( $result->{err} ) { # Use the selected primary package, but there are conflicting # errors among multiple alternative packages that need to be # reported $self->log_warn( "Found conflicting versions for package '$package'\n" . " $prime{$package}{file} ($prime{$package}{version})\n" . $result->{err} ); } elsif ( defined( $result->{version} ) ) { # There is a primary package selected, and exactly one # alternative package if ( exists( $prime{$package}{version} ) && defined( $prime{$package}{version} ) ) { # Unless the version of the primary package agrees with the # version of the alternative package, report a conflict if ( $self->compare_versions( $prime{$package}{version}, '!=', $result->{version} ) ) { $self->log_warn( "Found conflicting versions for package '$package'\n" . " $prime{$package}{file} ($prime{$package}{version})\n" . " $result->{file} ($result->{version})\n" ); } } else { # The prime package selected has no version so, we choose to # use any alternative package that does have a version $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version}; } } else { # no alt package found with a version, but we have a prime # package so we use it whether it has a version or not } } else { # No primary package was selected, use the best alternative if ( $result->{err} ) { $self->log_warn( "Found conflicting versions for package '$package'\n" . $result->{err} ); } # Despite possible conflicting versions, we choose to record # something rather than nothing $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version} if defined( $result->{version} ); } } # Normalize versions or delete them if undef/0 for my $provides ( values %prime ) { if ( $provides->{version} ) { $provides->{version} = $self->normalize_version( $provides->{version} ) } else { delete $provides->{version}; } } return \%prime; } # separate out some of the conflict resolution logic from # $self->find_dist_packages(), above, into a helper function. # sub _resolve_module_versions { my $self = shift; my $packages = shift; my( $file, $version ); my $err = ''; foreach my $p ( @$packages ) { if ( defined( $p->{version} ) ) { if ( defined( $version ) ) { if ( $self->compare_versions( $version, '!=', $p->{version} ) ) { $err .= " $p->{file} ($p->{version})\n"; } else { # same version declared multiple times, ignore } } else { $file = $p->{file}; $version = $p->{version}; } } $file ||= $p->{file} if defined( $p->{file} ); } if ( $err ) { $err = " $file ($version)\n" . $err; } my %result = ( file => $file, version => $version, err => $err ); return \%result; } sub make_tarball { my ($self, $dir, $file) = @_; $file ||= $dir; $self->log_info("Creating $file.tar.gz\n"); if ($self->{args}{tar}) { my $tar_flags = $self->verbose ? 'cvf' : 'cf'; # See ExtUtils::MM_Darwin # 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE. # 10.5 wants COPYFILE_DISABLE. # So just set both. local $ENV{COPY_EXTENDED_ATTRIBUTES_DISABLE} = 1 if $^O eq 'darwin'; local $ENV{COPYFILE_DISABLE} = 1 if $^O eq 'darwin'; $self->do_system($self->split_like_shell($self->{args}{tar}), $tar_flags, "$file.tar", $dir); $self->do_system($self->split_like_shell($self->{args}{gzip}), "$file.tar") if $self->{args}{gzip}; } else { eval { require Archive::Tar && Archive::Tar->VERSION(1.09); 1 } or die "You must install Archive::Tar 1.09+ to make a distribution tarball\n". "or specify a binary tar program with the '--tar' option.\n". "See the documentation for the 'dist' action.\n"; my $files = $self->rscan_dir($dir); # Archive::Tar versions >= 1.09 use the following to enable a compatibility # hack so that the resulting archive is compatible with older clients. # If no file path is 100 chars or longer, we disable the prefix field # for maximum compatibility. If there are any long file paths then we # need the prefix field after all. $Archive::Tar::DO_NOT_USE_PREFIX = (grep { length($_) >= 100 } @$files) ? 0 : 1; my $tar = Archive::Tar->new; $tar->add_files(@$files); for my $f ($tar->get_files) { $f->mode($f->mode & ~022); # chmod go-w } $tar->write("$file.tar.gz", 1); } } sub install_path { my $self = shift; my( $type, $value ) = ( @_, '' ); Carp::croak( 'Type argument missing' ) unless defined( $type ); my $map = $self->{properties}{install_path}; return $map unless @_; # delete existing value if $value is literal undef() unless ( defined( $value ) ) { delete( $map->{$type} ); return undef; } # return existing value if no new $value is given if ( $value eq '' ) { return undef unless exists $map->{$type}; return $map->{$type}; } # set value if $value is a valid relative path return $map->{$type} = $value; } sub install_sets { # Usage: install_sets('site'), install_sets('site', 'lib'), # or install_sets('site', 'lib' => $value); my ($self, $dirs, $key, $value) = @_; $dirs = $self->installdirs unless defined $dirs; # update property before merging with defaults if ( @_ == 4 && defined $dirs && defined $key) { # $value can be undef; will mask default $self->{properties}{install_sets}{$dirs}{$key} = $value; } my $map = { $self->_merge_arglist( $self->{properties}{install_sets}, $self->_default_install_paths->{install_sets} )}; if ( defined $dirs && defined $key ) { return $map->{$dirs}{$key}; } elsif ( defined $dirs ) { return $map->{$dirs}; } else { croak "Can't determine installdirs for install_sets()"; } } sub original_prefix { # Usage: original_prefix(), original_prefix('lib'), # or original_prefix('lib' => $value); my ($self, $key, $value) = @_; # update property before merging with defaults if ( @_ == 3 && defined $key) { # $value can be undef; will mask default $self->{properties}{original_prefix}{$key} = $value; } my $map = { $self->_merge_arglist( $self->{properties}{original_prefix}, $self->_default_install_paths->{original_prefix} )}; return $map unless defined $key; return $map->{$key} } sub install_base_relpaths { # Usage: install_base_relpaths(), install_base_relpaths('lib'), # or install_base_relpaths('lib' => $value); my $self = shift; if ( @_ > 1 ) { # change values before merge $self->_set_relpaths($self->{properties}{install_base_relpaths}, @_); } my $map = { $self->_merge_arglist( $self->{properties}{install_base_relpaths}, $self->_default_install_paths->{install_base_relpaths} )}; return $map unless @_; my $relpath = $map->{$_[0]}; return defined $relpath ? File::Spec->catdir( @$relpath ) : undef; } # Defaults to use in case the config install paths cannot be prefixified. sub prefix_relpaths { # Usage: prefix_relpaths('site'), prefix_relpaths('site', 'lib'), # or prefix_relpaths('site', 'lib' => $value); my $self = shift; my $installdirs = shift || $self->installdirs or croak "Can't determine installdirs for prefix_relpaths()"; if ( @_ > 1 ) { # change values before merge $self->{properties}{prefix_relpaths}{$installdirs} ||= {}; $self->_set_relpaths($self->{properties}{prefix_relpaths}{$installdirs}, @_); } my $map = {$self->_merge_arglist( $self->{properties}{prefix_relpaths}{$installdirs}, $self->_default_install_paths->{prefix_relpaths}{$installdirs} )}; return $map unless @_; my $relpath = $map->{$_[0]}; return defined $relpath ? File::Spec->catdir( @$relpath ) : undef; } sub _set_relpaths { my $self = shift; my( $map, $type, $value ) = @_; Carp::croak( 'Type argument missing' ) unless defined( $type ); # set undef if $value is literal undef() if ( ! defined( $value ) ) { $map->{$type} = undef; return; } # set value if $value is a valid relative path else { Carp::croak( "Value must be a relative path" ) if File::Spec::Unix->file_name_is_absolute($value); my @value = split( /\//, $value ); $map->{$type} = \@value; } } # Translated from ExtUtils::MM_Any::init_INSTALL_from_PREFIX sub prefix_relative { my ($self, $type) = @_; my $installdirs = $self->installdirs; my $relpath = $self->install_sets($installdirs)->{$type}; return $self->_prefixify($relpath, $self->original_prefix($installdirs), $type, ); } # Translated from ExtUtils::MM_Unix::prefixify() sub _prefixify { my($self, $path, $sprefix, $type) = @_; my $rprefix = $self->prefix; $rprefix .= '/' if $sprefix =~ m|/$|; $self->log_verbose(" prefixify $path from $sprefix to $rprefix\n") if defined( $path ) && length( $path ); if( !defined( $path ) || ( length( $path ) == 0 ) ) { $self->log_verbose(" no path to prefixify, falling back to default.\n"); return $self->_prefixify_default( $type, $rprefix ); } elsif( !File::Spec->file_name_is_absolute($path) ) { $self->log_verbose(" path is relative, not prefixifying.\n"); } elsif( $path !~ s{^\Q$sprefix\E\b}{}s ) { $self->log_verbose(" cannot prefixify, falling back to default.\n"); return $self->_prefixify_default( $type, $rprefix ); } $self->log_verbose(" now $path in $rprefix\n"); return $path; } sub _prefixify_default { my $self = shift; my $type = shift; my $rprefix = shift; my $default = $self->prefix_relpaths($self->installdirs, $type); if( !$default ) { $self->log_verbose(" no default install location for type '$type', using prefix '$rprefix'.\n"); return $rprefix; } else { return $default; } } sub install_destination { my ($self, $type) = @_; return $self->install_path($type) if $self->install_path($type); if ( $self->install_base ) { my $relpath = $self->install_base_relpaths($type); return $relpath ? File::Spec->catdir($self->install_base, $relpath) : undef; } if ( $self->prefix ) { my $relpath = $self->prefix_relative($type); return $relpath ? File::Spec->catdir($self->prefix, $relpath) : undef; } return $self->install_sets($self->installdirs)->{$type}; } sub install_types { my $self = shift; my %types; if ( $self->install_base ) { %types = %{$self->install_base_relpaths}; } elsif ( $self->prefix ) { %types = %{$self->prefix_relpaths}; } else { %types = %{$self->install_sets($self->installdirs)}; } %types = (%types, %{$self->install_path}); return sort keys %types; } sub install_map { my ($self, $blib) = @_; $blib ||= $self->blib; my( %map, @skipping ); foreach my $type ($self->install_types) { my $localdir = File::Spec->catdir( $blib, $type ); next unless -e $localdir; # the line "...next if (($type eq 'bindoc'..." was one of many changes introduced for # improving HTML generation on ActivePerl, see https://rt.cpan.org/Public/Bug/Display.html?id=53478 # Most changes were ok, but this particular line caused test failures in t/manifypods.t on windows, # therefore it is commented out. # ********* next if (($type eq 'bindoc' || $type eq 'libdoc') && not $self->is_unixish); if (my $dest = $self->install_destination($type)) { $map{$localdir} = $dest; } else { push( @skipping, $type ); } } $self->log_warn( "WARNING: Can't figure out install path for types: @skipping\n" . "Files will not be installed.\n" ) if @skipping; # Write the packlist into the same place as ExtUtils::MakeMaker. if ($self->create_packlist and my $module_name = $self->module_name) { my $archdir = $self->install_destination('arch'); my @ext = split /::/, $module_name; $map{write} = File::Spec->catfile($archdir, 'auto', @ext, '.packlist'); } # Handle destdir if (length(my $destdir = $self->destdir || '')) { foreach (keys %map) { # Need to remove volume from $map{$_} using splitpath, or else # we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux # VMS will always have the file separate than the path. my ($volume, $path, $file) = File::Spec->splitpath( $map{$_}, 0 ); # catdir needs a list of directories, or it will create something # crazy like volume:[Foo.Bar.volume.Baz.Quux] my @dirs = File::Spec->splitdir($path); # First merge the directories $path = File::Spec->catdir($destdir, @dirs); # Then put the file back on if there is one. if ($file ne '') { $map{$_} = File::Spec->catfile($path, $file) } else { $map{$_} = $path; } } } $map{read} = ''; # To keep ExtUtils::Install quiet return \%map; } sub depends_on { my $self = shift; foreach my $action (@_) { $self->_call_action($action); } } sub rscan_dir { my ($self, $dir, $pattern) = @_; my @result; local $_; # find() can overwrite $_, so protect ourselves my $subr = !$pattern ? sub {push @result, $File::Find::name} : !ref($pattern) || (ref $pattern eq 'Regexp') ? sub {push @result, $File::Find::name if /$pattern/} : ref($pattern) eq 'CODE' ? sub {push @result, $File::Find::name if $pattern->()} : die "Unknown pattern type"; File::Find::find({wanted => $subr, no_chdir => 1, preprocess => sub { sort @_ } }, $dir); return \@result; } sub delete_filetree { my $self = shift; my $deleted = 0; foreach (@_) { next unless -e $_; $self->log_verbose("Deleting $_\n"); File::Path::rmtree($_, 0, 0); die "Couldn't remove '$_': $!\n" if -e $_; $deleted++; } return $deleted; } sub autosplit_file { my ($self, $file, $to) = @_; require AutoSplit; my $dir = File::Spec->catdir($to, 'lib', 'auto'); AutoSplit::autosplit($file, $dir); } sub cbuilder { # Returns a CBuilder object my $self = shift; my $s = $self->{stash}; return $s->{_cbuilder} if $s->{_cbuilder}; require ExtUtils::CBuilder; return $s->{_cbuilder} = ExtUtils::CBuilder->new( config => $self->config, ($self->quiet ? (quiet => 1 ) : ()), ); } sub have_c_compiler { my ($self) = @_; my $p = $self->{properties}; return $p->{_have_c_compiler} if defined $p->{_have_c_compiler}; $self->log_verbose("Checking if compiler tools configured... "); my $b = $self->cbuilder; my $have = $b && eval { $b->have_compiler }; $self->log_verbose($have ? "ok.\n" : "failed.\n"); return $p->{_have_c_compiler} = $have; } sub compile_c { my ($self, $file, %args) = @_; if ( ! $self->have_c_compiler ) { die "Error: no compiler detected to compile '$file'. Aborting\n"; } my $b = $self->cbuilder; my $obj_file = $b->object_file($file); $self->add_to_cleanup($obj_file); return $obj_file if $self->up_to_date($file, $obj_file); $b->compile(source => $file, defines => $args{defines}, object_file => $obj_file, include_dirs => $self->include_dirs, extra_compiler_flags => $self->extra_compiler_flags, ); return $obj_file; } sub link_c { my ($self, $spec) = @_; my $p = $self->{properties}; # For convenience $self->add_to_cleanup($spec->{lib_file}); my $objects = $p->{objects} || []; return $spec->{lib_file} if $self->up_to_date([$spec->{obj_file}, @$objects], $spec->{lib_file}); my $module_name = $spec->{module_name} || $self->module_name; $self->cbuilder->link( module_name => $module_name, objects => [$spec->{obj_file}, @$objects], lib_file => $spec->{lib_file}, extra_linker_flags => $self->extra_linker_flags ); return $spec->{lib_file}; } sub compile_xs { my ($self, $file, %args) = @_; $self->log_verbose("$file -> $args{outfile}\n"); if (eval {require ExtUtils::ParseXS; 1}) { ExtUtils::ParseXS::process_file( filename => $file, prototypes => 0, output => $args{outfile}, ); } else { # Ok, I give up. Just use backticks. my $xsubpp = Module::Metadata->find_module_by_name('ExtUtils::xsubpp') or die "Can't find ExtUtils::xsubpp in INC (@INC)"; my @typemaps; push @typemaps, Module::Metadata->find_module_by_name( 'ExtUtils::typemap', \@INC ); my $lib_typemap = Module::Metadata->find_module_by_name( 'typemap', [File::Basename::dirname($file), File::Spec->rel2abs('.')] ); push @typemaps, $lib_typemap if $lib_typemap; @typemaps = map {+'-typemap', $_} @typemaps; my $cf = $self->{config}; my $perl = $self->{properties}{perl}; my @command = ($perl, "-I".$cf->get('installarchlib'), "-I".$cf->get('installprivlib'), $xsubpp, '-noprototypes', @typemaps, $file); $self->log_info("@command\n"); open(my $fh, '>', $args{outfile}) or die "Couldn't write $args{outfile}: $!"; print {$fh} $self->_backticks(@command); close $fh; } } sub split_like_shell { my ($self, $string) = @_; return () unless defined($string); return @$string if ref $string eq 'ARRAY'; $string =~ s/^\s+|\s+$//g; return () unless length($string); return Text::ParseWords::shellwords($string); } sub oneliner { # Returns a string that the shell can evaluate as a perl command. # This should be avoided whenever possible, since "the shell" really # means zillions of shells on zillions of platforms and it's really # hard to get it right all the time. # Some of this code is stolen with permission from ExtUtils::MakeMaker. my($self, $cmd, $switches, $args) = @_; $switches = [] unless defined $switches; $args = [] unless defined $args; # Strip leading and trailing newlines $cmd =~ s{^\n+}{}; $cmd =~ s{\n+$}{}; my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter; return $self->_quote_args($perl, @$switches, '-e', $cmd, @$args); } sub run_perl_script { my ($self, $script, $preargs, $postargs) = @_; foreach ($preargs, $postargs) { $_ = [ $self->split_like_shell($_) ] unless ref(); } return $self->run_perl_command([@$preargs, $script, @$postargs]); } sub run_perl_command { # XXX Maybe we should accept @args instead of $args? Must resolve # this before documenting. my ($self, $args) = @_; $args = [ $self->split_like_shell($args) ] unless ref($args); my $perl = ref($self) ? $self->perl : $self->find_perl_interpreter; # Make sure our local additions to @INC are propagated to the subprocess local $ENV{PERL5LIB} = join $self->config('path_sep'), $self->_added_to_INC; return $self->do_system($perl, @$args); } # Infer various data from the path of the input filename # that is needed to create output files. # The input filename is expected to be of the form: # lib/Module/Name.ext or Module/Name.ext sub _infer_xs_spec { my $self = shift; my $file = shift; my $cf = $self->{config}; my %spec; my( $v, $d, $f ) = File::Spec->splitpath( $file ); my @d = File::Spec->splitdir( $d ); (my $file_base = $f) =~ s/\.[^.]+$//i; $spec{base_name} = $file_base; $spec{src_dir} = File::Spec->catpath( $v, $d, '' ); # the module name shift( @d ) while @d && ($d[0] eq 'lib' || $d[0] eq ''); pop( @d ) while @d && $d[-1] eq ''; $spec{module_name} = join( '::', (@d, $file_base) ); $spec{archdir} = File::Spec->catdir($self->blib, 'arch', 'auto', @d, $file_base); $spec{c_file} = File::Spec->catfile( $spec{src_dir}, "${file_base}.c" ); $spec{obj_file} = File::Spec->catfile( $spec{src_dir}, "${file_base}".$cf->get('obj_ext') ); require DynaLoader; my $modfname = defined &DynaLoader::mod2fname ? DynaLoader::mod2fname([@d, $file_base]) : $file_base; $spec{bs_file} = File::Spec->catfile($spec{archdir}, "$modfname.bs"); $spec{lib_file} = File::Spec->catfile($spec{archdir}, "$modfname.".$cf->get('dlext')); return \%spec; } sub process_xs { my ($self, $file) = @_; my $spec = $self->_infer_xs_spec($file); # File name, minus the suffix (my $file_base = $file) =~ s/\.[^.]+$//; # .xs -> .c $self->add_to_cleanup($spec->{c_file}); unless ($self->up_to_date($file, $spec->{c_file})) { $self->compile_xs($file, outfile => $spec->{c_file}); } # .c -> .o my $v = $self->dist_version; $self->compile_c($spec->{c_file}, defines => {VERSION => qq{"$v"}, XS_VERSION => qq{"$v"}}); # archdir File::Path::mkpath($spec->{archdir}, 0, oct(777)) unless -d $spec->{archdir}; # .xs -> .bs $self->add_to_cleanup($spec->{bs_file}); unless ($self->up_to_date($file, $spec->{bs_file})) { require ExtUtils::Mkbootstrap; $self->log_info("ExtUtils::Mkbootstrap::Mkbootstrap('$spec->{bs_file}')\n"); ExtUtils::Mkbootstrap::Mkbootstrap($spec->{bs_file}); # Original had $BSLOADLIBS - what's that? open(my $fh, '>>', $spec->{bs_file}); # create utime((time)x2, $spec->{bs_file}); # touch } # .o -> .(a|bundle) $self->link_c($spec); } sub do_system { my ($self, @cmd) = @_; $self->log_verbose("@cmd\n"); # Some systems proliferate huge PERL5LIBs, try to ameliorate: my %seen; my $sep = $self->config('path_sep'); local $ENV{PERL5LIB} = ( !exists($ENV{PERL5LIB}) ? '' : length($ENV{PERL5LIB}) < 500 ? $ENV{PERL5LIB} : join $sep, grep { ! $seen{$_}++ and -d $_ } split($sep, $ENV{PERL5LIB}) ); my $status = system(@cmd); if ($status and $! =~ /Argument list too long/i) { my $env_entries = ''; foreach (sort keys %ENV) { $env_entries .= "$_=>".length($ENV{$_})."; " } warn "'Argument list' was 'too long', env lengths are $env_entries"; } return !$status; } sub copy_if_modified { my $self = shift; my %args = (@_ > 3 ? ( @_ ) : ( from => shift, to_dir => shift, flatten => shift ) ); $args{verbose} = !$self->quiet unless exists $args{verbose}; my $file = $args{from}; unless (defined $file and length $file) { die "No 'from' parameter given to copy_if_modified"; } # makes no sense to replicate an absolute path, so assume flatten $args{flatten} = 1 if File::Spec->file_name_is_absolute( $file ); my $to_path; if (defined $args{to} and length $args{to}) { $to_path = $args{to}; } elsif (defined $args{to_dir} and length $args{to_dir}) { $to_path = File::Spec->catfile( $args{to_dir}, $args{flatten} ? File::Basename::basename($file) : $file ); } else { die "No 'to' or 'to_dir' parameter given to copy_if_modified"; } return if $self->up_to_date($file, $to_path); # Already fresh { local $self->{properties}{quiet} = 1; $self->delete_filetree($to_path); # delete destination if exists } # Create parent directories File::Path::mkpath(File::Basename::dirname($to_path), 0, oct(777)); $self->log_verbose("Copying $file -> $to_path\n"); if ($^O eq 'os2') {# copy will not overwrite; 0x1 = overwrite chmod 0666, $to_path; File::Copy::syscopy($file, $to_path, 0x1) or die "Can't copy('$file', '$to_path'): $!"; } else { File::Copy::copy($file, $to_path) or die "Can't copy('$file', '$to_path'): $!"; } # mode is read-only + (executable if source is executable) my $mode = oct(444) | ( $self->is_executable($file) ? oct(111) : 0 ); chmod( $mode, $to_path ); return $to_path; } sub up_to_date { my ($self, $source, $derived) = @_; $source = [$source] unless ref $source; $derived = [$derived] unless ref $derived; # empty $derived means $source should always run return 0 if @$source && !@$derived || grep {not -e} @$derived; my $most_recent_source = time / (24*60*60); foreach my $file (@$source) { unless (-e $file) { $self->log_warn("Can't find source file $file for up-to-date check"); next; } $most_recent_source = -M _ if -M _ < $most_recent_source; } foreach my $derived (@$derived) { return 0 if -M $derived > $most_recent_source; } return 1; } sub dir_contains { my ($self, $first, $second) = @_; # File::Spec doesn't have an easy way to check whether one directory # is inside another, unfortunately. ($first, $second) = map File::Spec->canonpath($_), ($first, $second); my @first_dirs = File::Spec->splitdir($first); my @second_dirs = File::Spec->splitdir($second); return 0 if @second_dirs < @first_dirs; my $is_same = ( $self->_case_tolerant ? sub {lc(shift()) eq lc(shift())} : sub {shift() eq shift()} ); while (@first_dirs) { return 0 unless $is_same->(shift @first_dirs, shift @second_dirs); } return 1; } 1; __END__ =head1 NAME Module::Build::Base - Default methods for Module::Build =head1 SYNOPSIS Please see the Module::Build documentation. =head1 DESCRIPTION The C module defines the core functionality of C. Its methods may be overridden by any of the platform-dependent modules in the C namespace, but the intention here is to make this base module as platform-neutral as possible. Nicely enough, Perl has several core tools available in the C namespace for doing this, so the task isn't very difficult. Please see the C documentation for more details. =head1 AUTHOR Ken Williams =head1 COPYRIGHT Copyright (c) 2001-2006 Ken Williams. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO perl(1), Module::Build(3) =cut Tiny.pm100444001750001750 2505714546072342 26045 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/local/lib/perl5/Module/Buildpackage Module::Build::Tiny; $Module::Build::Tiny::VERSION = '0.047'; use strict; use warnings; use Exporter 5.57 'import'; our @EXPORT = qw/Build Build_PL/; use CPAN::Meta; use ExtUtils::Config 0.003; use ExtUtils::Helpers 0.020 qw/make_executable split_like_shell man1_pagename man3_pagename detildefy/; use ExtUtils::Install qw/pm_to_blib install/; use ExtUtils::InstallPaths 0.002; use File::Basename qw/basename dirname/; use File::Find (); use File::Path qw/mkpath rmtree/; use File::Spec::Functions qw/catfile catdir rel2abs abs2rel splitdir curdir/; use Getopt::Long 2.36 qw/GetOptionsFromArray/; use JSON::PP 2 qw/encode_json decode_json/; sub write_file { my ($filename, $content) = @_; open my $fh, '>', $filename or die "Could not open $filename: $!\n"; print $fh $content; } sub read_file { my ($filename) = @_; open my $fh, '<', $filename or die "Could not open $filename: $!\n"; return do { local $/; <$fh> }; } sub get_meta { my ($metafile) = grep { -e $_ } qw/META.json META.yml/ or die "No META information provided\n"; return CPAN::Meta->load_file($metafile); } sub manify { my ($input_file, $output_file, $section, $opts) = @_; return if -e $output_file && -M $input_file <= -M $output_file; my $dirname = dirname($output_file); mkpath($dirname, $opts->{verbose}) if not -d $dirname; require Pod::Man; Pod::Man->new(section => $section)->parse_from_file($input_file, $output_file); print "Manifying $output_file\n" if $opts->{verbose} && $opts->{verbose} > 0; return; } sub process_xs { my ($source, $options, $c_files) = @_; die "Can't build xs files under --pureperl-only\n" if $options->{'pureperl-only'}; my (undef, @parts) = splitdir(dirname($source)); push @parts, my $file_base = basename($source, '.xs'); my $archdir = catdir(qw/blib arch auto/, @parts); my $tempdir = 'temp'; my $c_file = catfile($tempdir, "$file_base.c"); require ExtUtils::ParseXS; mkpath($tempdir, $options->{verbose}, oct '755'); ExtUtils::ParseXS::process_file(filename => $source, prototypes => 0, output => $c_file); my $version = $options->{meta}->version; require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new(config => $options->{config}->values_set); my @objects = $builder->compile(source => $c_file, defines => { VERSION => qq/"$version"/, XS_VERSION => qq/"$version"/ }, include_dirs => [ curdir, 'include', 'src', dirname($source) ]); my $o = $options->{config}->get('_o'); for my $c_source (@{ $c_files }) { my $o_file = catfile($tempdir, basename($c_source, '.c') . $o); push @objects, $builder->compile(source => $c_source, include_dirs => [ curdir, 'include', 'src', dirname($c_source) ]) } require DynaLoader; my $mod2fname = defined &DynaLoader::mod2fname ? \&DynaLoader::mod2fname : sub { return $_[0][-1] }; mkpath($archdir, $options->{verbose}, oct '755') unless -d $archdir; my $lib_file = catfile($archdir, $mod2fname->(\@parts) . '.' . $options->{config}->get('dlext')); return $builder->link(objects => \@objects, lib_file => $lib_file, module_name => join '::', @parts); } sub find { my ($pattern, $dir) = @_; my @ret; File::Find::find(sub { push @ret, $File::Find::name if /$pattern/ && -f }, $dir) if -d $dir; return @ret; } sub contains_pod { my ($file) = @_; return unless -T $file; return read_file($file) =~ /^\=(?:head|pod|item)/m; } my %actions = ( build => sub { my %opt = @_; for my $pl_file (find(qr/\.PL$/, 'lib')) { (my $pm = $pl_file) =~ s/\.PL$//; system $^X, $pl_file, $pm and die "$pl_file returned $?\n"; } my %modules = map { $_ => catfile('blib', $_) } find(qr/\.pm$/, 'lib'); my %docs = map { $_ => catfile('blib', $_) } find(qr/\.pod$/, 'lib'); my %scripts = map { $_ => catfile('blib', $_) } find(qr/(?:)/, 'script'); my %sdocs = map { $_ => delete $scripts{$_} } grep { /.pod$/ } keys %scripts; my %dist_shared = map { $_ => catfile(qw/blib lib auto share dist/, $opt{meta}->name, abs2rel($_, 'share')) } find(qr/(?:)/, 'share'); my %module_shared = map { $_ => catfile(qw/blib lib auto share module/, abs2rel($_, 'module-share')) } find(qr/(?:)/, 'module-share'); pm_to_blib({ %modules, %docs, %scripts, %dist_shared, %module_shared }, catdir(qw/blib lib auto/)); make_executable($_) for values %scripts; mkpath(catdir(qw/blib arch/), $opt{verbose}); my $main_xs = join('/', 'lib', split /-/, $opt{meta}->name) . '.xs'; for my $xs (find(qr/.xs$/, 'lib')) { my @c_files = $xs eq $main_xs ? find(qr/\.c$/, 'src') : (); process_xs($xs, \%opt, \@c_files); } if ($opt{install_paths}->install_destination('bindoc') && $opt{install_paths}->is_default_installable('bindoc')) { my $section = $opt{config}->get('man1ext'); for my $input (keys %scripts, keys %sdocs) { next unless contains_pod($input); my $output = catfile('blib', 'bindoc', man1_pagename($input)); manify($input, $output, $section, \%opt); } } if ($opt{install_paths}->install_destination('libdoc') && $opt{install_paths}->is_default_installable('libdoc')) { my $section = $opt{config}->get('man3ext'); for my $input (keys %modules, keys %docs) { next unless contains_pod($input); my $output = catfile('blib', 'libdoc', man3_pagename($input)); manify($input, $output, $section, \%opt); } } return 0; }, test => sub { my %opt = @_; die "Must run `./Build build` first\n" if not -d 'blib'; require TAP::Harness::Env; my %test_args = ( (verbosity => $opt{verbose}) x!! exists $opt{verbose}, (jobs => $opt{jobs}) x!! exists $opt{jobs}, (color => 1) x !!-t STDOUT, lib => [ map { rel2abs(catdir(qw/blib/, $_)) } qw/arch lib/ ], ); my $tester = TAP::Harness::Env->create(\%test_args); return $tester->runtests(sort +find(qr/\.t$/, 't'))->has_errors; }, install => sub { my %opt = @_; die "Must run `./Build build` first\n" if not -d 'blib'; install($opt{install_paths}->install_map, @opt{qw/verbose dry_run uninst/}); return 0; }, clean => sub { my %opt = @_; rmtree($_, $opt{verbose}) for qw/blib temp/; return 0; }, realclean => sub { my %opt = @_; rmtree($_, $opt{verbose}) for qw/blib temp Build _build_params MYMETA.yml MYMETA.json/; return 0; }, ); sub Build { my $action = @ARGV && $ARGV[0] =~ /\A\w+\z/ ? shift @ARGV : 'build'; die "No such action '$action'\n" if not $actions{$action}; my($env, $bargv) = @{ decode_json(read_file('_build_params')) }; my %opt; GetOptionsFromArray($_, \%opt, qw/install_base=s install_path=s% installdirs=s destdir=s prefix=s config=s% uninst:1 verbose:1 dry_run:1 pureperl-only:1 create_packlist=i jobs=i/) for ($env, $bargv, \@ARGV); $_ = detildefy($_) for grep { defined } @opt{qw/install_base destdir prefix/}, values %{ $opt{install_path} }; @opt{ 'config', 'meta' } = (ExtUtils::Config->new($opt{config}), get_meta()); exit $actions{$action}->(%opt, install_paths => ExtUtils::InstallPaths->new(%opt, dist_name => $opt{meta}->name)); } sub Build_PL { my $meta = get_meta(); printf "Creating new 'Build' script for '%s' version '%s'\n", $meta->name, $meta->version; my $dir = $meta->name eq 'Module-Build-Tiny' ? "use lib 'lib';" : ''; write_file('Build', "#!perl\n$dir\nuse Module::Build::Tiny;\nBuild();\n"); make_executable('Build'); my @env = defined $ENV{PERL_MB_OPT} ? split_like_shell($ENV{PERL_MB_OPT}) : (); write_file('_build_params', encode_json([ \@env, \@ARGV ])); $meta->save(@$_) for ['MYMETA.json'], [ 'MYMETA.yml' => { version => 1.4 } ]; } 1; #ABSTRACT: A tiny replacement for Module::Build # vi:noet:sts=4:sw=4:ts=4 __END__ =pod =encoding UTF-8 =head1 NAME Module::Build::Tiny - A tiny replacement for Module::Build =head1 VERSION version 0.047 =head1 SYNOPSIS use Module::Build::Tiny; Build_PL(); =head1 DESCRIPTION Many Perl distributions use a Build.PL file instead of a Makefile.PL file to drive distribution configuration, build, test and installation. Traditionally, Build.PL uses Module::Build as the underlying build system. This module provides a simple, lightweight, drop-in replacement. Whereas Module::Build has over 6,700 lines of code; this module has less than 200, yet supports the features needed by most distributions. =head2 Supported =over 4 =item * Pure Perl distributions =item * Building XS or C =item * Recursive test files =item * MYMETA =item * Man page generation =item * Generated code from PL files =item * Module sharedirs =back =head2 Not Supported =over 4 =item * Dynamic prerequisites =item * HTML documentation generation =item * Extending Module::Build::Tiny =back =head2 Directory structure Your .pm, .xs and .pod files must be in F. Any executables must be in F]; } my $html .= < $javascript END return $html; } sub _login_styles { my $self = shift; my $login_form = $self->_cgiapp->authen->_config->{LOGIN_FORM} || {}; my %colour = (); $colour{base} = $login_form->{BASE_COLOUR} || '#445588'; $colour{lighter} = $login_form->{LIGHTER_COLOUR} if $login_form->{LIGHTER_COLOUR}; $colour{light} = $login_form->{LIGHT_COLOUR} if $login_form->{LIGHT_COLOUR}; $colour{dark} = $login_form->{DARK_COLOUR} if $login_form->{DARK_COLOUR}; $colour{darker} = $login_form->{DARKER_COLOUR} if $login_form->{DARKER_COLOUR}; $colour{grey} = $login_form->{GREY_COLOUR} if $login_form->{GREY_COLOUR}; my @undefined_colours = grep { ! defined $colour{$_} || index($colour{$_}, '%') >= 0 } qw(lighter light dark darker); if (@undefined_colours) { eval { require Color::Calc }; if ($@ && $login_form->{BASE_COLOUR}) { warn "Color::Calc is required when specifying a custom BASE_COLOUR, and leaving LIGHTER_COLOUR, LIGHT_COLOUR, DARK_COLOUR or DARKER_COLOUR blank or when providing percentage based colour"; } if ($@) { $colour{base} = '#445588'; $colour{lighter} = '#d0d5e1'; $colour{light} = '#a2aac4'; $colour{dark} = '#303c5f'; $colour{darker} = '#1b2236'; $colour{grey} = '#565656'; } else { $colour{lighter} = !$colour{lighter} ? Color::Calc::light_html($colour{base}, 0.75) : $colour{lighter} =~ m#(\d{2})%# ? Color::Calc::light_html($colour{base}, $1 / 100) : $colour{lighter}; $colour{light} = !$colour{light} ? Color::Calc::light_html($colour{base}, 0.5) : $colour{light} =~ m#(\d{2})%# ? Color::Calc::light_html($colour{base}, $1 / 100) : $colour{light}; $colour{dark} = !$colour{dark} ? Color::Calc::dark_html($colour{base}, 0.3) : $colour{dark} =~ m#(\d{2})%# ? Color::Calc::dark_html($colour{base}, $1 / 100) : $colour{dark}; $colour{darker} = !$colour{darker} ? Color::Calc::dark_html($colour{base}, 0.6) : $colour{darker} =~ m#(\d{2})%# ? Color::Calc::dark_html($colour{base}, $1 / 100) : $colour{darker}; #$colour{grey} ||= Color::Calc::bw_html($colour{base}); if (!$colour{grey}) { $colour{grey} = Color::Calc::bw_html($colour{base}); } } } $colour{grey} ||= '#565656'; return < object as the first non-object argument. =head2 login_box This method will return the HTML for a login box that can be embedded into another page. This is the same login box that is used in the default authen_login runmode that the plugin provides. You can set this option to customize the login form that is created when a user needs to be authenticated. If you wish to replace the entire login form with a completely custom version, then just set LOGIN_RUNMODE to point to your custom runmode. All of the parameters listed below are optional, and a reasonable default will be used if left blank: =over 4 =item TITLE (default: Sign In) the heading at the top of the login box =item USERNAME_LABEL (default: User Name) the label for the user name input =item PASSWORD_LABEL (default: Password) the label for the password input =item SUBMIT_LABEL (default: Sign In) the label for the submit button =item COMMENT (default: Please enter your username and password in the fields below.) a message provided on the first login attempt =item REMEMBERUSER_OPTION (default: 1) provide a checkbox to offer to remember the users name in a cookie so that their user name will be pre-filled the next time they log in =item REMEMBERUSER_LABEL (default: Remember User Name) the label for the remember user name checkbox =item REMEMBERUSER_COOKIENAME (default: CAPAUTHTOKEN) the name of the cookie where the user name will be saved =item REGISTER_URL (default: ) the URL for the register new account link =item REGISTER_LABEL (default: Register Now!) the label for the register new account link =item FORGOTPASSWORD_URL (default: ) the URL for the forgot password link =item FORGOTPASSWORD_LABEL (default: Forgot Password?) the label for the forgot password link =item INVALIDPASSWORD_MESSAGE (default: Invalid username or password
(login attempt %d) a message given when a login failed =item INCLUDE_STYLESHEET (default: 1) use this to disable the built in style-sheet for the login box so you can provide your own custom styles =item FORM_SUBMIT_METHOD (default: post) use this to get the form to submit using 'get' instead of 'post' =item FOCUS_FORM_ONLOAD (default: 1) use this to automatically focus the login form when the page loads so a user can start typing right away. =item BASE_COLOUR (default: #445588) This is the base colour that will be used in the included login box. All other colours are automatically calculated based on this colour (unless you hardcode the colour values). In order to calculate other colours, you will need the Color::Calc module. If you do not have the Color::Calc module, then you will need to use fixed values for all of the colour options. All colour values besides the BASE_COLOUR can be simple percentage values (including the % sign). For example if you set the LIGHTER_COLOUR option to 80%, then the calculated colour will be 80% lighter than the BASE_COLOUR. =item LIGHT_COLOUR (default: 50% or #a2aac4) A colour that is lighter than the base colour. =item LIGHTER_COLOUR (default: 75% or #d0d5e1) A colour that is another step lighter than the light colour. =item DARK_COLOUR (default: 30% or #303c5f) A colour that is darker than the base colour. =item DARKER_COLOUR (default: 60% or #1b2236) A colour that is another step darker than the dark colour. =item GREY_COLOUR (default: #565656) A grey colour that is calculated by desaturating the base colour. =back LOGIN_FORM => { TITLE => 'Login', SUBMIT_LABEL => 'Login', REMEMBERUSER_LABEL => 1, BASE_COLOUR => '#0099FF', LIGHTER_COLOUR => '#AAFFFF', DARK_COLOUR => '50%', } =head1 BUGS This is alpha software and as such, the features and interface are subject to change. So please check the Changes file when upgrading. =head1 SEE ALSO L, perl(1) =head1 AUTHOR Author: Cees Hek ; Co-maintainer: Nicholas Bamber . =head1 CREDITS Thanks to SiteSuite (http://www.sitesuite.com.au) for funding the development of this plugin and for releasing it to the world. Thanks to Christian Walde for suggesting changes to fix the incompatibility with L and for help with github. =head1 LICENCE AND COPYRIGHT Copyright (c) 2005, SiteSuite. All rights reserved. Copyright (c) 2010, Nicholas Bamber. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. =cut 1; Filter000755001750001750 014546072342 31532 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/lib/CGI/Application/Plugin/Authentication/Driveruc.pm100644001750001750 207114546072342 32637 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/lib/CGI/Application/Plugin/Authentication/Driver/Filterpackage CGI::Application::Plugin::Authentication::Driver::Filter::uc; $CGI::Application::Plugin::Authentication::Driver::Filter::uc::VERSION = '0.24'; use strict; use warnings; sub check { return ( uc $_[2] eq $_[3] ) ? 1 : 0; } sub filter { return uc $_[2]; } 1; __END__ =head1 NAME CGI::Application::Plugin::Authentication::Driver::Filter::uc - Uppercase Filter =head1 METHODS =head2 filter ( undef, $string ) This simply uppercases the string and returns it my $filtered = $class->filter(undef, 'foobar'); # FOOBAR =head2 check ( undef, $string, $compare ) This will uppercase the string and compare it against the comparison string and return true or false. if ($class->check(undef, 'foobar', 'FOOBAR')) { # they match } =head1 SEE ALSO L, perl(1) =head1 AUTHOR Cees Hek =head1 LICENCE AND COPYRIGHT Copyright (c) 2005, SiteSuite. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut lc.pm100644001750001750 206214546072342 32626 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/lib/CGI/Application/Plugin/Authentication/Driver/Filterpackage CGI::Application::Plugin::Authentication::Driver::Filter::lc; $CGI::Application::Plugin::Authentication::Driver::Filter::lc::VERSION = '0.24'; use strict; use warnings; sub check { return ( lc $_[2] eq $_[3] ) ? 1 : 0; } sub filter { return lc( $_[2] ); } 1; __END__ =head1 NAME CGI::Application::Plugin::Authentication::Driver::Filter::lc - Lowercase Filter =head1 METHODS =head2 filter ( undef, $string ) This simply lowercases the string and returns it my $filtered = $class->filter(undef, 'FOOBAR'); # foobar =head2 check ( undef, $string, $compare ) This will lowercase C<$string> and compare it against C<$compare> and return true or false. if ($class->check(undef, 'FOOBAR', 'foobar')) { # they match } =head1 SEE ALSO L, perl(1) =head1 AUTHOR Cees Hek =head1 LICENCE AND COPYRIGHT Copyright (c) 2005, SiteSuite. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut md5.pm100644001750001750 444614546072342 32725 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/lib/CGI/Application/Plugin/Authentication/Driver/Filterpackage CGI::Application::Plugin::Authentication::Driver::Filter::md5; $CGI::Application::Plugin::Authentication::Driver::Filter::md5::VERSION = '0.24'; use strict; use warnings; use UNIVERSAL::require; sub check { my $class = shift; my $param = shift; my $plain = shift; my $filtered = shift; if ($param) { return ( $class->filter( $param, $plain ) eq $filtered ) ? 1 : 0; } elsif ( length($filtered) == 16 ) { return ( $class->filter( 'binary', $plain ) eq $filtered ) ? 1 : 0; } elsif ( length($filtered) == 22 ) { return ( $class->filter( 'base64', $plain ) eq $filtered ) ? 1 : 0; } else { return ( $class->filter( undef, $plain ) eq $filtered ) ? 1 : 0; } } sub filter { my $class = shift; my $param = lc (shift || 'hex'); my $plain = shift; Digest::MD5->require || die "Digest::MD5 is required to check MD5 passwords"; if ( $param eq 'hex' ) { return Digest::MD5::md5_hex($plain); } elsif ( $param eq 'base64' ) { return Digest::MD5::md5_base64($plain); } elsif ( $param eq 'binary' ) { return Digest::MD5::md5($plain); } die "Unknown MD5 format $param"; } 1; __END__ =head1 NAME CGI::Application::Plugin::Authentication::Driver::Filter::md5 - MD5 filter =head1 METHODS =head2 filter ( (hex base64 binary), $string ) This will generate an MD5 hash of the string in the requested format. By default, hex encoding is used. my $filtered = $class->filter('base64', 'foobar'); # OFj2IjCsPJFfMAxmQxLGPw -or- my $filtered = $class->filter(undef, 'foobar'); # 3858f62230ac3c915f300c664312c63f =head2 check ( (hex base64 binary), $string, $md5 ) This will generate an MD5 hash of the string, and compare it against the provided MD5 string. If no encoding type is specified, the length of the MD5 string will be tested to see what format it is in. if ($class->check(undef, 'foobar', '3858f62230ac3c915f300c664312c63f')) { # they match } =head1 SEE ALSO L, L, perl(1) =head1 AUTHOR Cees Hek =head1 LICENCE AND COPYRIGHT Copyright (c) 2005, SiteSuite. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut sha1.pm100644001750001750 452314546072342 33070 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/lib/CGI/Application/Plugin/Authentication/Driver/Filterpackage CGI::Application::Plugin::Authentication::Driver::Filter::sha1; $CGI::Application::Plugin::Authentication::Driver::Filter::sha1::VERSION = '0.24'; use strict; use warnings; use UNIVERSAL::require; sub check { my $class = shift; my $param = shift; my $plain = shift; my $filtered = shift; if ($param) { return ( $class->filter( $param, $plain ) eq $filtered ) ? 1 : 0; } elsif ( length($filtered) == 20 ) { return ( $class->filter( 'binary', $plain ) eq $filtered ) ? 1 : 0; } elsif ( length($filtered) == 27 ) { return ( $class->filter( 'base64', $plain ) eq $filtered ) ? 1 : 0; } else { return ( $class->filter( undef, $plain ) eq $filtered ) ? 1 : 0; } } sub filter { my $class = shift; my $param = lc (shift || 'hex'); my $plain = shift; Digest::SHA->require || die "Digest::SHA is required to check SHA1 passwords"; if ( $param eq 'hex' ) { return Digest::SHA::sha1_hex($plain); } elsif ( $param eq 'base64' ) { return Digest::SHA::sha1_base64($plain); } elsif ( $param eq 'binary' ) { return Digest::SHA::sha1($plain); } die "Unknown SHA1 format $param"; } 1; __END__ =head1 NAME CGI::Application::Plugin::Authentication::Driver::Filter::sha1 - SHA1 Password filter =head1 METHODS =head2 filter ( (hex base64 binary), $string ) This will generate an SHA1 hash of the string in the requested format. By default, hex encoding is used. my $filtered = $class->filter('base64', 'foobar'); # iEPX+SQWIR3p67lj/0zigSWTKHg -or- my $filtered = $class->filter(undef, 'foobar'); # 8843d7f92416211de9ebb963ff4ce28125932878 =head2 check ( (hex base64 binary), $string, $sha1 ) This will generate an SHA1 hash of the string, and compare it against the provided SHA1 string. If no encoding type is specified, the length of the SHA1 string will be tested to see what format it is in. if ($class->check(undef, 'foobar', '8843d7f92416211de9ebb963ff4ce28125932878')) { # they match } =head1 SEE ALSO L, L, perl(1) =head1 AUTHOR Cees Hek =head1 LICENCE AND COPYRIGHT Copyright (c) 2005, SiteSuite. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut strip.pm100644001750001750 243414546072342 33374 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/lib/CGI/Application/Plugin/Authentication/Driver/Filterpackage CGI::Application::Plugin::Authentication::Driver::Filter::strip; $CGI::Application::Plugin::Authentication::Driver::Filter::strip::VERSION = '0.24'; use strict; use warnings; sub check { return ( _strip( $_[2] ) eq $_[3] ) ? 1 : 0; } sub filter { return _strip( $_[2] ); } sub _strip { my $str = shift; $str =~ s/^\s+//; $str =~ s/\s+$//; return $str; } 1; __END__ =head1 NAME CGI::Application::Plugin::Authentication::Driver::Filter::strip - Filter that strips whitespace from the beginning and end of the string =head1 METHODS =head2 filter ( undef, $string ) This strips whitespace from the beginning and end of the string and returns the result my $filtered = $class->filter(undef, " foobar\t\n"); # 'foobar' =head2 check ( undef, $string, $compare ) This will lowercase the string and compare it against the comparison string and return true or false. if ($class->check(undef, " foobar\t\n", 'foobar')) { # they match } =head1 SEE ALSO L, perl(1) =head1 AUTHOR Cees Hek =head1 LICENCE AND COPYRIGHT Copyright (c) 2005, SiteSuite. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut crypt.pm100644001750001750 333014546072342 33370 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/lib/CGI/Application/Plugin/Authentication/Driver/Filterpackage CGI::Application::Plugin::Authentication::Driver::Filter::crypt; $CGI::Application::Plugin::Authentication::Driver::Filter::crypt::VERSION = '0.24'; use strict; use warnings; sub check { my $class = shift; my $param = shift; my $plain = shift; my $filtered = shift; return ( $class->filter( $param, $plain, $filtered ) eq $filtered ) ? 1 : 0; } sub filter { my ($class, undef, $plain, $salt) = @_; if (!$salt) { my @alphabet = ( '.', '/', 0 .. 9, 'A' .. 'Z', 'a' .. 'z' ); $salt = join '', @alphabet[ rand 64, rand 64 ]; } return crypt( $plain, $salt ); } 1; __END__ =head1 NAME CGI::Application::Plugin::Authentication::Driver::Filter::crypt - crypt Filter =head1 METHODS =head2 filter ( undef, $string [, salt ] ) This will generate a crypted string. The first parameter is always ignored, since there is only one way to use the crypt function. You can pass in an extra parameter to act as the salt. my $filtered = $class->filter(undef, 'foobar'); # mQvbWI43eDCAk -or- my $filtered = $class->filter(undef, 'foobar', 'AA'); # AAZk9Aj5/Ue0E =head2 check ( undef, $string, $crypted ) This will crypt the string, and compare it against the provided crypted string. The first parameter is always ignored, since there is only one way to use the crypt function. if ($class->check(undef, 'foobar', 'mQvbWI43eDCAk')) { # they match } =head1 SEE ALSO L, perl(1) =head1 AUTHOR Cees Hek =head1 LICENCE AND COPYRIGHT Copyright (c) 2005, SiteSuite. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Authen000755001750001750 014546072342 31531 5ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/lib/CGI/Application/Plugin/Authentication/DriverSimple.pm100644001750001750 615014546072342 33462 0ustar00weswes000000000000CGI-Application-Plugin-Authentication-0.24/lib/CGI/Application/Plugin/Authentication/Driver/Authenpackage CGI::Application::Plugin::Authentication::Driver::Authen::Simple; $CGI::Application::Plugin::Authentication::Driver::Authen::Simple::VERSION = '0.24'; use strict; use warnings; use base qw(CGI::Application::Plugin::Authentication::Driver); use Carp; use UNIVERSAL::require; =head1 NAME CGI::Application::Plugin::Authentication::Driver::Authen::Simple - Authen::Simple Authentication driver =head1 SYNOPSIS use base qw(CGI::Application); use CGI::Application::Plugin::Authentication; __PACKAGE__->authen->config( DRIVER => [ 'Authen::Simple::Kerberos', realm => 'REALM.COMPANY.COM' ], ); =head1 DESCRIPTION This driver allows you to use any modules that following the Authen::Simple API. All options that you provide will be passed on to the given Authen::Simple module. =head1 EXAMPLE __PACKAGE__->authen->config( DRIVER => [ 'Authen::Simple::CDBI', class => 'MyApp::Model::User' ], ); =head1 METHODS =head2 verify_credentials This method will test the provided credentials against the Authen::Simple module that was configured. =cut sub verify_credentials { my $self = shift; my @creds = @_; my @options = $self->options; my $authen_class = shift @options; return undef unless defined $creds[0] && defined $creds[1]; $authen_class->require || Carp::croak("The $authen_class module is not installed"); my $authen_obj = $authen_class->new(@options); croak("Failed to create $authen_class instance") if !defined $authen_obj; return $authen_obj->authenticate(@creds) ? $creds[0] : undef; } =head1 SEE ALSO L, L, perl(1) =head1 LICENCE AND COPYRIGHT Copyright (c) 2006, SiteSuite. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. =cut 1;