diff --git a/Changes b/Changes new file mode 100644 index 0000000..8cdf8a7 --- /dev/null +++ b/Changes @@ -0,0 +1,236 @@ +Authen-SASL 2.16 -- Tue Sep 4 11:01:18 CDT 2012 + + * SASL.pod: fix typo [Peter Marschall] + * Perl.pm: avoid warning on "uninitialized value" [Peter Marschall] + +Authen-SASL 2.15 -- Wed Jun 2 13:47:41 CDT 2010 + + * Makes sure that user callbacks are called [Yann Kerherve] + +Authen-SASL 2.1401 -- Mon Mar 29 14:22:54 CDT 2010 + + * Add META.yml to release + +Authen-SASL 2.14 -- Thu Mar 11 08:21:07 CST 2010 + + * Documentation updates [Yann Kerherve] + * Added server API description [Yann Kerherve] + * Bugfixes to LOGIN, PLAIN and DIGEST_MD5 [Yann Kerherve] + * Added server support for LOGIN, PLAINaand DIGEST_MD5 [Yann Kerherve] + * Compatiblity with Authen::SASL::XS [Yann Kerherve] + +Authen-SASL 2.13 -- Thu Sep 24 17:27:47 CDT 2009 + + * RT#42191 Only use pass for GSSAPI credentials if it is an object of type GSSAPI::Cred + * RT#675 Authorization with Authen::SASL::Perl::External + * Call client_new and server_new inside eval so further plugins can be tried before failing + * Prefer to use Authen::SASL::XS over Authen::SASL::Cyrus + +Authen-SASL 2.12 -- Mon Jun 30 21:35:21 CDT 2008 + +Enhancements + * GSSAPI implement protocol according to RFC, but by default, remain compatible with cyrus sasl lib + * DIGEST-MD5 implement channel encryption layer + +Authen-SASL 2.11 -- Mon Apr 21 10:23:19 CDT 2008 + +Enhancements + * implement securesocket() in the ::Perl set of plugins + +Bug Fixes + * fix parsing challenges from GnuSASL + * update tests for DIGEST-MD5 + * New test from Phil Pennock for testing final server response + +Authen-SASL 2.10 -- Sat Mar 25 13:11:47 CST 2006 + +Enhancements + * Added Authen::SASL::Perl::GSSAPI + * Added error method to Authen::SASL to obtain error from last connection + +Bug Fixes + * Authen::SASL::Perl::DIGEST_MD5 + - Fixed response to server to pass digest-uri + - Correct un-escaping behaviour when reading the challenge, + - check for required fields (according to the RFC), + - allow for qop not to be sent from the server (according to the RFC), + - add a callback for the realm. + +Authen-SASL 2.09 -- Tue Apr 26 06:55:10 CDT 2005 + +Enhancements + * authname support in Authen::SASL::Perl::DIGEST_MD5 + * flexible plugin selection in Authen::SASL using import() + i.e. use Authen::SASL qw(Authen::SASL::Cyrus); + * new documentation for + - Authen::SASL::Perl::ANONYMOUS + - Authen::SASL::Perl::CRAM_MD5 + - Authen::SASL::Perl::EXTERNAL + - Authen::SASL::Perl::LOGIN + - Authen::SASL::Perl::PLAIN + - Authen::SASL::Perl + * updates in the tests + +Authen-SASL 2.08 -- Tue May 25 11:24:21 BST 2004 + +Bug Fixes + * Fix the handling of qop in Digest-MD5 + +Authen-SASL 2.07 -- Sat Apr 10 09:06:21 BST 2004 + +Bug Fixes + * Fixed test bug if Digest::HMAC_MD5 was not installed + * Fixed order of values sent in the PLAIN mechanism + +Enhancements + * Added support in the framework for server-side plugins + +2003-11-01 18:48 Graham Barr + + * lib/Authen/SASL.pm: + + Release 2.06 + +2003-10-21 19:59 Graham Barr + + * MANIFEST, lib/Authen/SASL/Perl.pm, + lib/Authen/SASL/Perl/ANONYMOUS.pm, + lib/Authen/SASL/Perl/CRAM_MD5.pm, + lib/Authen/SASL/Perl/DIGEST_MD5.pm, + lib/Authen/SASL/Perl/EXTERNAL.pm, lib/Authen/SASL/Perl/LOGIN.pm, + lib/Authen/SASL/Perl/PLAIN.pm, t/order.t: + + Add ordering so we always pich the best of the available methods instead of + just the first + +2003-10-17 22:12 Graham Barr + + * lib/Authen/SASL.pm: + + Release 2.05 + +2003-10-17 22:06 Graham Barr + + * MANIFEST, Makefile.PL: + + use Module::Install to generate Makefile and add SIGNATURE and META.yml + +2003-10-17 21:19 Graham Barr + + * lib/Authen/SASL/Perl/DIGEST_MD5.pm: + + Fix typo + +2003-10-17 21:17 Graham Barr + + * lib/Authen/SASL/: Perl.pm, Perl/DIGEST_MD5.pm: + + Don't call die in DIGEST_MD5, but call set_error and return an empty list + +2003-10-17 21:16 Graham Barr + + * lib/Authen/SASL.pod: + + Update docs to reflect that client_start and client_step return an emtpy list on error + +2003-05-19 22:41 Graham Barr + + * lib/Authen/SASL.pm: + + Release 2.04 + +2003-05-19 22:40 Graham Barr + + * t/digest_md5.t: + + Avoid used only once warning + +2003-05-19 17:06 Graham Barr + + * MANIFEST, lib/Authen/SASL/Perl/DIGEST_MD5.pm, t/digest_md5.t: + + Add DIGEST-MD5 mechanism + +2003-05-19 16:42 Graham Barr + + * MANIFEST, t/login.t: + + Add test for login mechanism + +2003-01-21 19:15 Graham Barr + + * lib/Authen/SASL.pm: + + Release 2.03 + +2003-01-21 12:22 Graham Barr + + * lib/Authen/SASL/Perl/LOGIN.pm: + + Fix LOGIN mechanism to respond with the username when prompted + +2002-05-28 15:22 Graham Barr + + * lib/Authen/SASL.pm: + + Release 2.02 + +2002-05-28 14:36 Graham Barr + + * MANIFEST, lib/Authen/SASL/Perl/LOGIN.pm: + + Add LOGIN mechanism commonly used by SMTP + +2002-03-31 15:39 Graham Barr + + * lib/Authen/SASL.pm: + + Release 2.01 + +2002-03-22 10:13 Graham Barr + + * t/cram_md5.t: + + Skip cram_md5 test if Digest::HMAC_MD5 is not installed + +2002-02-18 16:56 Graham Barr + + * lib/Authen/SASL/Perl.pm: + + Add securesocket to the ::Perl base class. + +2002-01-28 19:52 Graham Barr + + * MANIFEST, lib/Authen/SASL.pm, t/anon.t, t/callback.t, + t/cram_md5.t, t/external.t, t/plain.t: + + Add some tests + +2002-01-24 15:21 Graham Barr + + * lib/Authen/SASL/Perl.pm: + + Allow callback to be called on the connection object + +2002-01-24 12:04 Graham Barr + + * MANIFEST, Makefile.PL, api.txt, compat_pl, example_pl, + lib/Authen/SASL.pm, lib/Authen/SASL.pod, + lib/Authen/SASL/CRAM_MD5.pm, lib/Authen/SASL/EXTERNAL.pm, + lib/Authen/SASL/Perl.pm, lib/Authen/SASL/Perl/ANONYMOUS.pm, + lib/Authen/SASL/Perl/CRAM_MD5.pm, lib/Authen/SASL/Perl/EXTERNAL.pm, + lib/Authen/SASL/Perl/PLAIN.pm: + + Initial revision + +2002-01-24 12:04 Graham Barr + + * MANIFEST, Makefile.PL, api.txt, compat_pl, example_pl, + lib/Authen/SASL.pm, lib/Authen/SASL.pod, + lib/Authen/SASL/CRAM_MD5.pm, lib/Authen/SASL/EXTERNAL.pm, + lib/Authen/SASL/Perl.pm, lib/Authen/SASL/Perl/ANONYMOUS.pm, + lib/Authen/SASL/Perl/CRAM_MD5.pm, lib/Authen/SASL/Perl/EXTERNAL.pm, + lib/Authen/SASL/Perl/PLAIN.pm: + + import + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..3f4d0fc --- /dev/null +++ b/MANIFEST @@ -0,0 +1,48 @@ +api.txt +Changes +compat_pl +example_pl +inc/Module/Install.pm +inc/Module/Install/Base.pm +inc/Module/Install/Can.pm +inc/Module/Install/Fetch.pm +inc/Module/Install/Makefile.pm +inc/Module/Install/Metadata.pm +inc/Module/Install/Win32.pm +inc/Module/Install/WriteAll.pm +lib/Authen/SASL.pm +lib/Authen/SASL.pod +lib/Authen/SASL/CRAM_MD5.pm +lib/Authen/SASL/EXTERNAL.pm +lib/Authen/SASL/Perl.pm +lib/Authen/SASL/Perl.pod +lib/Authen/SASL/Perl/ANONYMOUS.pm +lib/Authen/SASL/Perl/CRAM_MD5.pm +lib/Authen/SASL/Perl/DIGEST_MD5.pm +lib/Authen/SASL/Perl/EXTERNAL.pm +lib/Authen/SASL/Perl/GSSAPI.pm +lib/Authen/SASL/Perl/LOGIN.pm +lib/Authen/SASL/Perl/PLAIN.pm +Makefile.PL +MANIFEST This list of files +MANIFEST.SKIP +META.yml +MYMETA.json +MYMETA.yml +SIGNATURE +t/anon.t +t/callback.t +t/cram_md5.t +t/digest_md5.t +t/digest_md5_verified.t +t/external.t +t/lib/common.pl +t/login.t +t/negotiations/digest_md5.t +t/negotiations/login.t +t/negotiations/plain.t +t/order.t +t/plain.t +t/server/digest_md5.t +t/server/login.t +t/server/plain.t diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..7bba4b0 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,23 @@ +^_build +^Build$ +^blib +~$ +\.bak$ +\.DS_Store +cover_db +\..*\.sw.?$ +^Makefile$ +^pm_to_blib$ +^MakeMaker-\d +^blibdirs$ +\.old$ +^#.*#$ +^\.# +^TODO$ +^PLANS$ +^doc/ +^benchmarks +^\._.*$ +\.shipit +^Authen-SASL-* +\.git.* diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..7a6146c --- /dev/null +++ b/META.yml @@ -0,0 +1,30 @@ +--- +abstract: 'SASL Authentication framework' +author: + - 'Graham Barr ' +build_requires: + ExtUtils::MakeMaker: 6.42 + Test::More: 0 +configure_requires: + ExtUtils::MakeMaker: 6.42 +distribution_type: module +generated_by: 'Module::Install version 0.95' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: Authen-SASL +no_index: + directory: + - inc + - t +recommends: + GSSAPI: 0 +requires: + Digest::HMAC_MD5: 0 + Digest::MD5: 0 + perl: 5.005 +resources: + license: http://dev.perl.org/licenses/ + repository: http://github.com/gbarr/perl-authen-sasl +version: 2.16 diff --git a/MYMETA.json b/MYMETA.json new file mode 100644 index 0000000..ee313c9 --- /dev/null +++ b/MYMETA.json @@ -0,0 +1,44 @@ +{ + "abstract" : "SASL Authentication framework", + "author" : [ + "Graham Barr " + ], + "dynamic_config" : 0, + "generated_by" : "ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Authen-SASL", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "6.42", + "Test::More" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "Digest::HMAC_MD5" : "0", + "Digest::MD5" : "0", + "perl" : "5.005" + } + } + }, + "release_status" : "stable", + "version" : "2.16" +} diff --git a/MYMETA.yml b/MYMETA.yml new file mode 100644 index 0000000..3e791aa --- /dev/null +++ b/MYMETA.yml @@ -0,0 +1,25 @@ +--- +abstract: 'SASL Authentication framework' +author: + - 'Graham Barr ' +build_requires: + ExtUtils::MakeMaker: 6.42 + Test::More: 0 +configure_requires: + ExtUtils::MakeMaker: 0 +dynamic_config: 0 +generated_by: 'ExtUtils::MakeMaker version 6.62, CPAN::Meta::Converter version 2.120921' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +name: Authen-SASL +no_index: + directory: + - t + - inc +requires: + Digest::HMAC_MD5: 0 + Digest::MD5: 0 + perl: 5.005 +version: 2.16 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..4db553e --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,24 @@ +# This -*- perl -*- script makes the Makefile + +use strict; +use warnings; +use 5.005; +use inc::Module::Install; + +name 'Authen-SASL'; +abstract 'SASL Authentication framework'; +author 'Graham Barr '; +version_from 'lib/Authen/SASL.pm'; +license 'perl'; +repository 'http://github.com/gbarr/perl-authen-sasl'; + +perl_version 5.005; + +test_requires 'Test::More' => 0; +requires 'Digest::MD5' => 0; +requires 'Digest::HMAC_MD5' => 0; +recommends 'GSSAPI' => 0; + +tests_recursive; + +WriteAll(); diff --git a/SIGNATURE b/SIGNATURE new file mode 100644 index 0000000..ca86640 --- /dev/null +++ b/SIGNATURE @@ -0,0 +1,70 @@ +This file contains message digests of all files listed in MANIFEST, +signed via the Module::Signature module, version 0.64. + +To verify the content in this distribution, first make sure you have +Module::Signature installed, then type: + + % cpansign -v + +It will check each file's integrity, as well as the signature's +validity. If "==> Signature verified OK! <==" is not displayed, +the distribution may already have been compromised, and you should +not run its Makefile.PL or Build.PL. + +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +SHA1 63ce37f504944aae3054a9cc31517f16c5df17d1 Changes +SHA1 009265ab9977843e16b1436e3c5d86bbe2df7a0f MANIFEST +SHA1 76ce2a83a03713855f54e0f0f13093bab0f5de6d MANIFEST.SKIP +SHA1 a38a595b63cd458e663eb87083effef88d5b81e4 META.yml +SHA1 ef177095f047faa6dddebf0f8146b0bd647acce3 MYMETA.json +SHA1 a2f0932b2c2e304ac2c9b713ef83edf15a206b8e MYMETA.yml +SHA1 30e38ea2e9ae64de8ddbf1529b823c930df7ac54 Makefile.PL +SHA1 d458613a6aef99468b37defcbf8321ec7c88fe76 api.txt +SHA1 81644069dc4507a71e4cfeef20780fee6c7ee00a compat_pl +SHA1 fe659c6b2d6041f944072b9aa1e4ff3a49381e36 example_pl +SHA1 1ebec4119486a032a5612a403e8d7b7be973e938 inc/Module/Install.pm +SHA1 24038af925a69df41972971356ccce885b0fe2ad inc/Module/Install/Base.pm +SHA1 8f96eddfef548c9328457fbb17a121631cda356b inc/Module/Install/Can.pm +SHA1 ec29048e48edd9c9c55f9de7b773bd7c904335ad inc/Module/Install/Fetch.pm +SHA1 0384525d85d51e99532e3ad8729d870113646d14 inc/Module/Install/Makefile.pm +SHA1 38c657de4d91f5a60ff8e6c6f6a5547daf7c4ab2 inc/Module/Install/Metadata.pm +SHA1 5c25f1104c0038041e3b93e0660c39171e4caf2b inc/Module/Install/Win32.pm +SHA1 94d47349c803c4bd2a9230d25e4db0b6aaf1acd8 inc/Module/Install/WriteAll.pm +SHA1 c44a98b717017d8bd79b216ac2c31566e564e190 lib/Authen/SASL.pm +SHA1 f8be1e65538fe4730d0eea1443bc948d3d666adc lib/Authen/SASL.pod +SHA1 81c1f6d65fb94ebf36e3928558d0f50b4968e2be lib/Authen/SASL/CRAM_MD5.pm +SHA1 dabe43f97abab76f875643defe311e7e29e46895 lib/Authen/SASL/EXTERNAL.pm +SHA1 575036889273f152579cdcc1007c27d28673843b lib/Authen/SASL/Perl.pm +SHA1 75212a3fbcfce6ab4f3e2a7db96780223b201272 lib/Authen/SASL/Perl.pod +SHA1 cdf6b8bb2b2a1286cab5b6e46f9c3d48ebe048e3 lib/Authen/SASL/Perl/ANONYMOUS.pm +SHA1 1dcf4897403f3721b3ce18afc6589f6fd1155836 lib/Authen/SASL/Perl/CRAM_MD5.pm +SHA1 6c60d02b4f05762f0e6e5d9faf2e06e0acbd25a7 lib/Authen/SASL/Perl/DIGEST_MD5.pm +SHA1 c4fce50b535c88ccddf6c844faf0870c52a3c90e lib/Authen/SASL/Perl/EXTERNAL.pm +SHA1 7c9facb2f8b81c430d1fd530a634e8cfc67e33f6 lib/Authen/SASL/Perl/GSSAPI.pm +SHA1 e6eb9dcf283d92e9962b9df4d9805672b4d56a50 lib/Authen/SASL/Perl/LOGIN.pm +SHA1 205ba41fe5d77fa431f1c41f00ba695794695da8 lib/Authen/SASL/Perl/PLAIN.pm +SHA1 be0c439da3f8f1740fa8b623cee9662946a62c3f t/anon.t +SHA1 2f0bc82458a42b9b2e9cf5792abb1611ee2fc2e7 t/callback.t +SHA1 b638f32f3215163b607c509a55026bafa5c5edfc t/cram_md5.t +SHA1 02ea6c791924c3dcbe2e3ea1a6f3fae4a0faf0f0 t/digest_md5.t +SHA1 7a52a9574b75c55d663de86edaf6b64d5f2a5814 t/digest_md5_verified.t +SHA1 c539103a4d2db98a95cfe2064822f58c153a14d4 t/external.t +SHA1 da812c25101b5624a1a8993888fb44ed5c6ccd39 t/lib/common.pl +SHA1 369a6b09c625fb91c64123daea5a82895bfaea69 t/login.t +SHA1 39999f1361408059472be21af60cebf1ffc70b79 t/negotiations/digest_md5.t +SHA1 d7b4c3b0efd92e95f38ec986400d3ff4e64932ec t/negotiations/login.t +SHA1 f29686ef395890edd3d06f174223cf91c6afbe90 t/negotiations/plain.t +SHA1 6a6c9fa037cdaf24091524cc399f9cc799547732 t/order.t +SHA1 0d3df2efa70ae53bf021707aae435fe54d96cc95 t/plain.t +SHA1 7bb229401b5a9d207594a24ecd5581f2a10ddfae t/server/digest_md5.t +SHA1 d653eeffdeb48bedbdafaf1d95cf307e072d0804 t/server/login.t +SHA1 b6ca8bd0a0ddaca6db8b2641592b341655b39ae8 t/server/plain.t +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.4.11 (Darwin) + +iEYEARECAAYFAlBGJ5sACgkQR0BL4gbYw3TdFQCfYa2GLN0iexXgCLNpoqMy2el9 +AsEAoIgR1T1OQPXY3NRbet2ZFFhNMdqa +=ZHX7 +-----END PGP SIGNATURE----- diff --git a/api.txt b/api.txt new file mode 100644 index 0000000..aea2d00 --- /dev/null +++ b/api.txt @@ -0,0 +1,73 @@ + +Client API +---------- +Basically the Authen::SASL module gathers some info. When ->client_new +is called the plugin is called to create a $conn object. At that point +it should query the Authen::SASL object for mechanisms and callbacks + +Properties are then set on the $conn object by calling $conn->property + +Then client_start is called + +Then we call client_step with a challenge string to get a response +string. need_step can be called to check that this step is actually +necessary for the selected mechanism. + + +Quite simple really I think. + + +So the plugin just needs to support + + client_new + client_start + client_step + need_step # returns true if client_step needs to be called + property # set/get for properties + mechanism # returns the name of the chosen mechanism + service # the service name passed to client_new + host # the hostname passed to client_new + is_success # returns true if authentication suceeded + +Server API +---------- +The server API is symetric to the client's one. server_new is called to +create a connection object. Then server_start is called, and if relevant +the first data from the client is passed to it as argument. + +Then we call server_step with all the response from the clients, which +returns challenges. need_step also determines if the current mechanism +requires another step. + +So the plugin just needs to support + + server_new + server_start + server_step + need_step # returns true if client_step needs to be called + property # set/get for properties + mechanism # returns the name of the chosen mechanism + service # the service name passed to client_new + host # the hostname passed to client_new + is_success # returns true if authentication suceeded + +Callbacks +--------- +properties and callbacks are passed by name, so you will need to convert +them to numbers. + +There are three types of call back + + user => 'fred' + +When the user callback is called, it will just return the string 'fred' + + user => \&subname + +When the user callback is called, &subname will be called and it will +be passed the $conn object as the first argument. + + user => [ \&subname, 1, 2, 3] + +When the user callback is called, &subname will be called. It will be passed +the $conn object, followed by all other values in the array diff --git a/compat_pl b/compat_pl new file mode 100755 index 0000000..22d1634 --- /dev/null +++ b/compat_pl @@ -0,0 +1,18 @@ +#!/usr/bin/env perl + +# short script to check compatability with previous Authen::SASL library + +use lib 'lib'; +use Authen::SASL; + +my $sasl = Authen::SASL->new('CRAM-MD5', password => 'fred'); + +$sasl->user('gbarr'); + +$initial = $sasl->initial; +$mech = $sasl->name; + +print "$mech;", unpack("H*",$initial),";\n"; + +print unpack "H*", $sasl->challenge('xyz'); +print "\n"; diff --git a/example_pl b/example_pl new file mode 100755 index 0000000..82c99f6 --- /dev/null +++ b/example_pl @@ -0,0 +1,40 @@ +#!/usr/bin/env perl + +# short example script + +use lib 'lib'; +use Authen::SASL; + +# This part is in the user script + +my $sasl = Authen::SASL->new( + mechanism => 'PLAIN CRAM-MD5 EXTERNAL ANONYMOUS', + callback => { + user => 'gbarr', + pass => 'fred', + authname => 'none' + }, +); + +# $sasl is then passed to a library (eg Net::LDAP) +# which will then do + +my $conn = $sasl->client_new("ldap","localhost", "noplaintext noanonymous"); + +# The library would also set properties on the connection +#$conn->property( +# iplocal => $socket->sockname, +# ipremote => $socket->peername, +#); + +# It would then start things off and send this info to the server + +my $initial = $conn->client_start; +my $mech = $conn ->mechanism; + +print "$mech;", unpack("H*",$initial),";\n"; + +# When the server want more information, the library would call + +print unpack "H*", $conn->client_step("xyz"); +print "\n"; diff --git a/inc/Module/Install.pm b/inc/Module/Install.pm new file mode 100644 index 0000000..bc055a9 --- /dev/null +++ b/inc/Module/Install.pm @@ -0,0 +1,441 @@ +#line 1 +package Module::Install; + +# For any maintainers: +# The load order for Module::Install is a bit magic. +# It goes something like this... +# +# IF ( host has Module::Install installed, creating author mode ) { +# 1. Makefile.PL calls "use inc::Module::Install" +# 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install +# 3. The installed version of inc::Module::Install loads +# 4. inc::Module::Install calls "require Module::Install" +# 5. The ./inc/ version of Module::Install loads +# } ELSE { +# 1. Makefile.PL calls "use inc::Module::Install" +# 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install +# 3. The ./inc/ version of Module::Install loads +# } + +use 5.005; +use strict 'vars'; +use Cwd (); +use File::Find (); +use File::Path (); +use FindBin; + +use vars qw{$VERSION $MAIN}; +BEGIN { + # All Module::Install core packages now require synchronised versions. + # This will be used to ensure we don't accidentally load old or + # different versions of modules. + # This is not enforced yet, but will be some time in the next few + # releases once we can make sure it won't clash with custom + # Module::Install extensions. + $VERSION = '0.95'; + + # Storage for the pseudo-singleton + $MAIN = undef; + + *inc::Module::Install::VERSION = *VERSION; + @inc::Module::Install::ISA = __PACKAGE__; + +} + +sub import { + my $class = shift; + my $self = $class->new(@_); + my $who = $self->_caller; + + #------------------------------------------------------------- + # all of the following checks should be included in import(), + # to allow "eval 'require Module::Install; 1' to test + # installation of Module::Install. (RT #51267) + #------------------------------------------------------------- + + # Whether or not inc::Module::Install is actually loaded, the + # $INC{inc/Module/Install.pm} is what will still get set as long as + # the caller loaded module this in the documented manner. + # If not set, the caller may NOT have loaded the bundled version, and thus + # they may not have a MI version that works with the Makefile.PL. This would + # result in false errors or unexpected behaviour. And we don't want that. + my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; + unless ( $INC{$file} ) { die <<"END_DIE" } + +Please invoke ${\__PACKAGE__} with: + + use inc::${\__PACKAGE__}; + +not: + + use ${\__PACKAGE__}; + +END_DIE + + # This reportedly fixes a rare Win32 UTC file time issue, but + # as this is a non-cross-platform XS module not in the core, + # we shouldn't really depend on it. See RT #24194 for detail. + # (Also, this module only supports Perl 5.6 and above). + eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; + + # If the script that is loading Module::Install is from the future, + # then make will detect this and cause it to re-run over and over + # again. This is bad. Rather than taking action to touch it (which + # is unreliable on some platforms and requires write permissions) + # for now we should catch this and refuse to run. + if ( -f $0 ) { + my $s = (stat($0))[9]; + + # If the modification time is only slightly in the future, + # sleep briefly to remove the problem. + my $a = $s - time; + if ( $a > 0 and $a < 5 ) { sleep 5 } + + # Too far in the future, throw an error. + my $t = time; + if ( $s > $t ) { die <<"END_DIE" } + +Your installer $0 has a modification time in the future ($s > $t). + +This is known to create infinite loops in make. + +Please correct this, then run $0 again. + +END_DIE + } + + + # Build.PL was formerly supported, but no longer is due to excessive + # difficulty in implementing every single feature twice. + if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } + +Module::Install no longer supports Build.PL. + +It was impossible to maintain duel backends, and has been deprecated. + +Please remove all Build.PL files and only use the Makefile.PL installer. + +END_DIE + + #------------------------------------------------------------- + + # To save some more typing in Module::Install installers, every... + # use inc::Module::Install + # ...also acts as an implicit use strict. + $^H |= strict::bits(qw(refs subs vars)); + + #------------------------------------------------------------- + + unless ( -f $self->{file} ) { + require "$self->{path}/$self->{dispatch}.pm"; + File::Path::mkpath("$self->{prefix}/$self->{author}"); + $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); + $self->{admin}->init; + @_ = ($class, _self => $self); + goto &{"$self->{name}::import"}; + } + + *{"${who}::AUTOLOAD"} = $self->autoload; + $self->preload; + + # Unregister loader and worker packages so subdirs can use them again + delete $INC{"$self->{file}"}; + delete $INC{"$self->{path}.pm"}; + + # Save to the singleton + $MAIN = $self; + + return 1; +} + +sub autoload { + my $self = shift; + my $who = $self->_caller; + my $cwd = Cwd::cwd(); + my $sym = "${who}::AUTOLOAD"; + $sym->{$cwd} = sub { + my $pwd = Cwd::cwd(); + if ( my $code = $sym->{$pwd} ) { + # Delegate back to parent dirs + goto &$code unless $cwd eq $pwd; + } + $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; + my $method = $1; + if ( uc($method) eq $method ) { + # Do nothing + return; + } elsif ( $method =~ /^_/ and $self->can($method) ) { + # Dispatch to the root M:I class + return $self->$method(@_); + } + + # Dispatch to the appropriate plugin + unshift @_, ( $self, $1 ); + goto &{$self->can('call')}; + }; +} + +sub preload { + my $self = shift; + unless ( $self->{extensions} ) { + $self->load_extensions( + "$self->{prefix}/$self->{path}", $self + ); + } + + my @exts = @{$self->{extensions}}; + unless ( @exts ) { + @exts = $self->{admin}->load_all_extensions; + } + + my %seen; + foreach my $obj ( @exts ) { + while (my ($method, $glob) = each %{ref($obj) . '::'}) { + next unless $obj->can($method); + next if $method =~ /^_/; + next if $method eq uc($method); + $seen{$method}++; + } + } + + my $who = $self->_caller; + foreach my $name ( sort keys %seen ) { + *{"${who}::$name"} = sub { + ${"${who}::AUTOLOAD"} = "${who}::$name"; + goto &{"${who}::AUTOLOAD"}; + }; + } +} + +sub new { + my ($class, %args) = @_; + + # ignore the prefix on extension modules built from top level. + my $base_path = Cwd::abs_path($FindBin::Bin); + unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { + delete $args{prefix}; + } + + return $args{_self} if $args{_self}; + + $args{dispatch} ||= 'Admin'; + $args{prefix} ||= 'inc'; + $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); + $args{bundle} ||= 'inc/BUNDLES'; + $args{base} ||= $base_path; + $class =~ s/^\Q$args{prefix}\E:://; + $args{name} ||= $class; + $args{version} ||= $class->VERSION; + unless ( $args{path} ) { + $args{path} = $args{name}; + $args{path} =~ s!::!/!g; + } + $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; + $args{wrote} = 0; + + bless( \%args, $class ); +} + +sub call { + my ($self, $method) = @_; + my $obj = $self->load($method) or return; + splice(@_, 0, 2, $obj); + goto &{$obj->can($method)}; +} + +sub load { + my ($self, $method) = @_; + + $self->load_extensions( + "$self->{prefix}/$self->{path}", $self + ) unless $self->{extensions}; + + foreach my $obj (@{$self->{extensions}}) { + return $obj if $obj->can($method); + } + + my $admin = $self->{admin} or die <<"END_DIE"; +The '$method' method does not exist in the '$self->{prefix}' path! +Please remove the '$self->{prefix}' directory and run $0 again to load it. +END_DIE + + my $obj = $admin->load($method, 1); + push @{$self->{extensions}}, $obj; + + $obj; +} + +sub load_extensions { + my ($self, $path, $top) = @_; + + unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { + unshift @INC, $self->{prefix}; + } + + foreach my $rv ( $self->find_extensions($path) ) { + my ($file, $pkg) = @{$rv}; + next if $self->{pathnames}{$pkg}; + + local $@; + my $new = eval { require $file; $pkg->can('new') }; + unless ( $new ) { + warn $@ if $@; + next; + } + $self->{pathnames}{$pkg} = delete $INC{$file}; + push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); + } + + $self->{extensions} ||= []; +} + +sub find_extensions { + my ($self, $path) = @_; + + my @found; + File::Find::find( sub { + my $file = $File::Find::name; + return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; + my $subpath = $1; + return if lc($subpath) eq lc($self->{dispatch}); + + $file = "$self->{path}/$subpath.pm"; + my $pkg = "$self->{name}::$subpath"; + $pkg =~ s!/!::!g; + + # If we have a mixed-case package name, assume case has been preserved + # correctly. Otherwise, root through the file to locate the case-preserved + # version of the package name. + if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { + my $content = Module::Install::_read($subpath . '.pm'); + my $in_pod = 0; + foreach ( split //, $content ) { + $in_pod = 1 if /^=\w/; + $in_pod = 0 if /^=cut/; + next if ($in_pod || /^=cut/); # skip pod text + next if /^\s*#/; # and comments + if ( m/^\s*package\s+($pkg)\s*;/i ) { + $pkg = $1; + last; + } + } + } + + push @found, [ $file, $pkg ]; + }, $path ) if -d $path; + + @found; +} + + + + + +##################################################################### +# Common Utility Functions + +sub _caller { + my $depth = 0; + my $call = caller($depth); + while ( $call eq __PACKAGE__ ) { + $depth++; + $call = caller($depth); + } + return $call; +} + +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; +sub _read { + local *FH; + open( FH, '<', $_[0] ) or die "open($_[0]): $!"; + my $string = do { local $/; }; + close FH or die "close($_[0]): $!"; + return $string; +} +END_NEW +sub _read { + local *FH; + open( FH, "< $_[0]" ) or die "open($_[0]): $!"; + my $string = do { local $/; }; + close FH or die "close($_[0]): $!"; + return $string; +} +END_OLD + +sub _readperl { + my $string = Module::Install::_read($_[0]); + $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; + $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; + $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; + return $string; +} + +sub _readpod { + my $string = Module::Install::_read($_[0]); + $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; + return $string if $_[0] =~ /\.pod\z/; + $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; + $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; + $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; + $string =~ s/^\n+//s; + return $string; +} + +# Done in evals to avoid confusing Perl::MinimumVersion +eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; +sub _write { + local *FH; + open( FH, '>', $_[0] ) or die "open($_[0]): $!"; + foreach ( 1 .. $#_ ) { + print FH $_[$_] or die "print($_[0]): $!"; + } + close FH or die "close($_[0]): $!"; +} +END_NEW +sub _write { + local *FH; + open( FH, "> $_[0]" ) or die "open($_[0]): $!"; + foreach ( 1 .. $#_ ) { + print FH $_[$_] or die "print($_[0]): $!"; + } + close FH or die "close($_[0]): $!"; +} +END_OLD + +# _version is for processing module versions (eg, 1.03_05) not +# Perl versions (eg, 5.8.1). +sub _version ($) { + my $s = shift || 0; + my $d =()= $s =~ /(\.)/g; + if ( $d >= 2 ) { + # Normalise multipart versions + $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; + } + $s =~ s/^(\d+)\.?//; + my $l = $1 || 0; + my @v = map { + $_ . '0' x (3 - length $_) + } $s =~ /(\d{1,3})\D?/g; + $l = $l . '.' . join '', @v if @v; + return $l + 0; +} + +sub _cmp ($$) { + _version($_[0]) <=> _version($_[1]); +} + +# Cloned from Params::Util::_CLASS +sub _CLASS ($) { + ( + defined $_[0] + and + ! ref $_[0] + and + $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s + ) ? $_[0] : undef; +} + +1; + +# Copyright 2008 - 2010 Adam Kennedy. diff --git a/inc/Module/Install/Base.pm b/inc/Module/Install/Base.pm new file mode 100644 index 0000000..4224c4d --- /dev/null +++ b/inc/Module/Install/Base.pm @@ -0,0 +1,78 @@ +#line 1 +package Module::Install::Base; + +use strict 'vars'; +use vars qw{$VERSION}; +BEGIN { + $VERSION = '0.95'; +} + +# Suspend handler for "redefined" warnings +BEGIN { + my $w = $SIG{__WARN__}; + $SIG{__WARN__} = sub { $w }; +} + +#line 42 + +sub new { + my $class = shift; + unless ( defined &{"${class}::call"} ) { + *{"${class}::call"} = sub { shift->_top->call(@_) }; + } + unless ( defined &{"${class}::load"} ) { + *{"${class}::load"} = sub { shift->_top->load(@_) }; + } + bless { @_ }, $class; +} + +#line 61 + +sub AUTOLOAD { + local $@; + my $func = eval { shift->_top->autoload } or return; + goto &$func; +} + +#line 75 + +sub _top { + $_[0]->{_top}; +} + +#line 90 + +sub admin { + $_[0]->_top->{admin} + or + Module::Install::Base::FakeAdmin->new; +} + +#line 106 + +sub is_admin { + $_[0]->admin->VERSION; +} + +sub DESTROY {} + +package Module::Install::Base::FakeAdmin; + +my $fake; + +sub new { + $fake ||= bless(\@_, $_[0]); +} + +sub AUTOLOAD {} + +sub DESTROY {} + +# Restore warning handler +BEGIN { + $SIG{__WARN__} = $SIG{__WARN__}->(); +} + +1; + +#line 154 diff --git a/inc/Module/Install/Can.pm b/inc/Module/Install/Can.pm new file mode 100644 index 0000000..c9f91d1 --- /dev/null +++ b/inc/Module/Install/Can.pm @@ -0,0 +1,81 @@ +#line 1 +package Module::Install::Can; + +use strict; +use Config (); +use File::Spec (); +use ExtUtils::MakeMaker (); +use Module::Install::Base (); + +use vars qw{$VERSION @ISA $ISCORE}; +BEGIN { + $VERSION = '0.95'; + @ISA = 'Module::Install::Base'; + $ISCORE = 1; +} + +# check if we can load some module +### Upgrade this to not have to load the module if possible +sub can_use { + my ($self, $mod, $ver) = @_; + $mod =~ s{::|\\}{/}g; + $mod .= '.pm' unless $mod =~ /\.pm$/i; + + my $pkg = $mod; + $pkg =~ s{/}{::}g; + $pkg =~ s{\.pm$}{}i; + + local $@; + eval { require $mod; $pkg->VERSION($ver || 0); 1 }; +} + +# check if we can run some command +sub can_run { + my ($self, $cmd) = @_; + + my $_cmd = $cmd; + return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); + + for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { + next if $dir eq ''; + my $abs = File::Spec->catfile($dir, $_[1]); + return $abs if (-x $abs or $abs = MM->maybe_command($abs)); + } + + return; +} + +# can we locate a (the) C compiler +sub can_cc { + my $self = shift; + my @chunks = split(/ /, $Config::Config{cc}) or return; + + # $Config{cc} may contain args; try to find out the program part + while (@chunks) { + return $self->can_run("@chunks") || (pop(@chunks), next); + } + + return; +} + +# Fix Cygwin bug on maybe_command(); +if ( $^O eq 'cygwin' ) { + require ExtUtils::MM_Cygwin; + require ExtUtils::MM_Win32; + if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { + *ExtUtils::MM_Cygwin::maybe_command = sub { + my ($self, $file) = @_; + if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { + ExtUtils::MM_Win32->maybe_command($file); + } else { + ExtUtils::MM_Unix->maybe_command($file); + } + } + } +} + +1; + +__END__ + +#line 156 diff --git a/inc/Module/Install/Fetch.pm b/inc/Module/Install/Fetch.pm new file mode 100644 index 0000000..c728bcd --- /dev/null +++ b/inc/Module/Install/Fetch.pm @@ -0,0 +1,93 @@ +#line 1 +package Module::Install::Fetch; + +use strict; +use Module::Install::Base (); + +use vars qw{$VERSION @ISA $ISCORE}; +BEGIN { + $VERSION = '0.95'; + @ISA = 'Module::Install::Base'; + $ISCORE = 1; +} + +sub get_file { + my ($self, %args) = @_; + my ($scheme, $host, $path, $file) = + $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; + + if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { + $args{url} = $args{ftp_url} + or (warn("LWP support unavailable!\n"), return); + ($scheme, $host, $path, $file) = + $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; + } + + $|++; + print "Fetching '$file' from $host... "; + + unless (eval { require Socket; Socket::inet_aton($host) }) { + warn "'$host' resolve failed!\n"; + return; + } + + return unless $scheme eq 'ftp' or $scheme eq 'http'; + + require Cwd; + my $dir = Cwd::getcwd(); + chdir $args{local_dir} or return if exists $args{local_dir}; + + if (eval { require LWP::Simple; 1 }) { + LWP::Simple::mirror($args{url}, $file); + } + elsif (eval { require Net::FTP; 1 }) { eval { + # use Net::FTP to get past firewall + my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); + $ftp->login("anonymous", 'anonymous@example.com'); + $ftp->cwd($path); + $ftp->binary; + $ftp->get($file) or (warn("$!\n"), return); + $ftp->quit; + } } + elsif (my $ftp = $self->can_run('ftp')) { eval { + # no Net::FTP, fallback to ftp.exe + require FileHandle; + my $fh = FileHandle->new; + + local $SIG{CHLD} = 'IGNORE'; + unless ($fh->open("|$ftp -n")) { + warn "Couldn't open ftp: $!\n"; + chdir $dir; return; + } + + my @dialog = split(/\n/, <<"END_FTP"); +open $host +user anonymous anonymous\@example.com +cd $path +binary +get $file $file +quit +END_FTP + foreach (@dialog) { $fh->print("$_\n") } + $fh->close; + } } + else { + warn "No working 'ftp' program available!\n"; + chdir $dir; return; + } + + unless (-f $file) { + warn "Fetching failed: $@\n"; + chdir $dir; return; + } + + return if exists $args{size} and -s $file != $args{size}; + system($args{run}) if exists $args{run}; + unlink($file) if $args{remove}; + + print(((!exists $args{check_for} or -e $args{check_for}) + ? "done!" : "failed! ($!)"), "\n"); + chdir $dir; return !$?; +} + +1; diff --git a/inc/Module/Install/Makefile.pm b/inc/Module/Install/Makefile.pm new file mode 100644 index 0000000..431ec3f --- /dev/null +++ b/inc/Module/Install/Makefile.pm @@ -0,0 +1,405 @@ +#line 1 +package Module::Install::Makefile; + +use strict 'vars'; +use ExtUtils::MakeMaker (); +use Module::Install::Base (); + +use vars qw{$VERSION @ISA $ISCORE}; +BEGIN { + $VERSION = '0.95'; + @ISA = 'Module::Install::Base'; + $ISCORE = 1; +} + +sub Makefile { $_[0] } + +my %seen = (); + +sub prompt { + shift; + + # Infinite loop protection + my @c = caller(); + if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { + die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; + } + + # In automated testing or non-interactive session, always use defaults + if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { + local $ENV{PERL_MM_USE_DEFAULT} = 1; + goto &ExtUtils::MakeMaker::prompt; + } else { + goto &ExtUtils::MakeMaker::prompt; + } +} + +# Store a cleaned up version of the MakeMaker version, +# since we need to behave differently in a variety of +# ways based on the MM version. +my $makemaker = eval $ExtUtils::MakeMaker::VERSION; + +# If we are passed a param, do a "newer than" comparison. +# Otherwise, just return the MakeMaker version. +sub makemaker { + ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 +} + +# Ripped from ExtUtils::MakeMaker 6.56, and slightly modified +# as we only need to know here whether the attribute is an array +# or a hash or something else (which may or may not be appendable). +my %makemaker_argtype = ( + C => 'ARRAY', + CONFIG => 'ARRAY', +# CONFIGURE => 'CODE', # ignore + DIR => 'ARRAY', + DL_FUNCS => 'HASH', + DL_VARS => 'ARRAY', + EXCLUDE_EXT => 'ARRAY', + EXE_FILES => 'ARRAY', + FUNCLIST => 'ARRAY', + H => 'ARRAY', + IMPORTS => 'HASH', + INCLUDE_EXT => 'ARRAY', + LIBS => 'ARRAY', # ignore '' + MAN1PODS => 'HASH', + MAN3PODS => 'HASH', + META_ADD => 'HASH', + META_MERGE => 'HASH', + PL_FILES => 'HASH', + PM => 'HASH', + PMLIBDIRS => 'ARRAY', + PMLIBPARENTDIRS => 'ARRAY', + PREREQ_PM => 'HASH', + CONFIGURE_REQUIRES => 'HASH', + SKIP => 'ARRAY', + TYPEMAPS => 'ARRAY', + XS => 'HASH', +# VERSION => ['version',''], # ignore +# _KEEP_AFTER_FLUSH => '', + + clean => 'HASH', + depend => 'HASH', + dist => 'HASH', + dynamic_lib=> 'HASH', + linkext => 'HASH', + macro => 'HASH', + postamble => 'HASH', + realclean => 'HASH', + test => 'HASH', + tool_autosplit => 'HASH', + + # special cases where you can use makemaker_append + CCFLAGS => 'APPENDABLE', + DEFINE => 'APPENDABLE', + INC => 'APPENDABLE', + LDDLFLAGS => 'APPENDABLE', + LDFROM => 'APPENDABLE', +); + +sub makemaker_args { + my ($self, %new_args) = @_; + my $args = ( $self->{makemaker_args} ||= {} ); + foreach my $key (keys %new_args) { + if ($makemaker_argtype{$key} eq 'ARRAY') { + $args->{$key} = [] unless defined $args->{$key}; + unless (ref $args->{$key} eq 'ARRAY') { + $args->{$key} = [$args->{$key}] + } + push @{$args->{$key}}, + ref $new_args{$key} eq 'ARRAY' + ? @{$new_args{$key}} + : $new_args{$key}; + } + elsif ($makemaker_argtype{$key} eq 'HASH') { + $args->{$key} = {} unless defined $args->{$key}; + foreach my $skey (keys %{ $new_args{$key} }) { + $args->{$key}{$skey} = $new_args{$key}{$skey}; + } + } + elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { + $self->makemaker_append($key => $new_args{$key}); + } + else { + if (defined $args->{$key}) { + warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; + } + $args->{$key} = $new_args{$key}; + } + } + return $args; +} + +# For mm args that take multiple space-seperated args, +# append an argument to the current list. +sub makemaker_append { + my $self = shift; + my $name = shift; + my $args = $self->makemaker_args; + $args->{$name} = defined $args->{$name} + ? join( ' ', $args->{$name}, @_ ) + : join( ' ', @_ ); +} + +sub build_subdirs { + my $self = shift; + my $subdirs = $self->makemaker_args->{DIR} ||= []; + for my $subdir (@_) { + push @$subdirs, $subdir; + } +} + +sub clean_files { + my $self = shift; + my $clean = $self->makemaker_args->{clean} ||= {}; + %$clean = ( + %$clean, + FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), + ); +} + +sub realclean_files { + my $self = shift; + my $realclean = $self->makemaker_args->{realclean} ||= {}; + %$realclean = ( + %$realclean, + FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), + ); +} + +sub libs { + my $self = shift; + my $libs = ref $_[0] ? shift : [ shift ]; + $self->makemaker_args( LIBS => $libs ); +} + +sub inc { + my $self = shift; + $self->makemaker_args( INC => shift ); +} + +my %test_dir = (); + +sub _wanted_t { + /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; +} + +sub tests_recursive { + my $self = shift; + if ( $self->tests ) { + die "tests_recursive will not work if tests are already defined"; + } + my $dir = shift || 't'; + unless ( -d $dir ) { + die "tests_recursive dir '$dir' does not exist"; + } + %test_dir = (); + require File::Find; + File::Find::find( \&_wanted_t, $dir ); + if ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { + File::Find::find( \&_wanted_t, 'xt' ); + } + $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); +} + +sub write { + my $self = shift; + die "&Makefile->write() takes no arguments\n" if @_; + + # Check the current Perl version + my $perl_version = $self->perl_version; + if ( $perl_version ) { + eval "use $perl_version; 1" + or die "ERROR: perl: Version $] is installed, " + . "but we need version >= $perl_version"; + } + + # Make sure we have a new enough MakeMaker + require ExtUtils::MakeMaker; + + if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { + # MakeMaker can complain about module versions that include + # an underscore, even though its own version may contain one! + # Hence the funny regexp to get rid of it. See RT #35800 + # for details. + my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; + $self->build_requires( 'ExtUtils::MakeMaker' => $v ); + $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); + } else { + # Allow legacy-compatibility with 5.005 by depending on the + # most recent EU:MM that supported 5.005. + $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); + $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); + } + + # Generate the MakeMaker params + my $args = $self->makemaker_args; + $args->{DISTNAME} = $self->name; + $args->{NAME} = $self->module_name || $self->name; + $args->{NAME} =~ s/-/::/g; + $args->{VERSION} = $self->version or die <<'EOT'; +ERROR: Can't determine distribution version. Please specify it +explicitly via 'version' in Makefile.PL, or set a valid $VERSION +in a module, and provide its file path via 'version_from' (or +'all_from' if you prefer) in Makefile.PL. +EOT + + $DB::single = 1; + if ( $self->tests ) { + my @tests = split ' ', $self->tests; + my %seen; + $args->{test} = { + TESTS => (join ' ', grep {!$seen{$_}++} @tests), + }; + } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { + $args->{test} = { + TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), + }; + } + if ( $] >= 5.005 ) { + $args->{ABSTRACT} = $self->abstract; + $args->{AUTHOR} = join ', ', @{$self->author || []}; + } + if ( $self->makemaker(6.10) ) { + $args->{NO_META} = 1; + #$args->{NO_MYMETA} = 1; + } + if ( $self->makemaker(6.17) and $self->sign ) { + $args->{SIGN} = 1; + } + unless ( $self->is_admin ) { + delete $args->{SIGN}; + } + if ( $self->makemaker(6.31) and $self->license ) { + $args->{LICENSE} = $self->license; + } + + my $prereq = ($args->{PREREQ_PM} ||= {}); + %$prereq = ( %$prereq, + map { @$_ } # flatten [module => version] + map { @$_ } + grep $_, + ($self->requires) + ); + + # Remove any reference to perl, PREREQ_PM doesn't support it + delete $args->{PREREQ_PM}->{perl}; + + # Merge both kinds of requires into BUILD_REQUIRES + my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); + %$build_prereq = ( %$build_prereq, + map { @$_ } # flatten [module => version] + map { @$_ } + grep $_, + ($self->configure_requires, $self->build_requires) + ); + + # Remove any reference to perl, BUILD_REQUIRES doesn't support it + delete $args->{BUILD_REQUIRES}->{perl}; + + # Delete bundled dists from prereq_pm + my $subdirs = ($args->{DIR} ||= []); + if ($self->bundles) { + foreach my $bundle (@{ $self->bundles }) { + my ($file, $dir) = @$bundle; + push @$subdirs, $dir if -d $dir; + delete $build_prereq->{$file}; #Delete from build prereqs only + } + } + + unless ( $self->makemaker('6.55_03') ) { + %$prereq = (%$prereq,%$build_prereq); + delete $args->{BUILD_REQUIRES}; + } + + if ( my $perl_version = $self->perl_version ) { + eval "use $perl_version; 1" + or die "ERROR: perl: Version $] is installed, " + . "but we need version >= $perl_version"; + + if ( $self->makemaker(6.48) ) { + $args->{MIN_PERL_VERSION} = $perl_version; + } + } + + if ($self->installdirs) { + warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; + $args->{INSTALLDIRS} = $self->installdirs; + } + + my %args = map { + ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) + } keys %$args; + + my $user_preop = delete $args{dist}->{PREOP}; + if ( my $preop = $self->admin->preop($user_preop) ) { + foreach my $key ( keys %$preop ) { + $args{dist}->{$key} = $preop->{$key}; + } + } + + my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); + $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); +} + +sub fix_up_makefile { + my $self = shift; + my $makefile_name = shift; + my $top_class = ref($self->_top) || ''; + my $top_version = $self->_top->VERSION || ''; + + my $preamble = $self->preamble + ? "# Preamble by $top_class $top_version\n" + . $self->preamble + : ''; + my $postamble = "# Postamble by $top_class $top_version\n" + . ($self->postamble || ''); + + local *MAKEFILE; + open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; + my $makefile = do { local $/; }; + close MAKEFILE or die $!; + + $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; + $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; + $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; + $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; + $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; + + # Module::Install will never be used to build the Core Perl + # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks + # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist + $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; + #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; + + # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. + $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; + + # XXX - This is currently unused; not sure if it breaks other MM-users + # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; + + open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; + print MAKEFILE "$preamble$makefile$postamble" or die $!; + close MAKEFILE or die $!; + + 1; +} + +sub preamble { + my ($self, $text) = @_; + $self->{preamble} = $text . $self->{preamble} if defined $text; + $self->{preamble}; +} + +sub postamble { + my ($self, $text) = @_; + $self->{postamble} ||= $self->admin->postamble; + $self->{postamble} .= $text if defined $text; + $self->{postamble} +} + +1; + +__END__ + +#line 531 diff --git a/inc/Module/Install/Metadata.pm b/inc/Module/Install/Metadata.pm new file mode 100644 index 0000000..162bde0 --- /dev/null +++ b/inc/Module/Install/Metadata.pm @@ -0,0 +1,694 @@ +#line 1 +package Module::Install::Metadata; + +use strict 'vars'; +use Module::Install::Base (); + +use vars qw{$VERSION @ISA $ISCORE}; +BEGIN { + $VERSION = '0.95'; + @ISA = 'Module::Install::Base'; + $ISCORE = 1; +} + +my @boolean_keys = qw{ + sign +}; + +my @scalar_keys = qw{ + name + module_name + abstract + version + distribution_type + tests + installdirs +}; + +my @tuple_keys = qw{ + configure_requires + build_requires + requires + recommends + bundles + resources +}; + +my @resource_keys = qw{ + homepage + bugtracker + repository +}; + +my @array_keys = qw{ + keywords + author +}; + +*authors = \&author; + +sub Meta { shift } +sub Meta_BooleanKeys { @boolean_keys } +sub Meta_ScalarKeys { @scalar_keys } +sub Meta_TupleKeys { @tuple_keys } +sub Meta_ResourceKeys { @resource_keys } +sub Meta_ArrayKeys { @array_keys } + +foreach my $key ( @boolean_keys ) { + *$key = sub { + my $self = shift; + if ( defined wantarray and not @_ ) { + return $self->{values}->{$key}; + } + $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); + return $self; + }; +} + +foreach my $key ( @scalar_keys ) { + *$key = sub { + my $self = shift; + return $self->{values}->{$key} if defined wantarray and !@_; + $self->{values}->{$key} = shift; + return $self; + }; +} + +foreach my $key ( @array_keys ) { + *$key = sub { + my $self = shift; + return $self->{values}->{$key} if defined wantarray and !@_; + $self->{values}->{$key} ||= []; + push @{$self->{values}->{$key}}, @_; + return $self; + }; +} + +foreach my $key ( @resource_keys ) { + *$key = sub { + my $self = shift; + unless ( @_ ) { + return () unless $self->{values}->{resources}; + return map { $_->[1] } + grep { $_->[0] eq $key } + @{ $self->{values}->{resources} }; + } + return $self->{values}->{resources}->{$key} unless @_; + my $uri = shift or die( + "Did not provide a value to $key()" + ); + $self->resources( $key => $uri ); + return 1; + }; +} + +foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { + *$key = sub { + my $self = shift; + return $self->{values}->{$key} unless @_; + my @added; + while ( @_ ) { + my $module = shift or last; + my $version = shift || 0; + push @added, [ $module, $version ]; + } + push @{ $self->{values}->{$key} }, @added; + return map {@$_} @added; + }; +} + +# Resource handling +my %lc_resource = map { $_ => 1 } qw{ + homepage + license + bugtracker + repository +}; + +sub resources { + my $self = shift; + while ( @_ ) { + my $name = shift or last; + my $value = shift or next; + if ( $name eq lc $name and ! $lc_resource{$name} ) { + die("Unsupported reserved lowercase resource '$name'"); + } + $self->{values}->{resources} ||= []; + push @{ $self->{values}->{resources} }, [ $name, $value ]; + } + $self->{values}->{resources}; +} + +# Aliases for build_requires that will have alternative +# meanings in some future version of META.yml. +sub test_requires { shift->build_requires(@_) } +sub install_requires { shift->build_requires(@_) } + +# Aliases for installdirs options +sub install_as_core { $_[0]->installdirs('perl') } +sub install_as_cpan { $_[0]->installdirs('site') } +sub install_as_site { $_[0]->installdirs('site') } +sub install_as_vendor { $_[0]->installdirs('vendor') } + +sub dynamic_config { + my $self = shift; + unless ( @_ ) { + warn "You MUST provide an explicit true/false value to dynamic_config\n"; + return $self; + } + $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; + return 1; +} + +sub perl_version { + my $self = shift; + return $self->{values}->{perl_version} unless @_; + my $version = shift or die( + "Did not provide a value to perl_version()" + ); + + # Normalize the version + $version = $self->_perl_version($version); + + # We don't support the reall old versions + unless ( $version >= 5.005 ) { + die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; + } + + $self->{values}->{perl_version} = $version; +} + +#Stolen from M::B +my %license_urls = ( + perl => 'http://dev.perl.org/licenses/', + apache => 'http://apache.org/licenses/LICENSE-2.0', + 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', + open_source => undef, + unrestricted => undef, + restrictive => undef, + unknown => undef, +); + +sub license { + my $self = shift; + return $self->{values}->{license} unless @_; + my $license = shift or die( + 'Did not provide a value to license()' + ); + $self->{values}->{license} = $license; + + # Automatically fill in license URLs + if ( $license_urls{$license} ) { + $self->resources( license => $license_urls{$license} ); + } + + return 1; +} + +sub all_from { + my ( $self, $file ) = @_; + + unless ( defined($file) ) { + my $name = $self->name or die( + "all_from called with no args without setting name() first" + ); + $file = join('/', 'lib', split(/-/, $name)) . '.pm'; + $file =~ s{.*/}{} unless -e $file; + unless ( -e $file ) { + die("all_from cannot find $file from $name"); + } + } + unless ( -f $file ) { + die("The path '$file' does not exist, or is not a file"); + } + + $self->{values}{all_from} = $file; + + # Some methods pull from POD instead of code. + # If there is a matching .pod, use that instead + my $pod = $file; + $pod =~ s/\.pm$/.pod/i; + $pod = $file unless -e $pod; + + # Pull the different values + $self->name_from($file) unless $self->name; + $self->version_from($file) unless $self->version; + $self->perl_version_from($file) unless $self->perl_version; + $self->author_from($pod) unless @{$self->author || []}; + $self->license_from($pod) unless $self->license; + $self->abstract_from($pod) unless $self->abstract; + + return 1; +} + +sub provides { + my $self = shift; + my $provides = ( $self->{values}->{provides} ||= {} ); + %$provides = (%$provides, @_) if @_; + return $provides; +} + +sub auto_provides { + my $self = shift; + return $self unless $self->is_admin; + unless (-e 'MANIFEST') { + warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; + return $self; + } + # Avoid spurious warnings as we are not checking manifest here. + local $SIG{__WARN__} = sub {1}; + require ExtUtils::Manifest; + local *ExtUtils::Manifest::manicheck = sub { return }; + + require Module::Build; + my $build = Module::Build->new( + dist_name => $self->name, + dist_version => $self->version, + license => $self->license, + ); + $self->provides( %{ $build->find_dist_packages || {} } ); +} + +sub feature { + my $self = shift; + my $name = shift; + my $features = ( $self->{values}->{features} ||= [] ); + my $mods; + + if ( @_ == 1 and ref( $_[0] ) ) { + # The user used ->feature like ->features by passing in the second + # argument as a reference. Accomodate for that. + $mods = $_[0]; + } else { + $mods = \@_; + } + + my $count = 0; + push @$features, ( + $name => [ + map { + ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ + } @$mods + ] + ); + + return @$features; +} + +sub features { + my $self = shift; + while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { + $self->feature( $name, @$mods ); + } + return $self->{values}->{features} + ? @{ $self->{values}->{features} } + : (); +} + +sub no_index { + my $self = shift; + my $type = shift; + push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; + return $self->{values}->{no_index}; +} + +sub read { + my $self = shift; + $self->include_deps( 'YAML::Tiny', 0 ); + + require YAML::Tiny; + my $data = YAML::Tiny::LoadFile('META.yml'); + + # Call methods explicitly in case user has already set some values. + while ( my ( $key, $value ) = each %$data ) { + next unless $self->can($key); + if ( ref $value eq 'HASH' ) { + while ( my ( $module, $version ) = each %$value ) { + $self->can($key)->($self, $module => $version ); + } + } else { + $self->can($key)->($self, $value); + } + } + return $self; +} + +sub write { + my $self = shift; + return $self unless $self->is_admin; + $self->admin->write_meta; + return $self; +} + +sub version_from { + require ExtUtils::MM_Unix; + my ( $self, $file ) = @_; + $self->version( ExtUtils::MM_Unix->parse_version($file) ); +} + +sub abstract_from { + require ExtUtils::MM_Unix; + my ( $self, $file ) = @_; + $self->abstract( + bless( + { DISTNAME => $self->name }, + 'ExtUtils::MM_Unix' + )->parse_abstract($file) + ); +} + +# Add both distribution and module name +sub name_from { + my ($self, $file) = @_; + if ( + Module::Install::_read($file) =~ m/ + ^ \s* + package \s* + ([\w:]+) + \s* ; + /ixms + ) { + my ($name, $module_name) = ($1, $1); + $name =~ s{::}{-}g; + $self->name($name); + unless ( $self->module_name ) { + $self->module_name($module_name); + } + } else { + die("Cannot determine name from $file\n"); + } +} + +sub _extract_perl_version { + if ( + $_[0] =~ m/ + ^\s* + (?:use|require) \s* + v? + ([\d_\.]+) + \s* ; + /ixms + ) { + my $perl_version = $1; + $perl_version =~ s{_}{}g; + return $perl_version; + } else { + return; + } +} + +sub perl_version_from { + my $self = shift; + my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); + if ($perl_version) { + $self->perl_version($perl_version); + } else { + warn "Cannot determine perl version info from $_[0]\n"; + return; + } +} + +sub author_from { + my $self = shift; + my $content = Module::Install::_read($_[0]); + if ($content =~ m/ + =head \d \s+ (?:authors?)\b \s* + ([^\n]*) + | + =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* + .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* + ([^\n]*) + /ixms) { + my $author = $1 || $2; + + # XXX: ugly but should work anyway... + if (eval "require Pod::Escapes; 1") { + # Pod::Escapes has a mapping table. + # It's in core of perl >= 5.9.3, and should be installed + # as one of the Pod::Simple's prereqs, which is a prereq + # of Pod::Text 3.x (see also below). + $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } + { + defined $2 + ? chr($2) + : defined $Pod::Escapes::Name2character_number{$1} + ? chr($Pod::Escapes::Name2character_number{$1}) + : do { + warn "Unknown escape: E<$1>"; + "E<$1>"; + }; + }gex; + } + elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { + # Pod::Text < 3.0 has yet another mapping table, + # though the table name of 2.x and 1.x are different. + # (1.x is in core of Perl < 5.6, 2.x is in core of + # Perl < 5.9.3) + my $mapping = ($Pod::Text::VERSION < 2) + ? \%Pod::Text::HTML_Escapes + : \%Pod::Text::ESCAPES; + $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } + { + defined $2 + ? chr($2) + : defined $mapping->{$1} + ? $mapping->{$1} + : do { + warn "Unknown escape: E<$1>"; + "E<$1>"; + }; + }gex; + } + else { + $author =~ s{E}{<}g; + $author =~ s{E}{>}g; + } + $self->author($author); + } else { + warn "Cannot determine author info from $_[0]\n"; + } +} + +sub _extract_license { + my $pod = shift; + my $matched; + return __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ (?:licen[cs]e|licensing)\b.*?) + (=head \d.*|=cut.*|)\z + /ixms + ) || __extract_license( + ($matched) = $pod =~ m/ + (=head \d \s+ (?:copyrights?|legal)\b.*?) + (=head \d.*|=cut.*|)\z + /ixms + ); +} + +sub __extract_license { + my $license_text = shift or return; + my @phrases = ( + 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1, + 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1, + 'Artistic and GPL' => 'perl', 1, + 'GNU general public license' => 'gpl', 1, + 'GNU public license' => 'gpl', 1, + 'GNU lesser general public license' => 'lgpl', 1, + 'GNU lesser public license' => 'lgpl', 1, + 'GNU library general public license' => 'lgpl', 1, + 'GNU library public license' => 'lgpl', 1, + 'BSD license' => 'bsd', 1, + 'Artistic license' => 'artistic', 1, + 'GPL' => 'gpl', 1, + 'LGPL' => 'lgpl', 1, + 'BSD' => 'bsd', 1, + 'Artistic' => 'artistic', 1, + 'MIT' => 'mit', 1, + 'proprietary' => 'proprietary', 0, + ); + while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { + $pattern =~ s#\s+#\\s+#gs; + if ( $license_text =~ /\b$pattern\b/i ) { + return $license; + } + } +} + +sub license_from { + my $self = shift; + if (my $license=_extract_license(Module::Install::_read($_[0]))) { + $self->license($license); + } else { + warn "Cannot determine license info from $_[0]\n"; + return 'unknown'; + } +} + +sub _extract_bugtracker { + my @links = $_[0] =~ m#L<( + \Qhttp://rt.cpan.org/\E[^>]+| + \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| + \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list + )>#gx; + my %links; + @links{@links}=(); + @links=keys %links; + return @links; +} + +sub bugtracker_from { + my $self = shift; + my $content = Module::Install::_read($_[0]); + my @links = _extract_bugtracker($content); + unless ( @links ) { + warn "Cannot determine bugtracker info from $_[0]\n"; + return 0; + } + if ( @links > 1 ) { + warn "Found more than one bugtracker link in $_[0]\n"; + return 0; + } + + # Set the bugtracker + bugtracker( $links[0] ); + return 1; +} + +sub requires_from { + my $self = shift; + my $content = Module::Install::_readperl($_[0]); + my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; + while ( @requires ) { + my $module = shift @requires; + my $version = shift @requires; + $self->requires( $module => $version ); + } +} + +sub test_requires_from { + my $self = shift; + my $content = Module::Install::_readperl($_[0]); + my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; + while ( @requires ) { + my $module = shift @requires; + my $version = shift @requires; + $self->test_requires( $module => $version ); + } +} + +# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to +# numbers (eg, 5.006001 or 5.008009). +# Also, convert double-part versions (eg, 5.8) +sub _perl_version { + my $v = $_[-1]; + $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; + $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; + $v =~ s/(\.\d\d\d)000$/$1/; + $v =~ s/_.+$//; + if ( ref($v) ) { + # Numify + $v = $v + 0; + } + return $v; +} + + + + + +###################################################################### +# MYMETA Support + +sub WriteMyMeta { + die "WriteMyMeta has been deprecated"; +} + +sub write_mymeta_yaml { + my $self = shift; + + # We need YAML::Tiny to write the MYMETA.yml file + unless ( eval { require YAML::Tiny; 1; } ) { + return 1; + } + + # Generate the data + my $meta = $self->_write_mymeta_data or return 1; + + # Save as the MYMETA.yml file + print "Writing MYMETA.yml\n"; + YAML::Tiny::DumpFile('MYMETA.yml', $meta); +} + +sub write_mymeta_json { + my $self = shift; + + # We need JSON to write the MYMETA.json file + unless ( eval { require JSON; 1; } ) { + return 1; + } + + # Generate the data + my $meta = $self->_write_mymeta_data or return 1; + + # Save as the MYMETA.yml file + print "Writing MYMETA.json\n"; + Module::Install::_write( + 'MYMETA.json', + JSON->new->pretty(1)->canonical->encode($meta), + ); +} + +sub _write_mymeta_data { + my $self = shift; + + # If there's no existing META.yml there is nothing we can do + return undef unless -f 'META.yml'; + + # We need Parse::CPAN::Meta to load the file + unless ( eval { require Parse::CPAN::Meta; 1; } ) { + return undef; + } + + # Merge the perl version into the dependencies + my $val = $self->Meta->{values}; + my $perl = delete $val->{perl_version}; + if ( $perl ) { + $val->{requires} ||= []; + my $requires = $val->{requires}; + + # Canonize to three-dot version after Perl 5.6 + if ( $perl >= 5.006 ) { + $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e + } + unshift @$requires, [ perl => $perl ]; + } + + # Load the advisory META.yml file + my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); + my $meta = $yaml[0]; + + # Overwrite the non-configure dependency hashs + delete $meta->{requires}; + delete $meta->{build_requires}; + delete $meta->{recommends}; + if ( exists $val->{requires} ) { + $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; + } + if ( exists $val->{build_requires} ) { + $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; + } + + return $meta; +} + +1; diff --git a/inc/Module/Install/Win32.pm b/inc/Module/Install/Win32.pm new file mode 100644 index 0000000..f55e166 --- /dev/null +++ b/inc/Module/Install/Win32.pm @@ -0,0 +1,64 @@ +#line 1 +package Module::Install::Win32; + +use strict; +use Module::Install::Base (); + +use vars qw{$VERSION @ISA $ISCORE}; +BEGIN { + $VERSION = '0.95'; + @ISA = 'Module::Install::Base'; + $ISCORE = 1; +} + +# determine if the user needs nmake, and download it if needed +sub check_nmake { + my $self = shift; + $self->load('can_run'); + $self->load('get_file'); + + require Config; + return unless ( + $^O eq 'MSWin32' and + $Config::Config{make} and + $Config::Config{make} =~ /^nmake\b/i and + ! $self->can_run('nmake') + ); + + print "The required 'nmake' executable not found, fetching it...\n"; + + require File::Basename; + my $rv = $self->get_file( + url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', + ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', + local_dir => File::Basename::dirname($^X), + size => 51928, + run => 'Nmake15.exe /o > nul', + check_for => 'Nmake.exe', + remove => 1, + ); + + die <<'END_MESSAGE' unless $rv; + +------------------------------------------------------------------------------- + +Since you are using Microsoft Windows, you will need the 'nmake' utility +before installation. It's available at: + + http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe + or + ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe + +Please download the file manually, save it to a directory in %PATH% (e.g. +C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to +that directory, and run "Nmake15.exe" from there; that will create the +'nmake.exe' file needed by this module. + +You may then resume the installation process described in README. + +------------------------------------------------------------------------------- +END_MESSAGE + +} + +1; diff --git a/inc/Module/Install/WriteAll.pm b/inc/Module/Install/WriteAll.pm new file mode 100644 index 0000000..6b3bba7 --- /dev/null +++ b/inc/Module/Install/WriteAll.pm @@ -0,0 +1,63 @@ +#line 1 +package Module::Install::WriteAll; + +use strict; +use Module::Install::Base (); + +use vars qw{$VERSION @ISA $ISCORE}; +BEGIN { + $VERSION = '0.95';; + @ISA = qw{Module::Install::Base}; + $ISCORE = 1; +} + +sub WriteAll { + my $self = shift; + my %args = ( + meta => 1, + sign => 0, + inline => 0, + check_nmake => 1, + @_, + ); + + $self->sign(1) if $args{sign}; + $self->admin->WriteAll(%args) if $self->is_admin; + + $self->check_nmake if $args{check_nmake}; + unless ( $self->makemaker_args->{PL_FILES} ) { + # XXX: This still may be a bit over-defensive... + unless ($self->makemaker(6.25)) { + $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; + } + } + + # Until ExtUtils::MakeMaker support MYMETA.yml, make sure + # we clean it up properly ourself. + $self->realclean_files('MYMETA.yml'); + + if ( $args{inline} ) { + $self->Inline->write; + } else { + $self->Makefile->write; + } + + # The Makefile write process adds a couple of dependencies, + # so write the META.yml files after the Makefile. + if ( $args{meta} ) { + $self->Meta->write; + } + + # Experimental support for MYMETA + if ( $ENV{X_MYMETA} ) { + if ( $ENV{X_MYMETA} eq 'JSON' ) { + $self->Meta->write_mymeta_json; + } else { + $self->Meta->write_mymeta_yaml; + } + } + + return 1; +} + +1; diff --git a/lib/Authen/SASL.pm b/lib/Authen/SASL.pm new file mode 100644 index 0000000..b00cac1 --- /dev/null +++ b/lib/Authen/SASL.pm @@ -0,0 +1,130 @@ +# Copyright (c) 2004-2006 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Authen::SASL; + +use strict; +use vars qw($VERSION @Plugins); +use Carp; + +$VERSION = "2.16"; + +@Plugins = qw( + Authen::SASL::XS + Authen::SASL::Cyrus + Authen::SASL::Perl +); + + +sub import { + shift; + return unless @_; + + local $SIG{__DIE__}; + @Plugins = grep { /^[:\w]+$/ and eval "require $_" } map { /::/ ? $_ : "Authen::SASL::$_" } @_ + or croak "no valid Authen::SASL plugins found"; +} + + +sub new { + my $pkg = shift; + my %opt = ((@_ % 2 ? 'mechanism' : ()), @_); + + my $self = bless { + mechanism => $opt{mechanism} || $opt{mech}, + callback => {}, + debug => $opt{debug}, + }, $pkg; + + $self->callback(%{$opt{callback}}) if ref($opt{callback}) eq 'HASH'; + + # Compat + $self->callback(user => ($self->{user} = $opt{user})) if exists $opt{user}; + $self->callback(pass => $opt{password}) if exists $opt{password}; + $self->callback(pass => $opt{response}) if exists $opt{response}; + + $self; +} + + +sub mechanism { + my $self = shift; + @_ ? $self->{mechanism} = shift + : $self->{mechanism}; +} + +sub callback { + my $self = shift; + + return $self->{callback}{$_[0]} if @_ == 1; + + my %new = @_; + @{$self->{callback}}{keys %new} = values %new; + + $self->{callback}; +} + +# The list of packages should not really be hardcoded here +# We need some way to discover what plugins are installed + +sub client_new { # $self, $service, $host, $secflags + my $self = shift; + + my $err; + foreach my $pkg (@Plugins) { + if (eval "require $pkg" and $pkg->can("client_new")) { + if ($self->{conn} = eval { $pkg->client_new($self, @_) }) { + return $self->{conn}; + } + $err = $@; + } + } + + croak $err || "Cannot find a SASL Connection library"; +} + +sub server_new { # $self, $service, $host, $secflags + my $self = shift; + + my $err; + foreach my $pkg (@Plugins) { + if (eval "require $pkg" and $pkg->can("server_new")) { + if ($self->{conn} = eval { $pkg->server_new($self, @_) } ) { + return $self->{conn}; + } + $err = $@; + } + } + croak $err || "Cannot find a SASL Connection library for server-side authentication"; +} + +sub error { + my $self = shift; + $self->{conn} && $self->{conn}->error; +} + +# Compat. +sub user { + my $self = shift; + my $user = $self->{callback}{user}; + $self->{callback}{user} = shift if @_; + $user; +} + +sub challenge { + my $self = shift; + $self->{conn}->client_step(@_); +} + +sub initial { + my $self = shift; + $self->client_new($self)->client_start; +} + +sub name { + my $self = shift; + $self->{conn} ? $self->{conn}->mechanism : ($self->{mechanism} =~ /(\S+)/)[0]; +} + +1; diff --git a/lib/Authen/SASL.pod b/lib/Authen/SASL.pod new file mode 100644 index 0000000..dd70775 --- /dev/null +++ b/lib/Authen/SASL.pod @@ -0,0 +1,241 @@ + +=head1 NAME + +Authen::SASL - SASL Authentication framework + +=head1 SYNOPSIS + + use Authen::SASL; + + $sasl = Authen::SASL->new( + mechanism => 'CRAM-MD5 PLAIN ANONYMOUS', + callback => { + pass => \&fetch_password, + user => $user, + } + ); + +=head1 DESCRIPTION + +SASL is a generic mechanism for authentication used by several +network protocols. B provides an implementation +framework that all protocols should be able to share. + +The framework allows different implementations of the connection +class to be plugged in. At the time of writing there were two such +plugins. + +=over 4 + +=item Authen::SASL::Perl + +This module implements several mechanisms and is implemented +entirely in Perl. + +=item Authen::SASL::XS + +This module uses the Cyrus SASL C-library (both version 1 and 2 +are supported). + +=item Authen::SASL::Cyrus + +This module is the predecessor to L. It is reccomended +to use L + +=back + +By default the order in which these plugins are selected is +Authen::SASL::XS, Authen::SASL::Cyrus and then Authen::SASL::Perl. + +If you want to change it or want to specifically use one +implementation only simply do + + use Authen::SASL qw(Perl); + +or if you have another plugin module that supports the Authen::SASL API + + use Authen::SASL qw(My::SASL::Plugin); + +=head2 CONTRUCTOR + +=over 4 + +=item new ( OPTIONS ) + +The constructor may be called with or without arguments. Passing arguments is +just a short cut to calling the C and C methods. + +=over 4 + +=item callback =E { NAME => VALUE, NAME => VALUE, ... } + +Set the callbacks. +See the L method for details. + +=item mechanism =E NAMES + +=item mech =E NAMES + +Set the list of mechanisms to choose from. +See the L method for details. + +=item debug =E VALUE + +Set the debug level bit-value to C + +Debug output will be sent to C. The +bits of this value are: + + 1 Show debug messages in the Perl modules for the mechanisms. + (Currently only used in GSSAPI) + 4 With security layers in place show information on packages read. + 8 With security layers in place show information on packages written. + +The default value is 0. + +=back + +=back + +=head2 METHODS + +=over 4 + +=item mechanism ( ) + +Returns the current list of mechanisms + +=item mechanism ( NAMES ) + +Set the list of mechanisms to choose from. C should be a space separated string +of the names. + +=item callback ( NAME ) + +Returns the current callback associated with C. + +=item callback ( NAME => VALUE, NAME => VALUE, ... ) + +Sets the given callbacks to the given values + +=item client_new ( SERVICE, HOST, SECURITY ) + +Creates and returns a new connection object for a client-side connection. + +=item server_new ( SERVICE, HOST, OPTIONS ) + +Creates and returns a new connection object for a server-side connection. + +=item error ( ) + +Returns any error from the last connection + +=back + +=head1 The Connection Class + +=over 4 + +=item server_start ( CHALLENGE ) + +server_start begins the authentication using the chosen mechanism. +If the mechanism is not supported by the installed SASL it fails. +Because for some mechanisms the client has to start the negotiation, +you can give the client challenge as a parameter. + +=item server_step ( CHALLENGE ) + +server_step performs the next step in the negotiation process. The +first parameter you give is the clients challenge/response. + +=item client_start ( ) + +The initial step to be performed. Returns the initial value to pass to the server +or an empty list on error. + +=item client_step ( CHALLENGE ) + +This method is called when a response from the server requires it. CHALLENGE +is the value from the server. Returns the next value to pass to the server or an +empty list on error. + +=item need_step ( ) + +Returns true if the selected mechanism requires another step before completion +(error or success). + +=item answer ( NAME ) + +The method will return the value returned from the last call to the callback NAME + +=item property ( NAME ) + +Returns the property value associated with C. + +=item property ( NAME => VALUE, NAME => VALUE, ... ) + +Sets the named properties to their associated values. + +=item service ( ) + +Returns the service argument that was passed to *_new-methods. + +=item host ( ) + +Returns the host argument that was passed to *_new-methods. + +=item mechanism ( ) + +Returns the name of the chosen mechanism. + +=item is_success ( ) + +Once need_step() returns false, then you can check if the authentication +succeeded by calling this method which returns a boolean value. + +=back + +=head2 Callbacks + +There are three different ways in which a callback may be passed + +=over + +=item CODEREF + +If the value passed is a code reference then, when needed, it will be called +and the connection object will be passed as the first argument. In addition +some callbacks may be passed additional arguments. + +=item ARRAYREF + +If the value passed is an array reference, the first element in the array +must be a code reference. When the callback is called the code reference +will be called with the connection object passed as the first argument +and all other values from the array passed after. + +=item SCALAR + +All other values passed will be used directly. ie it is the same as +passing an code reference that, when called, returns the value. + +=back + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Graham Barr + +Please report any bugs, or post any suggestions, to the perl-ldap mailing list + + +=head1 COPYRIGHT + +Copyright (c) 1998-2005 Graham Barr. All rights reserved. This program is +free software; you can redistribute it and/or modify it under the same +terms as Perl itself. + +=cut diff --git a/lib/Authen/SASL/CRAM_MD5.pm b/lib/Authen/SASL/CRAM_MD5.pm new file mode 100644 index 0000000..2f88542 --- /dev/null +++ b/lib/Authen/SASL/CRAM_MD5.pm @@ -0,0 +1,18 @@ +# Copyright (c) 2002 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Authen::SASL::CRAM_MD5; + +use strict; +use vars qw($VERSION); + +$VERSION = "2.14"; + +sub new { + shift; + Authen::SASL->new(@_, mechanism => 'CRAM-MD5'); +} + +1; + diff --git a/lib/Authen/SASL/EXTERNAL.pm b/lib/Authen/SASL/EXTERNAL.pm new file mode 100644 index 0000000..ed0541e --- /dev/null +++ b/lib/Authen/SASL/EXTERNAL.pm @@ -0,0 +1,18 @@ +# Copyright (c) 2002 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Authen::SASL::EXTERNAL; + +use strict; +use vars qw($VERSION); + +$VERSION = "2.14"; + +sub new { + shift; + Authen::SASL->new(@_, mechanism => 'EXTERNAL'); +} + +1; + diff --git a/lib/Authen/SASL/Perl.pm b/lib/Authen/SASL/Perl.pm new file mode 100644 index 0000000..53e66a2 --- /dev/null +++ b/lib/Authen/SASL/Perl.pm @@ -0,0 +1,344 @@ +# Copyright (c) 2002 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Authen::SASL::Perl; + +use strict; +use vars qw($VERSION); +use Carp; + +$VERSION = "2.14"; + +my %secflags = ( + noplaintext => 1, + noanonymous => 1, + nodictionary => 1, +); +my %have; + +sub server_new { + my ($pkg, $parent, $service, $host, $options) = @_; + + my $self = { + callback => { %{$parent->callback} }, + service => $service || '', + host => $host || '', + debug => $parent->{debug} || 0, + need_step => 1, + }; + + my $mechanism = $parent->mechanism + or croak "No server mechanism specified"; + $mechanism =~ s/^\s*\b(.*)\b\s*$/$1/g; + $mechanism =~ s/-/_/g; + $mechanism = uc $mechanism; + my $mpkg = __PACKAGE__ . "::$mechanism"; + eval "require $mpkg;" + or croak "Cannot use $mpkg for " . $parent->mechanism; + my $server = $mpkg->_init($self); + $server->_init_server($options); + return $server; +} + +sub client_new { + my ($pkg, $parent, $service, $host, $secflags) = @_; + + my @sec = grep { $secflags{$_} } split /\W+/, lc($secflags || ''); + + my $self = { + callback => { %{$parent->callback} }, + service => $service || '', + host => $host || '', + debug => $parent->{debug} || 0, + need_step => 1, + }; + + my @mpkg = sort { + $b->_order <=> $a->_order + } grep { + my $have = $have{$_} ||= (eval "require $_;" and $_->can('_secflags')) ? 1 : -1; + $have > 0 and $_->_secflags(@sec) == @sec + } map { + (my $mpkg = __PACKAGE__ . "::$_") =~ s/-/_/g; + $mpkg; + } split /[^-\w]+/, $parent->mechanism + or croak "No SASL mechanism found\n"; + + $mpkg[0]->_init($self); +} + +sub _init_server {} + +sub _order { 0 } +sub code { defined(shift->{error}) || 0 } +sub error { shift->{error} } +sub service { shift->{service} } +sub host { shift->{host} } + +sub need_step { + my $self = shift; + return 0 if $self->{error}; + return $self->{need_step}; +} + +## I think I need to rename that to end()? +## It doesn't mean that SASL is successful, but that +## that the negotiation is over, no more step necessary +## at least for the client +sub set_success { + my $self = shift; + $self->{need_step} = 0; +} + +sub is_success { + my $self = shift; + return !$self->code && !$self->need_step; +} + +sub set_error { + my $self = shift; + $self->{error} = shift; + return; +} + +# set/get property +sub property { + my $self = shift; + my $prop = $self->{property} ||= {}; + return $prop->{ $_[0] } if @_ == 1; + my %new = @_; + @{$prop}{keys %new} = values %new; + 1; +} + +sub callback { + my $self = shift; + + return $self->{callback}{$_[0]} if @_ == 1; + + my %new = @_; + @{$self->{callback}}{keys %new} = values %new; + + $self->{callback}; +} + +# Should be defined in the mechanism sub-class +sub mechanism { undef } +sub client_step { undef } +sub client_start { undef } +sub server_step { undef } +sub server_start { undef } + +# Private methods used by Authen::SASL::Perl that +# may be overridden in mechanism sub-calsses + +sub _init { + my ($pkg, $href) = @_; + + bless $href, $pkg; +} + +sub _call { + my ($self, $name) = splice(@_,0,2); + + my $cb = $self->{callback}{$name}; + + return undef unless defined $cb; + + my $value; + + if (ref($cb) eq 'ARRAY') { + my @args = @$cb; + $cb = shift @args; + $value = $cb->($self, @args); + } + elsif (ref($cb) eq 'CODE') { + $value = $cb->($self, @_); + } + else { + $value = $cb; + } + + $self->{answer}{$name} = $value + unless $name eq 'pass'; # Do not store password + + return $value; +} + +# TODO: Need a better name than this +sub answer { + my ($self, $name) = @_; + $self->{answer}{$name}; +} + +sub _secflags { 0 } + +sub securesocket { + my $self = shift; + return $_[0] unless (defined($self->property('ssf')) && $self->property('ssf') > 0); + + local *GLOB; # avoid used only once warning + my $glob = \do { local *GLOB; }; + tie(*$glob, 'Authen::SASL::Perl::Layer', $_[0], $self); + $glob; +} + +{ + +# +# Add SASL encoding/decoding to a filehandle +# + + package Authen::SASL::Perl::Layer; + + use bytes; + + require Tie::Handle; + our @ISA = qw(Tie::Handle); + + sub TIEHANDLE { + my ($class, $fh, $conn) = @_; + my $self; + + warn __PACKAGE__ . ': non-blocking handle may not work' + if ($fh->can('blocking') and not $fh->blocking()); + + $self->{fh} = $fh; + $self->{conn} = $conn; + $self->{readbuflen} = 0; + $self->{sndbufsz} = $conn->property('maxout'); + $self->{rcvbufsz} = $conn->property('maxbuf'); + + return bless($self, $class); + } + + sub CLOSE { + my ($self) = @_; + + # forward close to the inner handle + close($self->{fh}); + delete $self->{fh}; + } + + sub DESTROY { + my ($self) = @_; + delete $self->{fh}; + undef $self; + } + + sub FETCH { + my ($self) = @_; + return $self->{fh}; + } + + sub FILENO { + my ($self) = @_; + return fileno($self->{fh}); + } + + + sub READ { + my ($self, $buf, $len, $offset) = @_; + my $debug = $self->{conn}->{debug}; + + $buf = \$_[1]; + + my $avail = $self->{readbuflen}; + + print STDERR " [READ(len=$len,offset=$offset)] avail=$avail;\n" + if ($debug & 4); + + # Check if there's leftovers from a previous READ + if ($avail <= 0) { + $avail = $self->_getbuf(); + return undef unless ($avail > 0); + } + + # if there's more than we need right now, leave the rest for later + if ($avail >= $len) { + print STDERR " GOT ALL: avail=$avail; need=$len\n" + if ($debug & 4); + substr($$buf, $offset, $len) = substr($self->{readbuf}, 0, $len, ''); + $self->{readbuflen} -= $len; + return ($len); + } + + # there's not enough; take all we have, read more on next call + print STDERR " GOT PARTIAL: avail=$avail; need=$len\n" + if ($debug & 4); + substr($$buf, $offset || 0, $avail) = $self->{readbuf}; + $self->{readbuf} = ''; + $self->{readbuflen} = 0; + + return ($avail); + } + + # retrieve and decode a buffer of cipher text in SASL format + sub _getbuf { + my ($self) = @_; + my $debug = $self->{conn}->{debug}; + my $fh = $self->{fh}; + my $buf = ''; + + # first, read 4-octet buffer size + my $n = 0; + while ($n < 4) { + my $rv = sysread($fh, $buf, 4 - $n, $n); + print STDERR " [getbuf: sysread($fh,$buf,4-$n,$n)=$rv: $!\n" + if ($debug & 4); + return $rv unless $rv > 0; + $n += $rv; + } + + # size is encoded in network byte order + my ($bsz) = unpack('N', $buf); + print STDERR " [getbuf: cipher buffer sz=$bsz]\n" if ($debug & 4); + return undef unless ($bsz <= $self->{rcvbufsz}); + + # next, read actual cipher text + $buf = ''; + $n = 0; + while ($n < $bsz) { + my $rv = sysread($fh, $buf, $bsz - $n, $n); + print STDERR " [getbuf: got o=$n,n=", $bsz - $n, ",rv=$rv,bl=" . length($buf) . "]\n" + if ($debug & 4); + return $rv unless $rv > 0; + $n += $rv; + } + + # call mechanism specific decoding routine + $self->{readbuf} = $self->{conn}->decode($buf, $bsz); + $n = length($self->{readbuf}); + print STDERR " [getbuf: clear text buffer sz=$n]\n" if ($debug & 4); + $self->{readbuflen} = $n; + } + + + # Encrypting a write() to a filehandle is much easier than reading, because + # all the data to be encrypted is immediately available + sub WRITE { + my ($self, undef, $len, $offset) = @_; + my $debug = $self->{conn}->{debug}; + + my $fh = $self->{fh}; + + # put on wire in peer-sized chunks + my $bsz = $self->{sndbufsz}; + while ($len > 0) { + print STDERR " [WRITE: chunk $bsz/$len]\n" + if ($debug & 8); + + # call mechanism specific encoding routine + my $x = $self->{conn}->encode(substr($_[1], $offset || 0, $bsz)); + print $fh pack('N', length($x)), $x; + $len -= $bsz; + $offset += $bsz; + } + + return $_[2]; + } + +} + +1; diff --git a/lib/Authen/SASL/Perl.pod b/lib/Authen/SASL/Perl.pod new file mode 100644 index 0000000..bb0b451 --- /dev/null +++ b/lib/Authen/SASL/Perl.pod @@ -0,0 +1,154 @@ +# Copyright (c) 2004 Peter Marschall . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +=head1 NAME + +Authen::SASL::Perl -- Perl implementation of the SASL Authentication framework + +=head1 SYNOPSIS + + use Authen::SASL qw(Perl); + + $sasl = Authen::SASL->new( + mechanism => 'CRAM-MD5 PLAIN ANONYMOUS', + callback => { + user => $user, + pass => \&fetch_password + } + ); + +=head1 DESCRIPTION + +B is the pure Perl implementation of SASL mechanisms +in the B framework. + +At the time of this writing it provides the client part implementation +for the following SASL mechanisms: + +=over 4 + +=item ANONYMOUS + +The Anonymous SASL Mechanism as defined in RFC 2245 resp. +in IETF Draft draft-ietf-sasl-anon-03.txt from February 2004 +provides a method to anonymously access internet services. + +Since it does no authentication it does not need to send +any confidential information such as passwords in plain text +over the network. + + +=item CRAM-MD5 + +The CRAM-MD5 SASL Mechanism as defined in RFC2195 resp. +in IETF Draft draft-ietf-sasl-crammd5-XX.txt +offers a simple challenge-response authentication mechanism. + +Since it is a challenge-response authentication mechanism +no passwords are transferred in clear-text over the wire. + +Due to the simplicity of the protocol CRAM-MD5 is susceptible +to replay and dictionary attacks, so DIGEST-MD5 should be used +in preferrence. + + +=item DIGEST-MD5 + +The DIGEST-MD5 SASL Mechanism as defined in RFC 2831 resp. +in IETF Draft draft-ietf-sasl-rfc2831bis-XX.txt +offers the HTTP Digest Access Authentication as SASL mechanism. + +Like CRAM-MD5 it is a challenge-response authentication +method that does not send plain text passwords over the network. + +Compared to CRAM-MD5, DIGEST-MD5 prevents chosen plaintext +attacks, and permits the use of third party authentication servers, +so that it is recommended to use DIGEST-MD5 instead of CRAM-MD5 +when possible. + + +=item EXTERNAL + +The EXTERNAL SASL mechanism as defined in RFC 2222 +allows the use of external authentication systems as SASL mechanisms. + + +=item GSSAPI + +The GSSAPI SASL mechanism as defined in RFC 2222 resp. IETF Draft +draft-ietf-sasl-gssapi-XX.txt allows using the Generic Security Service +Application Program Interface [GSSAPI] KERBEROS V5 as as SASL mechanism. + +Although GSSAPI is a general mechanism for authentication it is almost +exlusively used for Kerberos 5. + + +=item LOGIN + +The LOGIN SASL Mechanism as defined in IETF Draft +draft-murchison-sasl-login-XX.txt allows the +combination of username and clear-text password to be used +in a SASL mechanism. + +It does does not provide a security layer and sends the credentials +in clear over the wire. +Thus this mechanism should not be used without adequate security +protection. + + +=item PLAIN + +The Plain SASL Mechanism as defined in RFC 2595 resp. IETF Draft +draft-ietf-sasl-plain-XX.txt is another SASL mechanism that allows +username and clear-text password combinations in SASL environments. + +Like LOGIN it sends the credentials in clear over the network +and should not be used without sufficient security protection. + +=back + +As for server support, only I, I and I are supported +at the time of this writing. + +C OPTIONS is a hashref that is only relevant for I for +now and it supports the following options: + +=over 4 + +=item - no_integrity + +=item - no_confidentiality + +=back + +which configures how the security layers are negotiated with the client (or +rather imposed to the client). + + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L, +L, +L + +=head1 AUTHOR + +Peter Marschall + +Please report any bugs, or post any suggestions, to the perl-ldap mailing list + + +=head1 COPYRIGHT + +Copyright (c) 2004-2006 Peter Marschall. +All rights reserved. This document is distributed, and may be redistributed, +under the same terms as Perl itself. + +=cut + diff --git a/lib/Authen/SASL/Perl/ANONYMOUS.pm b/lib/Authen/SASL/Perl/ANONYMOUS.pm new file mode 100644 index 0000000..7bb8c00 --- /dev/null +++ b/lib/Authen/SASL/Perl/ANONYMOUS.pm @@ -0,0 +1,93 @@ +# Copyright (c) 2002 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Authen::SASL::Perl::ANONYMOUS; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = "2.14"; +@ISA = qw(Authen::SASL::Perl); + +my %secflags = ( + noplaintext => 1, +); + +sub _order { 0 } +sub _secflags { + shift; + grep { $secflags{$_} } @_; +} + +sub mechanism { 'ANONYMOUS' } + +sub client_start { + shift->_call('authname') +} + +sub client_step { + shift->_call('authname') +} + +1; + +__END__ + +=head1 NAME + +Authen::SASL::Perl::ANONYMOUS - Anonymous Authentication class + +=head1 SYNOPSIS + + use Authen::SASL qw(Perl); + + $sasl = Authen::SASL->new( + mechanism => 'ANONYMOUS', + callback => { + authname => $mailaddress + }, + ); + +=head1 DESCRIPTION + +This method implements the client part of the ANONYMOUS SASL algorithm, +as described in RFC 2245 resp. in IETF Draft draft-ietf-sasl-anon-XX.txt. + +=head2 CALLBACK + +The callbacks used are: + +=over 4 + +=item authname + +email address or UTF-8 encoded string to be used as +trace information for the server + +=back + +=head1 SEE ALSO + +L, +L + +=head1 AUTHORS + +Software written by Graham Barr , +documentation written by Peter Marschall . + +Please report any bugs, or post any suggestions, to the perl-ldap mailing list + + +=head1 COPYRIGHT + +Copyright (c) 2002-2004 Graham Barr. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +Documentation Copyright (c) 2004 Peter Marschall. +All rights reserved. This documentation is distributed, +and may be redistributed, under the same terms as Perl itself. + +=cut diff --git a/lib/Authen/SASL/Perl/CRAM_MD5.pm b/lib/Authen/SASL/Perl/CRAM_MD5.pm new file mode 100644 index 0000000..84db3a0 --- /dev/null +++ b/lib/Authen/SASL/Perl/CRAM_MD5.pm @@ -0,0 +1,105 @@ +# Copyright (c) 2002 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Authen::SASL::Perl::CRAM_MD5; + +use strict; +use vars qw($VERSION @ISA); +use Digest::HMAC_MD5 qw(hmac_md5_hex); + +$VERSION = "2.14"; +@ISA = qw(Authen::SASL::Perl); + +my %secflags = ( + noplaintext => 1, + noanonymous => 1, +); + +sub _order { 2 } +sub _secflags { + shift; + scalar grep { $secflags{$_} } @_; +} + +sub mechanism { 'CRAM-MD5' } + +sub client_start { + ''; +} + +sub client_step { + my ($self, $string) = @_; + my ($user, $pass) = map { + my $v = $self->_call($_); + defined($v) ? $v : '' + } qw(user pass); + + $user . " " . hmac_md5_hex($string,$pass); +} + +1; + +__END__ + +=head1 NAME + +Authen::SASL::Perl::CRAM_MD5 - CRAM MD5 Authentication class + +=head1 SYNOPSIS + + use Authen::SASL qw(Perl); + + $sasl = Authen::SASL->new( + mechanism => 'CRAM-MD5', + callback => { + user => $user, + pass => $pass + }, + ); + +=head1 DESCRIPTION + +This method implements the client part of the CRAM-MD5 SASL algorithm, +as described in RFC 2195 resp. in IETF Draft draft-ietf-sasl-crammd5-XX.txt. + +=head2 CALLBACK + +The callbacks used are: + +=over 4 + +=item user + +The username to be used for authentication + +=item pass + +The user's password to be used for authentication + +=back + +=head1 SEE ALSO + +L, +L + +=head1 AUTHORS + +Software written by Graham Barr , +documentation written by Peter Marschall . + +Please report any bugs, or post any suggestions, to the perl-ldap mailing list + + +=head1 COPYRIGHT + +Copyright (c) 2002-2004 Graham Barr. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +Documentation Copyright (c) 2004 Peter Marschall. +All rights reserved. This documentation is distributed, +and may be redistributed, under the same terms as Perl itself. + +=cut diff --git a/lib/Authen/SASL/Perl/DIGEST_MD5.pm b/lib/Authen/SASL/Perl/DIGEST_MD5.pm new file mode 100644 index 0000000..ca25b6e --- /dev/null +++ b/lib/Authen/SASL/Perl/DIGEST_MD5.pm @@ -0,0 +1,877 @@ +# Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian +# Onions, Nexor and Yann Kerherve. +# All rights reserved. This program is free software; you can redistribute +# it and/or modify it under the same terms as Perl itself. + +# See http://www.ietf.org/rfc/rfc2831.txt for details + +package Authen::SASL::Perl::DIGEST_MD5; + +use strict; +use vars qw($VERSION @ISA $CNONCE $NONCE); +use Digest::MD5 qw(md5_hex md5); +use Digest::HMAC_MD5 qw(hmac_md5); + +# TODO: complete qop support in server, should be configurable + +$VERSION = "2.14"; +@ISA = qw(Authen::SASL::Perl); + +my %secflags = ( + noplaintext => 1, + noanonymous => 1, +); + +# some have to be quoted - some don't - sigh! +my (%cqdval, %sqdval); +@cqdval{qw( + username authzid realm nonce cnonce digest-uri +)} = (); + +## ...and server behaves different than client - double sigh! +@sqdval{keys %cqdval, qw(qop cipher)} = (); +# username authzid realm nonce cnonce digest-uri qop cipher +#)} = (); + +my %multi; +@{$multi{server}}{qw(realm auth-param)} = (); +@{$multi{client}}{qw()} = (); + +my @server_required = qw(algorithm nonce); +my @client_required = qw(username nonce cnonce nc qop response); + +# available ciphers +my @ourciphers = ( + { + name => 'rc4', + ssf => 128, + bs => 1, + ks => 16, + pkg => 'Crypt::RC4', + key => sub { $_[0] }, + iv => sub {}, + fixup => sub { + # retrofit the Crypt::RC4 module with standard subs + *Crypt::RC4::encrypt = *Crypt::RC4::decrypt = + sub { goto &Crypt::RC4::RC4; }; + *Crypt::RC4::keysize = sub {128}; + *Crypt::RC4::blocksize = sub {1}; + } + }, + { + name => '3des', + ssf => 112, + bs => 8, + ks => 16, + pkg => 'Crypt::DES3', + key => sub { + pack('B8' x 16, + map { $_ . '0' } + map { unpack('a7' x 16, $_); } + unpack('B*', substr($_[0], 0, 14)) ); + }, + iv => sub { substr($_[0], -8, 8) }, + }, + { + name => 'des', + ssf => 56, + bs => 8, + ks => 16, + pkg => 'Crypt::DES', + key => sub { + pack('B8' x 8, + map { $_ . '0' } + map { unpack('a7' x 8, $_); } + unpack('B*',substr($_[0], 0, 7)) ); + }, + iv => sub { substr($_[0], -8, 8) }, + }, + { + name => 'rc4-56', + ssf => 56, + bs => 1, + ks => 7, + pkg => 'Crypt::RC4', + key => sub { $_[0] }, + iv => sub {}, + fixup => sub { + *Crypt::RC4::encrypt = *Crypt::RC4::decrypt = + sub { goto &Crypt::RC4::RC4; }; + *Crypt::RC4::keysize = sub {56}; + *Crypt::RC4::blocksize = sub {1}; + } + }, + { + name => 'rc4-40', + ssf => 40, + bs => 1, + ks => 5, + pkg => 'Crypt::RC4', + key => sub { $_[0] }, + iv => sub {}, + fixup => sub { + *Crypt::RC4::encrypt = *Crypt::RC4::decrypt = + sub { goto &Crypt::RC4::RC4; }; + *Crypt::RC4::keysize = sub {40}; + *Crypt::RC4::blocksize = sub {1}; + } + }, +); + +## The system we are on, might not be able to crypt the stream +our $NO_CRYPT_AVAILABLE = 1; +for (@ourciphers) { + eval "require $_->{pkg}"; + unless ($@) { + $NO_CRYPT_AVAILABLE = 0; + last; + } +} + +sub _order { 3 } +sub _secflags { + shift; + scalar grep { $secflags{$_} } @_; +} + +sub mechanism { 'DIGEST-MD5' } + +sub _init { + my ($pkg, $self) = @_; + bless $self, $pkg; + + # set default security properties + $self->property('minssf', 0); + $self->property('maxssf', int 2**31 - 1); # XXX - arbitrary "high" value + $self->property('maxbuf', 0xFFFFFF); # maximum supported by GSSAPI mech + $self->property('externalssf', 0); + + $self; +} + +sub _init_server { + my $server = shift; + my $options = shift || {}; + if (!ref $options or ref $options ne 'HASH') { + warn "options for DIGEST_MD5 should be a hashref"; + $options = {}; + } + + ## new server, means new nonce_counts + $server->{nonce_counts} = {}; + + ## determine supported qop + my @qop = ('auth'); + push @qop, 'auth-int' unless $options->{no_integrity}; + push @qop, 'auth-conf' unless $options->{no_integrity} + or $options->{no_confidentiality} + or $NO_CRYPT_AVAILABLE; + + $server->{supported_qop} = { map { $_ => 1 } @qop }; +} + +sub init_sec_layer { + my $self = shift; + $self->{cipher} = undef; + $self->{khc} = undef; + $self->{khs} = undef; + $self->{sndseqnum} = 0; + $self->{rcvseqnum} = 0; + + # reset properties for new session + $self->property(maxout => undef); + $self->property(ssf => undef); +} + +# no initial value passed to the server +sub client_start { + my $self = shift; + + $self->{need_step} = 1; + $self->{error} = undef; + $self->{state} = 0; + $self->init_sec_layer; + ''; +} + +sub server_start { + my $self = shift; + my $challenge = shift; + my $cb = shift || sub {}; + + $self->{need_step} = 1; + $self->{error} = undef; + $self->{nonce} = md5_hex($NONCE || join (":", $$, time, rand)); + + $self->init_sec_layer; + + my $qop = [ sort keys %{$self->{supported_qop}} ]; + + ## get the realm using callbacks but default to the host specified + ## during the instanciation of the SASL object + my $realm = $self->_call('realm'); + $realm ||= $self->host; + + my %response = ( + nonce => $self->{nonce}, + charset => 'utf-8', + algorithm => 'md5-sess', + realm => $realm, + maxbuf => $self->property('maxbuf'), + +## IN DRAFT ONLY: +# If this directive is present multiple times the client MUST treat +# it as if it received a single qop directive containing a comma +# separated value from all instances. I.e., +# 'qop="auth",qop="auth-int"' is the same as 'qop="auth,auth-int" + + 'qop' => $qop, + 'cipher' => [ map { $_->{name} } @ourciphers ], + ); + my $final_response = _response(\%response); + $cb->($final_response); + return; +} + +sub client_step { # $self, $server_sasl_credentials + my ($self, $challenge) = @_; + $self->{server_params} = \my %sparams; + + # Parse response parameters + $self->_parse_challenge(\$challenge, server => $self->{server_params}) + or return $self->set_error("Bad challenge: '$challenge'"); + + if ($self->{state} == 1) { + # check server's `rspauth' response + return $self->set_error("Server did not send rspauth in step 2") + unless ($sparams{rspauth}); + return $self->set_error("Invalid rspauth in step 2") + unless ($self->{rspauth} eq $sparams{rspauth}); + + # all is well + $self->set_success; + return ''; + } + + # check required fields in server challenge + if (my @missing = grep { !exists $sparams{$_} } @server_required) { + return $self->set_error("Server did not provide required field(s): @missing") + } + + my %response = ( + nonce => $sparams{'nonce'}, + cnonce => md5_hex($CNONCE || join (":", $$, time, rand)), + 'digest-uri' => $self->service . '/' . $self->host, + # calc how often the server nonce has been seen; server expects "00000001" + nc => sprintf("%08d", ++$self->{nonce_counts}{$sparams{'nonce'}}), + charset => $sparams{'charset'}, + ); + + return $self->set_error("Server qop too weak (qop = $sparams{'qop'})") + unless ($self->_client_layer(\%sparams,\%response)); + + # let caller-provided fields override defaults: authorization ID, service name, realm + + my $s_realm = $sparams{realm} || []; + my $realm = $self->_call('realm', @$s_realm); + unless (defined $realm) { + # If the user does not pick a realm, use the first from the server + $realm = $s_realm->[0]; + } + if (defined $realm) { + $response{realm} = $realm; + } + + my $authzid = $self->_call('authname'); + if (defined $authzid) { + $response{authzid} = $authzid; + } + + my $serv_name = $self->_call('serv'); + if (defined $serv_name) { + $response{'digest-uri'} .= '/' . $serv_name; + } + + my $user = $self->_call('user'); + return $self->set_error("Username is required") + unless defined $user; + $response{username} = $user; + + my $password = $self->_call('pass'); + return $self->set_error("Password is required") + unless defined $password; + + $self->property('maxout', $sparams{maxbuf} || 65536); + + # Generate the response value + $self->{state} = 1; + + my ($response, $rspauth) + = $self->_compute_digests_and_set_keys($password, \%response); + + $response{response} = $response; + $self->{rspauth} = $rspauth; + + # finally, return our response token + return _response(\%response, "is_client"); +} + +sub _compute_digests_and_set_keys { + my $self = shift; + my $password = shift; + my $params = shift; + + if (defined $params->{realm} and ref $params->{realm} eq 'ARRAY') { + $params->{realm} = $params->{realm}[0]; + } + + my $realm = $params->{realm}; + $realm = "" unless defined $realm; + + my $A1 = join (":", + md5(join (":", $params->{username}, $realm, $password)), + @$params{defined($params->{authzid}) + ? qw(nonce cnonce authzid) + : qw(nonce cnonce) + } + ); + + # pre-compute MD5(A1) and HEX(MD5(A1)); these are used multiple times below + my $hdA1 = unpack("H*", (my $dA1 = md5($A1)) ); + + # derive keys for layer encryption / integrity + $self->{kic} = md5($dA1, + 'Digest session key to client-to-server signing key magic constant'); + + $self->{kis} = md5($dA1, + 'Digest session key to server-to-client signing key magic constant'); + + if (my $cipher = $self->{cipher}) { + &{ $cipher->{fixup} || sub{} }; + + # compute keys for encryption + my $ks = $cipher->{ks}; + $self->{kcc} = md5(substr($dA1,0,$ks), + 'Digest H(A1) to client-to-server sealing key magic constant'); + $self->{kcs} = md5(substr($dA1,0,$ks), + 'Digest H(A1) to server-to-client sealing key magic constant'); + + # get an encryption and decryption handle for the chosen cipher + $self->{khc} = $cipher->{pkg}->new($cipher->{key}->($self->{kcc})); + $self->{khs} = $cipher->{pkg}->new($cipher->{key}->($self->{kcs})); + + # initialize IVs + $self->{ivc} = $cipher->{iv}->($self->{kcc}); + $self->{ivs} = $cipher->{iv}->($self->{kcs}); + } + + my $A2 = "AUTHENTICATE:" . $params->{'digest-uri'}; + $A2 .= ":00000000000000000000000000000000" if ($params->{qop} ne 'auth'); + + my $response = md5_hex( + join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2)) + ); + + # calculate server `rspauth' response, so we can check in step 2 + # the only difference here is in the A2 string which from which + # `AUTHENTICATE' is omitted in the calculation of `rspauth' + $A2 = ":" . $params->{'digest-uri'}; + $A2 .= ":00000000000000000000000000000000" if ($params->{qop} ne 'auth'); + + my $rspauth = md5_hex( + join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2)) + ); + + return ($response, $rspauth); +} + +sub server_step { + my $self = shift; + my $challenge = shift; + my $cb = shift || sub {}; + + $self->{client_params} = \my %cparams; + unless ( $self->_parse_challenge(\$challenge, client => $self->{client_params}) ) { + $self->set_error("Bad challenge: '$challenge'"); + return $cb->(); + } + + # check required fields in server challenge + if (my @missing = grep { !exists $cparams{$_} } @client_required) { + $self->set_error("Client did not provide required field(s): @missing"); + return $cb->(); + } + + my $count = hex ($cparams{'nc'} || 0); + unless ($count == ++$self->{nonce_counts}{$cparams{nonce}}) { + $self->set_error("nonce-count doesn't match: $count"); + return $cb->(); + } + + my $qop = $cparams{'qop'} || "auth"; + unless ($self->is_qop_supported($qop)) { + $self->set_error("Client qop not supported (qop = '$qop')"); + return $cb->(); + } + + my $username = $cparams{'username'}; + unless ($username) { + $self->set_error("Client didn't provide a username"); + return $cb->(); + } + + # "The authzid MUST NOT be an empty string." + if (exists $cparams{authzid} && $cparams{authzid} eq '') { + $self->set_error("authzid cannot be empty"); + return $cb->(); + } + my $authzid = $cparams{authzid}; + + # digest-uri: "Servers SHOULD check that the supplied value is correct. + # This will detect accidental connection to the incorrect server, as well as + # some redirection attacks" + my $digest_uri = $cparams{'digest-uri'}; + my ($cservice, $chost, $cservname) = split '/', $digest_uri, 3; + if ($cservice ne $self->service or $chost ne $self->host) { + # XXX deal with serv_name + $self->set_error("Incorrect digest-uri"); + return $cb->(); + } + + unless (defined $self->callback('getsecret')) { + $self->set_error("a getsecret callback MUST be defined"); + $cb->(); + return; + } + + my $realm = $self->{client_params}->{'realm'}; + my $response_check = sub { + my $password = shift; + return $self->set_error("Cannot get the passord for $username") + unless defined $password; + + ## configure the security layer + $self->_server_layer($qop) + or return $self->set_error("Cannot negociate the security layer"); + + my ($expected, $rspauth) + = $self->_compute_digests_and_set_keys($password, $self->{client_params}); + + return $self->set_error("Incorrect response $self->{client_params}->{response} <> $expected") + unless $expected eq $self->{client_params}->{response}; + + my %response = ( + rspauth => $rspauth, + ); + + # I'm not entirely sure of what I am doing + $self->{answer}{$_} = $self->{client_params}->{$_} for qw/username authzid realm serv/; + + $self->set_success; + return _response(\%response); + }; + + $self->callback('getsecret')->( + $self, + { user => $username, realm => $realm, authzid => $authzid }, + sub { $cb->( $response_check->( shift ) ) }, + ); +} + +sub is_qop_supported { + my $self = shift; + my $qop = shift; + return $self->{supported_qop}{$qop}; +} + +sub _response { + my $response = shift; + my $is_client = shift; + + my @out; + for my $k (sort keys %$response) { + my $is_array = ref $response->{$k} && ref $response->{$k} eq 'ARRAY'; + my @values = $is_array ? @{$response->{$k}} : ($response->{$k}); + # Per spec, one way of doing it: multiple k=v + #push @out, [$k, $_] for @values; + # other way: comma separated list + push @out, [$k, join (',', @values)]; + } + return join (",", map { _qdval($_->[0], $_->[1], $is_client) } @out); +} + +sub _parse_challenge { + my $self = shift; + my $challenge_ref = shift; + my $type = shift; + my $params = shift; + + while($$challenge_ref =~ + s/^(?:\s*,)*\s* # remaining or crap + ([\w-]+) # key, eg: qop + = + ("([^\\"]+|\\.)*"|[^,]+) # value, eg: auth-conf or "NoNcE" + \s*(?:,\s*)* # remaining + //x) { + + my ($k, $v) = ($1,$2); + if ($v =~ /^"(.*)"$/s) { + ($v = $1) =~ s/\\(.)/$1/g; + } + if (exists $multi{$type}{$k}) { + my $aref = $params->{$k} ||= []; + push @$aref, $v; + } + elsif (defined $params->{$k}) { + return $self->set_error("Bad challenge: '$$challenge_ref'"); + } + else { + $params->{$k} = $v; + } + } + return length $$challenge_ref ? 0 : 1; +} + +sub _qdval { + my ($k, $v, $is_client) = @_; + + my $qdval = $is_client ? \%cqdval : \%sqdval; + + if (!defined $v) { + return; + } + elsif (exists $qdval->{$k}) { + $v =~ s/([\\"])/\\$1/g; + return qq{$k="$v"}; + } + + return "$k=$v"; +} + +sub _server_layer { + my ($self, $auth) = @_; + + # XXX dupe + # construct our qop mask + my $maxssf = $self->property('maxssf') - $self->property('externalssf'); + $maxssf = 0 if ($maxssf < 0); + my $minssf = $self->property('minssf') - $self->property('externalssf'); + $minssf = 0 if ($minssf < 0); + + return undef if ($maxssf < $minssf); # sanity check + + my $ciphers = [ map { $_->{name} } @ourciphers ]; + if (( $auth eq 'auth-conf') + and $self->_select_cipher($minssf, $maxssf, $ciphers )) { + $self->property('ssf', $self->{cipher}->{ssf}); + return 1; + } + if ($auth eq 'auth-int') { + $self->property('ssf', 1); + return 1; + } + if ($auth eq 'auth') { + $self->property('ssf', 0); + return 1; + } + + return undef; +} + +sub _client_layer { + my ($self, $sparams, $response) = @_; + + # construct server qop mask + # qop in server challenge is optional: if not there "auth" is assumed + my $smask = 0; + map { + m/^auth$/ and $smask |= 1; + m/^auth-int$/ and $smask |= 2; + m/^auth-conf$/ and $smask |= 4; + } split(/,/, $sparams->{qop}||'auth'); # XXX I think we might have a bug here bc. of LWS + + # construct our qop mask + my $cmask = 0; + my $maxssf = $self->property('maxssf') - $self->property('externalssf'); + $maxssf = 0 if ($maxssf < 0); + my $minssf = $self->property('minssf') - $self->property('externalssf'); + $minssf = 0 if ($minssf < 0); + + return undef if ($maxssf < $minssf); # sanity check + + # ssf values > 1 mean integrity and confidentiality + # ssf == 1 means integrity but no confidentiality + # ssf < 1 means neither integrity nor confidentiality + # no security layer can be had if buffer size is 0 + $cmask |= 1 if ($minssf < 1); + $cmask |= 2 if ($minssf <= 1 and $maxssf >= 1); + $cmask |= 4 if ($maxssf > 1); + + # find common bits + $cmask &= $smask; + + # parse server cipher options + my @sciphers = split(/,/, $sparams->{'cipher-opts'}||$sparams->{cipher}||''); + + if (($cmask & 4) and $self->_select_cipher($minssf,$maxssf,\@sciphers)) { + $response->{qop} = 'auth-conf'; + $response->{cipher} = $self->{cipher}->{name}; + $self->property('ssf', $self->{cipher}->{ssf}); + return 1; + } + if ($cmask & 2) { + $response->{qop} = 'auth-int'; + $self->property('ssf', 1); + return 1; + } + if ($cmask & 1) { + $response->{qop} = 'auth'; + $self->property('ssf', 0); + return 1; + } + + return undef; +} + +sub _select_cipher { + my ($self, $minssf, $maxssf, $ciphers) = @_; + + # compose a subset of candidate ciphers based on ssf and peer list + my @a = map { + my $c = $_; + (grep { $c->{name} eq $_ } @$ciphers and + $c->{ssf} >= $minssf and $c->{ssf} <= $maxssf) ? $_ : () + } @ourciphers; + + # from these, select the first one we can create an instance of + for (@a) { + next unless eval "require $_->{pkg}"; + $self->{cipher} = $_; + return 1; + } + + return 0; +} + +use Digest::HMAC_MD5 qw(hmac_md5); + +sub encode { # input: self, plaintext buffer,length (length not used here) + my $self = shift; + my $seqnum = pack('N', $self->{sndseqnum}++); + my $mac = substr(hmac_md5($seqnum . $_[0], $self->{kic}), 0, 10); + + # if integrity only, return concatenation of buffer, MAC, TYPE and SEQNUM + return $_[0] . $mac.pack('n',1) . $seqnum unless ($self->{khc}); + + # must encrypt, block ciphers need padding bytes + my $pad = ''; + my $bs = $self->{cipher}->{bs}; + if ($bs > 1) { + # padding is added in between BUF and MAC + my $n = $bs - ((length($_[0]) + 10) & ($bs - 1)); + $pad = chr($n) x $n; + } + + # XXX - for future AES cipher support, the currently used common _crypt() + # function probably wont do; we might to switch to per-cipher routines + # like so: + # return $self->{khc}->encrypt($_[0] . $pad . $mac) . pack('n', 1) . $seqnum; + return $self->_crypt(0, $_[0] . $pad . $mac) . pack('n', 1) . $seqnum; +} + +sub decode { # input: self, cipher buffer,length + my ($self, $buf, $len) = @_; + + return if ($len <= 16); + + # extract TYPE/SEQNUM from end of buffer + my ($type,$seqnum) = unpack('na[4]', substr($buf, -6, 6, '')); + + # decrypt remaining buffer, if necessary + if ($self->{khs}) { + # XXX - see remark above in encode() #$buf = $self->{khs}->decrypt($buf); + $buf = $self->_crypt(1, $buf); + } + return unless ($buf); + + # extract 10-byte MAC from the end of (decrypted) buffer + my ($mac) = unpack('a[10]', substr($buf, -10, 10, '')); + + if ($self->{khs} and $self->{cipher}->{bs} > 1) { + # remove padding + my $n = ord(substr($buf, -1, 1)); + substr($buf, -$n, $n, ''); + } + + # check the MAC + my $check = substr(hmac_md5($seqnum . $buf, $self->{kis}), 0, 10); + return if ($mac ne $check); + return if (unpack('N', $seqnum) != $self->{rcvseqnum}); + $self->{rcvseqnum}++; + + return $buf; +} + +sub _crypt { # input: op(decrypting=1/encrypting=0)), buffer + my ($self,$d) = (shift,shift); + my $bs = $self->{cipher}->{bs}; + + if ($bs <= 1) { + # stream cipher + return $d ? $self->{khs}->decrypt($_[0]) : $self->{khc}->encrypt($_[0]) + } + + # the remainder of this sub is for block ciphers + + # get current IV + my $piv = \$self->{$d ? 'ivs' : 'ivc'}; + my $iv = $$piv; + + my $result = join '', map { + my $x = $d + ? $iv ^ $self->{khs}->decrypt($_) + : $self->{khc}->encrypt($iv ^ $_); + $iv = $d ? $_ : $x; + $x; + } unpack("a$bs "x(int(length($_[0])/$bs)), $_[0]); + + # store current IV + $$piv = $iv; + return $result; +} + +1; + +__END__ + +=head1 NAME + +Authen::SASL::Perl::DIGEST_MD5 - Digest MD5 Authentication class + +=head1 SYNOPSIS + + use Authen::SASL qw(Perl); + + $sasl = Authen::SASL->new( + mechanism => 'DIGEST-MD5', + callback => { + user => $user, + pass => $pass, + serv => $serv + }, + ); + +=head1 DESCRIPTION + +This method implements the client and server parts of the DIGEST-MD5 SASL +algorithm, as described in RFC 2831. + +=head2 CALLBACK + +The callbacks used are: + +=head3 client + +=over 4 + +=item authname + +The authorization id to use after successful authentication + +=item user + +The username to be used in the response + +=item pass + +The password to be used to compute the response. + +=item serv + +The service name when authenticating to a replicated service + +=item realm + +The authentication realm when overriding the server-provided default. +If not given the server-provided value is used. + +The callback will be passed the list of realms that the server provided +in the initial response. + +=back + +=head3 server + +=over4 + +=item realm + +The default realm to provide to the client + +=item getsecret(username, realm, authzid) + +returns the password associated with C and C + +=back + +=head2 PROPERTIES + +The properties used are: + +=over 4 + +=item maxbuf + +The maximum buffer size for receiving cipher text + +=item minssf + +The minimum SSF value that should be provided by the SASL security layer. +The default is 0 + +=item maxssf + +The maximum SSF value that should be provided by the SASL security layer. +The default is 2**31 + +=item externalssf + +The SSF value provided by an underlying external security layer. +The default is 0 + +=item ssf + +The actual SSF value provided by the SASL security layer after the SASL +authentication phase has been completed. This value is read-only and set +by the implementation after the SASL authentication phase has been completed. + +=item maxout + +The maximum plaintext buffer size for sending data to the peer. +This value is set by the implementation after the SASL authentication +phase has been completed and a SASL security layer is in effect. + +=back + + +=head1 SEE ALSO + +L, +L + +=head1 AUTHORS + +Graham Barr, Djamel Boudjerda (NEXOR), Paul Connolly, Julian Onions (NEXOR), +Yann Kerherve. + +Please report any bugs, or post any suggestions, to the perl-ldap mailing list + + +=head1 COPYRIGHT + +Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly, +Julian Onions, Nexor, Peter Marschall and Yann Kerherve. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +=cut diff --git a/lib/Authen/SASL/Perl/EXTERNAL.pm b/lib/Authen/SASL/Perl/EXTERNAL.pm new file mode 100644 index 0000000..1eeafbe --- /dev/null +++ b/lib/Authen/SASL/Perl/EXTERNAL.pm @@ -0,0 +1,97 @@ +# Copyright (c) 1998-2002 Graham Barr and 2001 Chris Ridd +# . All rights reserved. This program +# is free software; you can redistribute it and/or modify it under the +# same terms as Perl itself. + +package Authen::SASL::Perl::EXTERNAL; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = "2.14"; +@ISA = qw(Authen::SASL::Perl); + +my %secflags = ( + noplaintext => 1, + nodictionary => 1, + noanonymous => 1, +); + +sub _order { 2 } +sub _secflags { + shift; + grep { $secflags{$_} } @_; +} + +sub mechanism { 'EXTERNAL' } + +sub client_start { + my $self = shift; + my $v = $self->_call('user'); + defined($v) ? $v : '' +} + +#sub client_step { +# shift->_call('user'); +#} + +1; + +__END__ + +=head1 NAME + +Authen::SASL::Perl::EXTERNAL - External Authentication class + +=head1 SYNOPSIS + + use Authen::SASL qw(Perl); + + $sasl = Authen::SASL->new( + mechanism => 'EXTERNAL', + callback => { + user => $user + }, + ); + +=head1 DESCRIPTION + +This method implements the client part of the EXTERNAL SASL algorithm, +as described in RFC 2222. + +=head2 CALLBACK + +The callbacks used are: + +=over 4 + +=item user + +The username to be used for authentication + +=back + +=head1 SEE ALSO + +L, +L + +=head1 AUTHORS + +Software written by Graham Barr , +documentation written by Peter Marschall . + +Please report any bugs, or post any suggestions, to the perl-ldap mailing list + + +=head1 COPYRIGHT + +Copyright (c) 1998-2004 Graham Barr. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +Documentation Copyright (c) 2004 Peter Marschall. +All rights reserved. This documentation is distributed, +and may be redistributed, under the same terms as Perl itself. + +=cut diff --git a/lib/Authen/SASL/Perl/GSSAPI.pm b/lib/Authen/SASL/Perl/GSSAPI.pm new file mode 100644 index 0000000..d2670fc --- /dev/null +++ b/lib/Authen/SASL/Perl/GSSAPI.pm @@ -0,0 +1,375 @@ +# Copyright (c) 2006 Simon Wilkinson +# All rights reserved. This program is free software; you can redistribute +# it and/or modify it under the same terms as Perl itself. + +package Authen::SASL::Perl::GSSAPI; + +use strict; + +use vars qw($VERSION @ISA); +use GSSAPI; + +$VERSION= "0.05"; +@ISA = qw(Authen::SASL::Perl); + +my %secflags = ( + noplaintext => 1, + noanonymous => 1, +); + +sub _order { 4 } +sub _secflags { + shift; + scalar grep { $secflags{$_} } @_; +} + +sub mechanism { 'GSSAPI' } + +sub _init { + my ($pkg, $self) = @_; + bless $self, $pkg; + + # set default security properties + $self->property('minssf', 0); + $self->property('maxssf', int 2**31 - 1); # XXX - arbitrary "high" value + $self->property('maxbuf', 0xFFFFFF); # maximum supported by GSSAPI mech + $self->property('externalssf', 0); + # the cyrus sasl library allows only one bit to be set in the + # layer selection mask in the client reply, we default to + # compatibility with that bug + $self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG', 1); + $self; +} + +sub client_start { + my $self = shift; + my $status; + my $principal = $self->service.'@'.$self->host; + + # GSSAPI::Name->import is the *constructor*, + # storing the new GSSAPI::Name into $target. + # GSSAPI::Name->import is not the standard + # import() method as used in Perl normally + my $target; + $status = GSSAPI::Name->import($target, $principal, gss_nt_service_name) + or return $self->set_error("GSSAPI Error : ".$status); + $self->{gss_name} = $target; + $self->{gss_ctx} = new GSSAPI::Context; + $self->{gss_state} = 0; + $self->{gss_layer} = undef; + my $cred = $self->_call('pass'); + $self->{gss_cred} = (ref($cred) && $cred->isa('GSSAPI::Cred')) ? $cred : GSS_C_NO_CREDENTIAL; + $self->{gss_mech} = $self->_call('gssmech') || gss_mech_krb5; + + # reset properties for new session + $self->property(maxout => undef); + $self->property(ssf => undef); + + return $self->client_step(''); +} + +sub client_step { + my ($self, $challenge) = @_; + my $debug = $self->{debug}; + + my $status; + + if ($self->{gss_state} == 0) { + my $outtok; + my $inflags = GSS_C_INTEG_FLAG | GSS_C_MUTUAL_FLAG;#todo:set according to ssf props + my $outflags; + $status = $self->{gss_ctx}->init($self->{gss_cred}, $self->{gss_name}, + $self->{gss_mech}, + $inflags, + 0, GSS_C_NO_CHANNEL_BINDINGS, $challenge, undef, + $outtok, $outflags, undef); + + print STDERR "state(0): ". + $status->generic_message.';'.$status->specific_message. + "; output token sz: ".length($outtok)."\n" + if ($debug & 1); + + if (GSSAPI::Status::GSS_ERROR($status->major)) { + return $self->set_error("GSSAPI Error (init): ".$status); + } + if ($status->major == GSS_S_COMPLETE) { + $self->{gss_state} = 1; + } + return $outtok; + } + elsif ($self->{gss_state} == 1) { + # If the server has an empty output token when it COMPLETEs, Cyrus SASL + # kindly sends us that empty token. We need to ignore it, which introduces + # another round into the process. + print STDERR " state(1): challenge is EMPTY\n" + if ($debug and $challenge eq ''); + return '' if ($challenge eq ''); + + my $unwrapped; + $status = $self->{gss_ctx}->unwrap($challenge, $unwrapped, undef, undef) + or return $self->set_error("GSSAPI Error (unwrap challenge): ".$status); + + return $self->set_error("GSSAPI Error : invalid security layer token") + if (length($unwrapped) != 4); + + # the security layers the server supports: bitmask of + # 1 = no security layer, + # 2 = integrity protection, + # 4 = confidelity protection + # which is encoded in the first octet of the response; + # the remote maximum buffer size is encoded in the next three octets + # + my $layer = ord(substr($unwrapped, 0, 1, chr(0))); + my ($rsz) = unpack('N',$unwrapped); + + # get local receive buffer size + my $lsz = $self->property('maxbuf'); + + # choose security layer + my $choice = $self->_layer($layer,$rsz,$lsz); + return $self->set_error("GSSAPI Error: security too weak") unless $choice; + + $self->{gss_layer} = $choice; + + if ($choice > 1) { + # determine maximum plain text message size for peer's cipher buffer + my $psz; + $status = $self->{gss_ctx}->wrap_size_limit($choice & 4, 0, $rsz, $psz) + or return $self->set_error("GSSAPI Error (wrap size): ".$status); + return $self->set_error("GSSAPI wrap size = 0") unless ($psz); + $self->property(maxout => $psz); + # set SSF property; if we have just integrity protection SSF is set + # to 1. If we have confidentiality, SSF would be an estimate of the + # strength of the actual encryption ciphers in use which is not + # available through the GSSAPI interface; for now just set it to + # the lowest value that signifies confidentiality. + $self->property(ssf => (($choice & 4) ? 2 : 1)); + } else { + # our advertised buffer size should be 0 if no layer selected + $lsz = 0; + $self->property(ssf => 0); + } + + print STDERR "state(1): layermask $layer,rsz $rsz,lsz $lsz,choice $choice\n" + if ($debug & 1); + + my $message = pack('CCCC', $choice, + ($lsz >> 16)&0xff, ($lsz >> 8)&0xff, $lsz&0xff); + + # append authorization identity if we have one + my $authz = $self->_call('authname'); + $message .= $authz if ($authz); + + my $outtok; + $status = $self->{gss_ctx}->wrap(0, 0, $message, undef, $outtok) + or return $self->set_error("GSSAPI Error (wrap token): ".$status); + + $self->{gss_state} = 0; + return $outtok; + } +} + +# default layer selection +sub _layer { + my ($self, $theirmask, $rsz, $lsz) = @_; + my $maxssf = $self->property('maxssf') - $self->property('externalssf'); + $maxssf = 0 if ($maxssf < 0); + + my $minssf = $self->property('minssf') - $self->property('externalssf'); + $minssf = 0 if ($minssf < 0); + + return undef if ($maxssf < $minssf); # sanity check + + # ssf values > 1 mean integrity and confidentiality + # ssf == 1 means integrity but no confidentiality + # ssf < 1 means neither integrity nor confidentiality + # no security layer can be had if buffer size is 0 + my $ourmask = 0; + $ourmask |= 1 if ($minssf < 1); + $ourmask |= 2 if ($minssf <= 1 and $maxssf >= 1); + $ourmask |= 4 if ($maxssf > 1); + $ourmask &= 1 unless ($rsz and $lsz); + + # mask the bits they dont have + $ourmask &= $theirmask; + + return $ourmask unless $self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG'); + + # in cyrus sasl bug compat mode, select the highest bit set + return 4 if ($ourmask & 4); + return 2 if ($ourmask & 2); + return 1 if ($ourmask & 1); + return undef; +} + +sub encode { # input: self, plaintext buffer,length (length not used here) + my $self = shift; + my $wrapped; + my $status = $self->{gss_ctx}->wrap($self->{gss_layer} & 4, 0, $_[0], undef, $wrapped); + $self->set_error("GSSAPI Error (encode): " . $status), return + unless ($status); + return $wrapped; +} + +sub decode { # input: self, cipher buffer,length (length not used here) + my $self = shift; + my $unwrapped; + my $status = $self->{gss_ctx}->unwrap($_[0], $unwrapped, undef, undef); + $self->set_error("GSSAPI Error (decode): " . $status), return + unless ($status); + return $unwrapped; +} + +__END__ + +=head1 NAME + +Authen::SASL::Perl::GSSAPI - GSSAPI (Kerberosv5) Authentication class + +=head1 SYNOPSIS + + use Authen::SASL qw(Perl); + + $sasl = Authen::SASL->new( mechanism => 'GSSAPI' ); + + $sasl = Authen::SASL->new( mechanism => 'GSSAPI', + callback => { pass => $mycred }); + + $sasl->client_start( $service, $host ); + +=head1 DESCRIPTION + +This method implements the client part of the GSSAPI SASL algorithm, +as described in RFC 2222 section 7.2.1 resp. draft-ietf-sasl-gssapi-XX.txt. + +With a valid Kerberos 5 credentials cache (aka TGT) it allows +to connect to I@I given as the first two parameters +to Authen::SASL's client_start() method. Alternatively, a GSSAPI::Cred +object can be passed in via the Authen::SASL callback hash using +the `pass' key. + +Please note that this module does not currently implement a SASL +security layer following authentication. Unless the connection is +protected by other means, such as TLS, it will be vulnerable to +man-in-the-middle attacks. If security layers are required, then the +L GSSAPI module should be used instead. + +=head2 CALLBACK + +The callbacks used are: + +=over 4 + +=item authname + +The authorization identity to be used in SASL exchange + +=item gssmech + +The GSS mechanism to be used in the connection + +=item pass + +The GSS credentials to be used in the connection (optional) + +=back + + +=head1 EXAMPLE + + #! /usr/bin/perl -w + + use strict; + + use Net::LDAP 0.33; + use Authen::SASL 2.10; + + # -------- Adjust to your environment -------- + my $adhost = 'theserver.bla.net'; + my $ldap_base = 'dc=bla,dc=net'; + my $ldap_filter = '(&(sAMAccountName=BLAAGROL))'; + + my $sasl = Authen::SASL->new(mechanism => 'GSSAPI'); + my $ldap; + + eval { + $ldap = Net::LDAP->new($adhost, + onerror => 'die') + or die "Cannot connect to LDAP host '$adhost': '$@'"; + $ldap->bind(sasl => $sasl); + }; + + if ($@) { + chomp $@; + die "\nBind error : $@", + "\nDetailed SASL error: ", $sasl->error, + "\nTerminated"; + } + + print "\nLDAP bind() succeeded, working in authenticated state"; + + my $mesg = $ldap->search(base => $ldap_base, + filter => $ldap_filter); + + # -------- evaluate $mesg + +=head2 PROPERTIES + +The properties used are: + +=over 4 + +=item maxbuf + +The maximum buffer size for receiving cipher text + +=item minssf + +The minimum SSF value that should be provided by the SASL security layer. +The default is 0 + +=item maxssf + +The maximum SSF value that should be provided by the SASL security layer. +The default is 2**31 + +=item externalssf + +The SSF value provided by an underlying external security layer. +The default is 0 + +=item ssf + +The actual SSF value provided by the SASL security layer after the SASL +authentication phase has been completed. This value is read-only and set +by the implementation after the SASL authentication phase has been completed. + +=item maxout + +The maximum plaintext buffer size for sending data to the peer. +This value is set by the implementation after the SASL authentication +phase has been completed and a SASL security layer is in effect. + +=back + + +=head1 SEE ALSO + +L, +L + +=head1 AUTHORS + +Written by Simon Wilkinson, with patches and extensions by Achim Grolms +and Peter Marschall. + +Please report any bugs, or post any suggestions, to the perl-ldap mailing list + + +=head1 COPYRIGHT + +Copyright (c) 2006 Simon Wilkinson, Achim Grolms and Peter Marschall. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +=cut diff --git a/lib/Authen/SASL/Perl/LOGIN.pm b/lib/Authen/SASL/Perl/LOGIN.pm new file mode 100644 index 0000000..f248b29 --- /dev/null +++ b/lib/Authen/SASL/Perl/LOGIN.pm @@ -0,0 +1,216 @@ +# Copyright (c) 2002 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Authen::SASL::Perl::LOGIN; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = "2.14"; +@ISA = qw(Authen::SASL::Perl); + +my %secflags = ( + noanonymous => 1, +); + +sub _order { 1 } +sub _secflags { + shift; + scalar grep { $secflags{$_} } @_; +} + +sub mechanism { 'LOGIN' } + +sub client_start { + my $self = shift; + $self->{stage} = 0; + ''; +} + +sub client_step { + my ($self, $string) = @_; + + # XXX technically this is wrong. I might want to change that. + # spec say it's "staged" and that the content of the challenge doesn't + # matter + # actually, let's try + my $stage = ++$self->{stage}; + if ($stage == 1) { + return $self->_call('user'); + } + elsif ($stage == 2) { + return $self->_call('pass'); + } + elsif ($stage == 3) { + $self->set_success; + return; + } + else { + return $self->set_error("Invalid sequence"); + } +} + +sub server_start { + my $self = shift; + my $response = shift; + my $user_cb = shift || sub {}; + + $self->{answer} = {}; + $self->{stage} = 0; + $self->{need_step} = 1; + $self->{error} = undef; + $user_cb->('Username:'); + return; +} + +sub server_step { + my $self = shift; + my $response = shift; + my $user_cb = shift || sub {}; + + my $stage = ++$self->{stage}; + + if ($stage == 1) { + unless (defined $response) { + $self->set_error("Invalid sequence (empty username)"); + return $user_cb->(); + } + $self->{answer}{user} = $response; + return $user_cb->("Password:"); + } + elsif ($stage == 2) { + unless (defined $response) { + $self->set_error("Invalid sequence (empty pass)"); + return $user_cb->(); + } + $self->{answer}{pass} = $response; + } + else { + $self->set_error("Invalid sequence (end)"); + return $user_cb->(); + } + my $error = "Credentials don't match"; + my $answers = { user => $self->{answer}{user}, pass => $self->{answer}{pass} }; + if (my $checkpass = $self->{callback}{checkpass}) { + my $cb = sub { + my $result = shift; + unless ($result) { + $self->set_error($error); + } + else { + $self->set_success; + } + $user_cb->(); + }; + $checkpass->($self => $answers => $cb ); + return; + } + elsif (my $getsecret = $self->{callback}{getsecret}) { + my $cb = sub { + my $good_pass = shift; + if ($good_pass && $good_pass eq ($self->{answer}{pass} || "")) { + $self->set_success; + } + else { + $self->set_error($error); + } + $user_cb->(); + }; + $getsecret->($self => $answers => $cb ); + return; + } + else { + $self->set_error($error); + $user_cb->(); + } + return; +} + +1; + +__END__ + +=head1 NAME + +Authen::SASL::Perl::LOGIN - Login Authentication class + +=head1 SYNOPSIS + + use Authen::SASL qw(Perl); + + $sasl = Authen::SASL->new( + mechanism => 'LOGIN', + callback => { + user => $user, + pass => $pass + }, + ); + +=head1 DESCRIPTION + +This method implements the client and server part of the LOGIN SASL algorithm, +as described in IETF Draft draft-murchison-sasl-login-XX.txt. + +=head2 CALLBACK + +The callbacks used are: + +=head3 Client + +=over 4 + +=item user + +The username to be used for authentication + +=item pass + +The user's password to be used for authentication + +=back + +=head3 Server + +=over4 + +=item getsecret(username) + +returns the password associated with C + +=item checkpass(username, password) + +returns true and false depending on the validity of the credentials passed +in arguments. + +=back + +=head1 SEE ALSO + +L, +L + +=head1 AUTHORS + +Software written by Graham Barr , +documentation written by Peter Marschall . +Server support by Yann Kerherve + +Please report any bugs, or post any suggestions, to the perl-ldap mailing list + + +=head1 COPYRIGHT + +Copyright (c) 2002-2004 Graham Barr. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +Documentation Copyright (c) 2004 Peter Marschall. +All rights reserved. This documentation is distributed, +and may be redistributed, under the same terms as Perl itself. + +Server support Copyright (c) 2009 Yann Kerherve. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +=cut diff --git a/lib/Authen/SASL/Perl/PLAIN.pm b/lib/Authen/SASL/Perl/PLAIN.pm new file mode 100644 index 0000000..31fed89 --- /dev/null +++ b/lib/Authen/SASL/Perl/PLAIN.pm @@ -0,0 +1,182 @@ +# Copyright (c) 2002 Graham Barr . All rights reserved. +# This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +package Authen::SASL::Perl::PLAIN; + +use strict; +use vars qw($VERSION @ISA); + +$VERSION = "2.14"; +@ISA = qw(Authen::SASL::Perl); + +my %secflags = ( + noanonymous => 1, +); + +my @tokens = qw(authname user pass); + +sub _order { 1 } +sub _secflags { + shift; + grep { $secflags{$_} } @_; +} + +sub mechanism { 'PLAIN' } + +sub client_start { + my $self = shift; + + $self->{error} = undef; + $self->{need_step} = 0; + + my @parts = map { + my $v = $self->_call($_); + defined($v) ? $v : '' + } @tokens; + + join("\0", @parts); +} + +sub server_start { + my $self = shift; + my $response = shift; + my $user_cb = shift || sub {}; + + $self->{error} = undef; + return $self->set_error("No response: Credentials don't match") + unless defined $response; + + my %parts; + @parts{@tokens} = split "\0", $response, scalar @tokens; + + + # I'm not entirely sure of what I am doing + $self->{answer}{$_} = $parts{$_} for qw/authname user/; + my $error = "Credentials don't match"; + + ## checkpass + if (my $checkpass = $self->callback('checkpass')) { + my $cb = sub { + my $result = shift; + unless ($result) { + $self->set_error($error); + } + else { + $self->set_success; + } + $user_cb->(); + }; + $checkpass->($self => { %parts } => $cb ); + return; + } + + ## getsecret + elsif (my $getsecret = $self->callback('getsecret')) { + my $cb = sub { + my $good_pass = shift; + if ($good_pass && $good_pass eq ($parts{pass} || "")) { + $self->set_success; + } + else { + $self->set_error($error); + } + $user_cb->(); + }; + $getsecret->( $self, { map { $_ => $parts{$_ } } qw/user authname/ }, $cb ); + return; + } + + ## error by default + else { + $self->set_error($error); + $user_cb->(); + } +} + +1; + +__END__ + +=head1 NAME + +Authen::SASL::Perl::PLAIN - Plain Login Authentication class + +=head1 SYNOPSIS + + use Authen::SASL qw(Perl); + + $sasl = Authen::SASL->new( + mechanism => 'PLAIN', + callback => { + user => $user, + pass => $pass + }, + ); + +=head1 DESCRIPTION + +This method implements the client and server part of the PLAIN SASL algorithm, +as described in RFC 2595 resp. IETF Draft draft-ietf-sasl-plain-XX.txt + +=head2 CALLBACK + +The callbacks used are: + +=head3 Client + +=over 4 + +=item authname + +The authorization id to use after successful authentication (client) + +=item user + +The username to be used for authentication (client) + +=item pass + +The user's password to be used for authentication. + +=back + +=head3 Server + +=over4 + +=item checkpass(username, password, realm) + +returns true and false depending on the validity of the credentials passed +in arguments. + +=back + +=head1 SEE ALSO + +L, +L + +=head1 AUTHORS + +Software written by Graham Barr , +documentation written by Peter Marschall . + +Please report any bugs, or post any suggestions, to the perl-ldap mailing list + + +=head1 COPYRIGHT + +Copyright (c) 2002-2004 Graham Barr. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +Documentation Copyright (c) 2004 Peter Marschall. +All rights reserved. This documentation is distributed, +and may be redistributed, under the same terms as Perl itself. + +Server support Copyright (c) 2009 Yann Kerherve. +All rights reserved. This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +=cut diff --git a/t/anon.t b/t/anon.t new file mode 100644 index 0000000..31fbfc0 --- /dev/null +++ b/t/anon.t @@ -0,0 +1,31 @@ +#!perl + +use Test::More tests => 5; + +use Authen::SASL qw(Perl); + +my $sasl = Authen::SASL->new( + mechanism => 'ANONYMOUS', + callback => { + user => 'gbarr', + pass => 'fred', + authname => 'none' + }, +); + +ok($sasl, 'new'); + +is($sasl->mechanism, 'ANONYMOUS', 'mechanism is ANONYMOUS'); + +my $conn = $sasl->client_new("ldap","localhost"); + +is($conn->mechanism, 'ANONYMOUS', 'connection mechanism is ANONYMOUS'); + +my $initial = $conn->client_start; + +ok($initial eq 'none', 'client_start'); + +my $step = $conn->client_step("xyz"); + +is($step, 'none', 'client_step'); + diff --git a/t/callback.t b/t/callback.t new file mode 100644 index 0000000..065c9e7 --- /dev/null +++ b/t/callback.t @@ -0,0 +1,38 @@ +#!perl + +use Test::More tests => 7; + +use Authen::SASL qw(Perl); + +my $sasl = Authen::SASL->new( + mechanism => 'PLAIN', + callback => { + user => 'gbarr', + pass => \&cb_pass, + authname => [ \&cb_authname, 1 ], + }, +); +ok($sasl, 'new'); + +is($sasl->mechanism, 'PLAIN', 'sasl mechanism'); + +my $conn = $sasl->client_new("ldap","localhost"); + +is($conn->mechanism, 'PLAIN', 'conn mechanism'); + +my $test = 4; + +is($conn->client_start, "none\0gbarr\0fred", "client_start"); + +is($conn->client_step("xyz"), undef, "client_step"); + +sub cb_pass { + ok(1,'pass callback'); + 'fred'; +} + +sub cb_authname { + ok((@_ == 2 and $_[1] == 1), 'authname callback'); + 'none'; +} + diff --git a/t/cram_md5.t b/t/cram_md5.t new file mode 100644 index 0000000..d593598 --- /dev/null +++ b/t/cram_md5.t @@ -0,0 +1,32 @@ +#!perl + +BEGIN { + eval { require Digest::HMAC_MD5 } +} + +use Test::More ($Digest::HMAC_MD5::VERSION ? (tests => 5) : (skip_all => 'Need Digest::HMAC_MD5')); + +use Authen::SASL qw(Perl); + +my $sasl = Authen::SASL->new( + mechanism => 'CRAM-MD5', + callback => { + user => 'gbarr', + pass => 'fred', + authname => 'none' + }, +); +ok($sasl, 'new'); + +is($sasl->mechanism, 'CRAM-MD5', 'sasl mechanism'); + +my $conn = $sasl->client_new("ldap","localhost", "noplaintext noanonymous"); + +is($conn->mechanism, 'CRAM-MD5', 'conn mechanism'); + + +is($conn->client_start, '', 'client_start'); + +is($conn->client_step("xyz"), 'gbarr 36c931fe47f3fe9c7adbf810b3c7c4ad', 'client_step'); + + diff --git a/t/digest_md5.t b/t/digest_md5.t new file mode 100644 index 0000000..718d013 --- /dev/null +++ b/t/digest_md5.t @@ -0,0 +1,107 @@ +#!perl + +BEGIN { + require Test::More; + eval { require Digest::MD5 } or Test::More->import(skip_all => 'Need Digest::MD5'); + eval { require Digest::HMAC_MD5 } or Test::More->import(skip_all => 'Need Digest::HMAC_MD5'); +} + +use Test::More (tests => 27); + +use Authen::SASL qw(Perl); + +my $authname; + +my $sasl = Authen::SASL->new( + mechanism => 'DIGEST-MD5', + callback => { + user => 'gbarr', + pass => 'fred', + authname => sub { $authname }, + }, +); +ok($sasl,'new'); + +is($sasl->mechanism, 'DIGEST-MD5', 'sasl mechanism'); + +my $conn = $sasl->client_new("ldap","localhost", "noplaintext noanonymous"); + +is($conn->mechanism, 'DIGEST-MD5', 'conn mechanism'); + +is($conn->client_start, '', 'client_start'); +ok $conn->need_step, "we need extra steps"; +ok !$conn->is_success, "success will be later if we are good boys"; +ok !$conn->error, "so far so good"; + +my $sparams = 'realm="elwood.innosoft.com",nonce="OA6MG9tEQGm2hh",qop="auth,auth-inf",algorithm=md5-sess,charset=utf-8'; +# override for testing as by default it uses $$, time and rand +$Authen::SASL::Perl::DIGEST_MD5::CNONCE = "foobar"; +$Authen::SASL::Perl::DIGEST_MD5::CNONCE = "foobar"; # avoid used only once warning +my $initial = $conn->client_step($sparams); +ok $conn->need_step, "we need extra steps"; +ok !$conn->is_success, "success will be later if we are good boys"; +ok !$conn->error, "so far so good"; + +my @expect = qw( + charset=utf-8 + cnonce="3858f62230ac3c915f300c664312c63f" + digest-uri="ldap/localhost" + nc=00000001 + nonce="OA6MG9tEQGm2hh" + qop=auth + realm="elwood.innosoft.com" + response=9c81619e12f61fb2eed6bc8ed504ad28 + username="gbarr" +); + +is( + $initial, + join(",", @expect), + 'client_step [1]' +); + +my $response='rspauth=d1273170c120bae49cea49de9b4c5bdc'; +$initial = $conn->client_step($response); +ok !$conn->need_step, "we're done"; +ok $conn->is_success, "success !"; +ok !$conn->error, "we did a good job"; + +is( + $initial, + '', + 'client_step [2]' +); + +# .. .and now everything with an authname +is($conn->client_start, '', 'client_start'); +ok $conn->need_step, "we need extra steps"; +ok !$conn->is_success, "success will be later if we are good boys"; +ok !$conn->error, "so far so good"; + +$authname = 'meme'; +$initial = $conn->client_step($sparams); +ok $conn->need_step, "we need extra steps"; +ok !$conn->is_success, "success will be later if we are good boys"; +ok !$conn->error, "so far so good"; + +$expect[3] = 'nc=00000002'; +$expect[7] = 'response=8d8afc5ff9cf3add40e50a5eaabb9aac'; + +is( + $initial, + join(",", 'authzid="meme"', @expect), + 'client_step + authname [1]' +); + +$response='rspauth=dcb2b36dcd0750d3a7d0482fe1872769'; +$initial = $conn->client_step($response); +ok !$conn->need_step, "we're done"; +ok $conn->is_success, "success !"; +ok !$conn->error, "we did a good job"; + +is( + $initial, + '', + 'client_step + authname [2]' +) or diag $conn->error; + diff --git a/t/digest_md5_verified.t b/t/digest_md5_verified.t new file mode 100644 index 0000000..29bacae --- /dev/null +++ b/t/digest_md5_verified.t @@ -0,0 +1,67 @@ +#!perl + +BEGIN { + require Test::More; + eval { require Digest::MD5 } or Test::More->import(skip_all => 'Need Digest::MD5'); + eval { require Digest::HMAC_MD5 } or Test::More->import(skip_all => 'Need Digest::HMAC_MD5'); +} + +use Test::More (tests => 8); + +use Authen::SASL qw(Perl); + +my $authname; + +my $sasl = Authen::SASL->new( + mechanism => 'DIGEST-MD5', + callback => { + user => 'fred', + pass => 'gladys', + authname => sub { $authname }, + }, +); +ok($sasl,'new'); + +is($sasl->mechanism, 'DIGEST-MD5', 'sasl mechanism'); + +my $conn = $sasl->client_new("sieve","imap.spodhuis.org", "noplaintext noanonymous"); + +is($conn->mechanism, 'DIGEST-MD5', 'conn mechanism'); + +is($conn->client_start, '', 'client_start'); + +my $sparams = 'nonce="YPymzyi3YH8OILTBvSIuaul7RD3fIANDT2akHE6auBE=",realm="imap.spodhuis.org",qop="auth",maxbuf=4096,charset=utf-8,algorithm=md5-sess'; +# override for testing as by default it uses $$, time and rand +$Authen::SASL::Perl::DIGEST_MD5::CNONCE = "foobar"; +$Authen::SASL::Perl::DIGEST_MD5::CNONCE = "foobar"; # avoid used only once warning +my $initial = $conn->client_step($sparams); + +ok(!$conn->code(), "SASL error: " . ($conn->code() ? $conn->error() : '')); + +my @expect = qw( + charset=utf-8 + cnonce="3858f62230ac3c915f300c664312c63f" + digest-uri="sieve/imap.spodhuis.org" + nc=00000001 + nonce="YPymzyi3YH8OILTBvSIuaul7RD3fIANDT2akHE6auBE=" + qop=auth + realm="imap.spodhuis.org" + response=3743421076899a855bafec1f7a9ed58a + username="fred" +); + +is( + $initial, + join(",", @expect), + 'client_step' +); + +my $second = $conn->client_step('rspauth=4593215e1a0613328324b8325b975d96'); + +ok(!$conn->code(), "SASL error: " . ($conn->code() ? $conn->error() : '')); + +is( + $second, + '', + 'client_step final verification' +); diff --git a/t/external.t b/t/external.t new file mode 100644 index 0000000..4bfee60 --- /dev/null +++ b/t/external.t @@ -0,0 +1,27 @@ +#!perl + +use Test::More tests => 5; + +use Authen::SASL qw(Perl); + +my $sasl = Authen::SASL->new( + mechanism => 'EXTERNAL', + callback => { + user => 'gbarr', + pass => 'fred', + authname => 'none' + }, +); +ok($sasl, 'new'); + +is($sasl->mechanism, 'EXTERNAL', 'sasl mechanism'); + +my $conn = $sasl->client_new("ldap","localhost", "noplaintext"); + +is($conn->mechanism, 'EXTERNAL', 'conn mechanism'); + +is($conn->client_start, 'gbarr', 'client_start'); + +is($conn->client_step("xyz"), undef, 'client_step'); + + diff --git a/t/lib/common.pl b/t/lib/common.pl new file mode 100644 index 0000000..e40dc52 --- /dev/null +++ b/t/lib/common.pl @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Authen::SASL ('Perl'); + +sub negotiate { + my ($c, $s, $do) = @_; + + my $client_sasl = Authen::SASL->new( %{ $c->{sasl} } ); + my $server_sasl = Authen::SASL->new( %{ $s->{sasl} } ); + + my $client = $client_sasl->client_new(@$c{qw/service host security/}); + my $server = $server_sasl->server_new(@$s{qw/service host/}); + + my $start = $client->client_start(); + + my $challenge; + my $next_cb = sub { $challenge = shift }; + $server->server_start($start, $next_cb); + + my $response; + ## note: this wouldn't work in a real async environment + while ($client->need_step || $server->need_step) { + $response = $client->client_step($challenge) + if $client->need_step; + last if $client->error; + $server->server_step($response, $next_cb) + if $server->need_step; + last if $server->error; + } + $do->($client, $server); +} + +1; diff --git a/t/login.t b/t/login.t new file mode 100644 index 0000000..51c5942 --- /dev/null +++ b/t/login.t @@ -0,0 +1,29 @@ +#!perl + +use Test::More tests => 6; + +use Authen::SASL qw(Perl); + +my $sasl = Authen::SASL->new( + mechanism => 'LOGIN', + callback => { + user => 'gbarr', + pass => 'fred', + authname => 'none' + }, +); +ok($sasl, 'new'); + +is($sasl->mechanism, 'LOGIN', 'sasl mechanism'); + +my $conn = $sasl->client_new("ldap","localhost"); + +is($conn->mechanism, 'LOGIN', 'conn mechanism'); + +is($conn->client_start, '', 'client_start'); + +is($conn->client_step("username"), 'gbarr', 'client_step username'); + +is($conn->client_step("password"), 'fred', 'client_step password'); + +## XXX TODO check for success and extra steps diff --git a/t/negotiations/digest_md5.t b/t/negotiations/digest_md5.t new file mode 100644 index 0000000..bb7357e --- /dev/null +++ b/t/negotiations/digest_md5.t @@ -0,0 +1,80 @@ +#!perl +use strict; +use warnings; +use Test::More tests => 11; +use FindBin qw($Bin); +require "$Bin/../lib/common.pl"; + +## base conf +my $cconf = { + sasl => { + mechanism => 'DIGEST-MD5', + callback => { + user => 'yann', + pass => 'maelys', + }, + }, + host => 'localhost', + security => 'noanonymous', + service => 'xmpp', +}; + +my $sconf = { + sasl => { + mechanism => 'DIGEST-MD5', + callback => { + getsecret => sub { $_[2]->('maelys') }, + }, + }, + host => 'localhost', + service => 'xmpp', +}; + +## base negotiation should work +negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + ok $clt->is_success, "client success" or diag $clt->error; + ok $srv->is_success, "server success" or diag $srv->error; +}); + +## invalid password +{ + local $cconf->{sasl}{callback}{pass} = "YANN"; + + negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + ok !$srv->is_success, "failure"; + like $srv->error, qr/response/; + }); +} + +## arguments passed to server pass callback +{ + local $cconf->{sasl}{callback}{authname} = "some authzid"; + local $sconf->{sasl}{callback}{getsecret} = sub { + my $server = shift; + my ($args, $cb) = @_; + is $args->{user}, "yann", "username"; + is $args->{realm}, "localhost", "realm"; + is $args->{authzid}, "some authzid", "authzid"; + $cb->("incorrect"); + }; + + negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + ok !$srv->is_success, "failure"; + like $srv->error, qr/response/, "incorrect response"; + }); +} + +## digest-uri checking +{ + local $cconf->{host} = "elsewhere"; + local $cconf->{service} = "pop3"; + negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + ok !$srv->is_success, "failure"; + my $error = $srv->error || ""; + like $error, qr/incorrect.*digest.*uri/i, "incorrect digest uri"; + }); +} diff --git a/t/negotiations/login.t b/t/negotiations/login.t new file mode 100644 index 0000000..ec24e5e --- /dev/null +++ b/t/negotiations/login.t @@ -0,0 +1,65 @@ +#!perl + +use Test::More tests => 9; + +use FindBin qw($Bin); +require "$Bin/../lib/common.pl"; + +use Authen::SASL qw(Perl); +use_ok('Authen::SASL::Perl::LOGIN'); + +## base conf +my $cconf = { + sasl => { + mechanism => 'LOGIN', + callback => { + user => 'yann', + pass => 'maelys', + }, + }, + host => 'localhost', + service => 'xmpp', +}; +my $Password = 'maelys'; +my $sconf = { + sasl => { + mechanism => 'LOGIN', + callback => { + getsecret => sub { $_[2]->($Password) }, + }, + }, + host => 'localhost', + service => 'xmpp', +}; + +## base negotiation should work +negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + is $clt->mechanism, "LOGIN"; + is $srv->mechanism, "LOGIN"; + ok $clt->is_success, "client success" or diag $clt->error; + ok $srv->is_success, "server success" or diag $srv->error; +}); + +## invalid password +{ + # hey callback could just be a subref that returns a localvar + $Password = "wrong"; + + negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + ok ! $srv->is_success, "wrong pass"; + like $srv->error, qr/match/, "error set"; + }); +} + +## invalid password with different callback +{ + local $sconf->{sasl}{callback}{checkpass} = sub { $_[2]->(0) }; + + negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + ok ! $srv->is_success, "wrong pass"; + like $srv->error, qr/match/, "error set"; + }); +} diff --git a/t/negotiations/plain.t b/t/negotiations/plain.t new file mode 100644 index 0000000..34c434d --- /dev/null +++ b/t/negotiations/plain.t @@ -0,0 +1,66 @@ +#!perl + +use Test::More tests => 9; + +use FindBin qw($Bin); +require "$Bin/../lib/common.pl"; + +use Authen::SASL qw(Perl); +use_ok('Authen::SASL::Perl::PLAIN'); + +## base conf +my $cconf = { + sasl => { + mechanism => 'PLAIN', + callback => { + user => 'yann', + pass => 'maelys', + }, + }, + host => 'localhost', + service => 'xmpp', +}; + +my $Password = 'maelys'; +my $sconf = { + sasl => { + mechanism => 'PLAIN', + callback => { + getsecret => sub { $_[2]->($Password) }, + }, + }, + host => 'localhost', + service => 'xmpp', +}; + +## base negotiation should work +negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + is $clt->mechanism, "PLAIN"; + is $srv->mechanism, "PLAIN"; + ok $clt->is_success, "client success" or diag $clt->error; + ok $srv->is_success, "server success" or diag $srv->error; +}); + +## invalid password +{ + # hey callback could just be a subref that returns a localvar + $Password = "x"; + + negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + ok ! $srv->is_success, "wrong pass"; + like $srv->error, qr/match/, "error set"; + }); +} + +## invalid password with different callback +{ + local $sconf->{sasl}{callback}{checkpass} = sub { $_[2]->(0) }; + + negotiate($cconf, $sconf, sub { + my ($clt, $srv) = @_; + ok ! $srv->is_success, "wrong pass"; + like $srv->error, qr/match/, "error set"; + }); +} diff --git a/t/order.t b/t/order.t new file mode 100644 index 0000000..2a76c3c --- /dev/null +++ b/t/order.t @@ -0,0 +1,49 @@ +#!perl + +use Test::More tests => 75; + +use Authen::SASL qw(Perl); + +my %order = qw( + ANONYMOUS 0 + LOGIN 1 + PLAIN 1 + CRAM-MD5 2 + EXTERNAL 2 + DIGEST-MD5 3 +); +my $skip3 = !eval { require Digest::MD5 and $Digest::MD5::VERSION || $Digest::MD5::VERSION }; + +foreach my $level (reverse 0..3) { + my @mech = grep { $order{$_} <= $level } keys %order; + foreach my $n (1..@mech) { + push @mech, shift @mech; # rotate + my $mech = join(" ",@mech); + print "# $level $mech\n"; + if ($level == 3 and $skip3) { + SKIP: { + skip "requires Digest::MD5", 5; + } + next; + } + my $sasl = Authen::SASL->new( + mechanism => $mech, + callback => { + user => 'gbarr', + pass => 'fred', + authname => 'none' + }, + ); + ok($sasl, "new"); + + is($sasl->mechanism, $mech, "sasl mechanism"); + + my $conn = $sasl->client_new("ldap","localhost"); + ok($conn, 'client_new'); + + my $chosen = $conn->mechanism; + ok($chosen, 'conn mechanism ' . ($chosen || '?')); + + is($order{$chosen}, $level, 'mechanism level'); + } +} diff --git a/t/plain.t b/t/plain.t new file mode 100644 index 0000000..545e589 --- /dev/null +++ b/t/plain.t @@ -0,0 +1,36 @@ +#!perl + +use Test::More tests => 14; + +use Authen::SASL qw(Perl); + +my $sasl = Authen::SASL->new( + mechanism => 'PLAIN', + callback => { + user => 'gbarr', + pass => 'fred', + authname => 'none' + }, +); +ok($sasl, 'new'); + +is($sasl->mechanism, 'PLAIN', 'sasl mechanism'); + +my $conn = $sasl->client_new("ldap","localhost"); + +is($conn->mechanism, 'PLAIN', 'conn mechanism'); +ok $conn->need_step, "we need to *start* at the minimum"; +ok !$conn->is_success, "no success yet"; +ok !$conn->error, "and no error"; + +is($conn->client_start, "none\0gbarr\0fred", 'client_start'); +ok !$conn->need_step, "we're done, plain is kinda quick"; +ok $conn->is_success, "success!"; +ok !$conn->error, "and no error"; + +is($conn->client_step("xyz"), undef, 'client_step'); +ok !$conn->need_step, "we're done already"; +ok $conn->is_success, "sucess already"; +ok !$conn->error, "and no error"; + + diff --git a/t/server/digest_md5.t b/t/server/digest_md5.t new file mode 100644 index 0000000..4c81720 --- /dev/null +++ b/t/server/digest_md5.t @@ -0,0 +1,235 @@ +#!perl +use strict; +use warnings; + +BEGIN { + require Test::More; + eval { require Digest::MD5 } or Test::More->import(skip_all => 'Need Digest::MD5'); + eval { require Digest::HMAC_MD5 } or Test::More->import(skip_all => 'Need Digest::HMAC_MD5'); +} + +use Test::More (tests => 33); + +use Authen::SASL qw(Perl); +use_ok 'Authen::SASL::Perl::DIGEST_MD5'; + +my $authname; + +my $sasl = Authen::SASL->new( + mechanism => 'DIGEST-MD5', + callback => { + getsecret => sub { $_[2]->('fred') }, + }, +); +ok($sasl,'new'); + +no warnings 'once'; +# override for testing as by default it uses $$, time and rand +$Authen::SASL::Perl::DIGEST_MD5::NONCE = "foobaz"; + +is($sasl->mechanism, 'DIGEST-MD5', 'sasl mechanism'); +my $server = $sasl->server_new("ldap","elwood.innosoft.com", { no_integrity => 1 }); +is($server->mechanism, 'DIGEST-MD5', 'conn mechanism'); + +## simple success without authzid +{ + my $expected_ss = join ",", + 'algorithm=md5-sess', + 'charset=utf-8', + 'cipher="rc4,3des,des,rc4-56,rc4-40"', + 'maxbuf=16777215', + 'nonce="80338e79d2ca9b9c090ebaaa2ef293c7"', + 'qop="auth"', + 'realm="elwood.innosoft.com"'; + + my $ss; + $server->server_start('', sub { $ss = shift }); + is($ss, $expected_ss, 'server_start'); + + my $c1 = join ",", qw( + charset=utf-8 + cnonce="3858f62230ac3c915f300c664312c63f" + digest-uri="ldap/elwood.innosoft.com" + nc=00000001 + nonce="80338e79d2ca9b9c090ebaaa2ef293c7" + qop=auth + realm="elwood.innosoft.com" + response=39ab7388b1f52492b1b87cda55177d04 + username="gbarr" + ); + + my $s1; + $server->server_step($c1, sub { $s1 = shift }); + ok $server->is_success, "This is the first and only step"; + ok !$server->error, "no error" or diag $server->error; + ok !$server->need_step, "over"; + is $server->property('ssf'), 0, "auth doesn't provide any protection"; + is($s1, "rspauth=dbf4b44d397bafd53be835344988ec9d", "rspauth matches"); +} + +# try with an authname +{ + my $expected_ss = join ",", + 'algorithm=md5-sess', + 'charset=utf-8', + 'cipher="rc4,3des,des,rc4-56,rc4-40"', + 'maxbuf=16777215', + 'nonce="80338e79d2ca9b9c090ebaaa2ef293c7"', + 'qop="auth"', + 'realm="elwood.innosoft.com"'; + + my $ss; + $server->server_start('', sub { $ss = shift }); + is($ss, $expected_ss, 'server_start'); + ok !$server->is_success, "not success yet"; + ok !$server->error, "no error" or diag $server->error; + ok $server->need_step, "we need one more step"; + + $authname = 'meme'; + + my $c1 = join ",", qw( + authzid="meme" + charset=utf-8 + cnonce="3858f62230ac3c915f300c664312c63f" + digest-uri="ldap/elwood.innosoft.com" + nc=00000002 + nonce="80338e79d2ca9b9c090ebaaa2ef293c7" + qop=auth + realm="elwood.innosoft.com" + response=e01f51543754aa665cfa2c621d59ee9e + username="gbarr" + ); + + my $s1; + $server->server_step($c1, sub { $s1 = shift }); + is($s1, "rspauth=d10458627b2b6bb553d796f4d805fdd1", "rspauth") + or diag $server->error; + ok $server->is_success, "success!"; + ok !$server->error, "no error" or diag $server->error; + ok !$server->need_step, "over"; + is $server->property('ssf'), 0, "auth doesn't provide any protection"; +} + +## using auth-conf (if available) +{ + SKIP: { + skip "Crypt not available", 6 + if $Authen::SASL::Perl::DIGEST_MD5::NO_CRYPT_AVAILABLE; + + $server = $sasl->server_new("ldap","elwood.innosoft.com"); + my $expected_ss = join ",", + 'algorithm=md5-sess', + 'charset=utf-8', + 'cipher="rc4,3des,des,rc4-56,rc4-40"', + 'maxbuf=16777215', + 'nonce="80338e79d2ca9b9c090ebaaa2ef293c7"', + 'qop="auth,auth-conf,auth-int"', + 'realm="elwood.innosoft.com"'; + + my $ss; + $server->server_start('', sub { $ss = shift }); + is($ss, $expected_ss, 'server_start'); + + my $c1 = join ",", qw( + charset=utf-8 + cnonce="3858f62230ac3c915f300c664312c63f" + digest-uri="ldap/elwood.innosoft.com" + nc=00000001 + nonce="80338e79d2ca9b9c090ebaaa2ef293c7" + qop=auth-conf + realm="elwood.innosoft.com" + response=e3c8b38d9bd9556761253e9879c4a8a2 + username="gbarr" + ); + + my $s1; + $server->server_step($c1, sub { $s1 = shift }); + ok $server->is_success, "This is the first and only step"; + ok !$server->error, "no error" or diag $server->error; + ok !$server->need_step, "over"; + is($s1, "rspauth=1b1156d0e7f046bd0ea1476eb7d63a7b", "rspauth matches"); + + ## we have negociated the conf layer + ok $server->property('ssf') > 1, "yes! secure layer set up"; + }; +} +## wrong challenge response +{ + $server = $sasl->server_new("ldap","elwood.innosoft.com"); + $server->server_start(''); + + my $c1 = join ",", qw( + charset=utf-8 + cnonce="3858f62230ac3c915f300c664312c63f" + digest-uri="ldap/elwood.innosoft.com" + nc=00000001 + nonce="80338e79d2ca9b9c090ebaaa2ef293c7" + qop=auth-conf + realm="elwood.innosoft.com" + response=nottherightone + username="gbarr" + ); + + $server->server_step($c1); + ok !$server->is_success, "Bad challenge"; + + if ($Authen::SASL::Perl::DIGEST_MD5::NO_CRYPT_AVAILABLE) { + like $server->error, qr/Client qop not supported/, $server->error; + } + else { + like $server->error, qr/incorrect.*response/i, $server->error; + } +} + +## multiple digest-uri; +{ + $server = $sasl->server_new("ldap","elwood.innosoft.com"); + $server->server_start(''); + + my $c1 = join ",", qw( + charset=utf-8 + cnonce="3858f62230ac3c915f300c664312c63f" + digest-uri="ldap/elwood.innosoft.com" + digest-uri="ldap/elwood.innosoft.com" + nc=00000001 + nonce="80338e79d2ca9b9c090ebaaa2ef293c7" + qop=auth-conf + realm="elwood.innosoft.com" + response=e3c8b38d9bd9556761253e9879c4a8a2 + username="gbarr" + ); + + $server->server_step($c1); + ok !$server->is_success, "Bad challenge"; + like $server->error, qr/Bad.*challenge/i, $server->error; +} + +## nonce-count; +{ + $server = $sasl->server_new("ldap","elwood.innosoft.com"); + $server->server_start(''); + + my $c1 = join ",", qw( + charset=utf-8 + cnonce="3858f62230ac3c915f300c664312c63f" + digest-uri="ldap/elwood.innosoft.com" + nc=00000001 + nonce="80338e79d2ca9b9c090ebaaa2ef293c7" + qop=auth-conf + realm="elwood.innosoft.com" + response=e3c8b38d9bd9556761253e9879c4a8a2 + username="gbarr" + ); + + SKIP: { + skip "no crypt available", 4 + if $Authen::SASL::Perl::DIGEST_MD5::NO_CRYPT_AVAILABLE; + $server->server_step($c1); + ok $server->is_success, "first is success"; + ok ! $server->error, "no error"; + + $server->server_step($c1); + ok !$server->is_success, "replay attack"; + like $server->error, qr/nonce-count.*match/i, $server->error; + } +} diff --git a/t/server/login.t b/t/server/login.t new file mode 100644 index 0000000..914c09e --- /dev/null +++ b/t/server/login.t @@ -0,0 +1,82 @@ +#!perl +use strict; +use warnings; + +use Test::More tests => 32; + +use Authen::SASL qw(Perl); +use_ok('Authen::SASL::Perl::LOGIN'); + +my %params = ( + mechanism => 'LOGIN', + callback => { + getsecret => sub { use Carp; Carp::confess("x") unless $_[2]; $_[2]->('secret') }, + }, +); + +ok(my $ssasl = Authen::SASL->new( %params ), "new"); + +is($ssasl->mechanism, 'LOGIN', 'sasl mechanism'); + +my $server = $ssasl->server_new("xmpp","localhost"); +is($server->mechanism, 'LOGIN', 'server mechanism'); + +is_failure(); +is_failure("", ""); +is_failure("xxx", "yyy", "zzz"); +is_failure("a", "a", "a"); + +my $response; my $cb = sub { $response = shift }; +$server->server_start("", $cb), +is $response, "Username:"; +$server->server_step("user", $cb); +is $response, "Password:"; +$server->server_step("secret", $cb); + +ok !$server->error, "no error" or diag $server->error; +ok $server->is_success, "success finally"; + +sub is_failure { + my $creds = shift; + my @steps = @_; + ## wouldn't really work in an async environemnt + my $cb; + $server->server_start("", sub { $cb = 1 }); + ok $cb, "callback called"; + for (@steps) { + $cb = 0; + $server->server_step($_, sub { $cb = 1 }); + ok $cb, "callback called"; + } + ok !$server->is_success, "failure"; + ok ($server->need_step or $server->error), "no success means that"; +} + + +## testing checkpass callback, which takes precedence +## over getsecret when specified +%params = ( + mechanism => 'LOGIN', + callback => { + getsecret => "incorrect", + checkpass => sub { + my $self = shift; + my ($args, $cb) = @_; + is $args->{user}, "foo", "username correct"; + is $args->{pass}, "bar", "correct password"; + $cb->(1); + return; + } + }, +); + +ok($ssasl = Authen::SASL->new( %params ), "new"); +$server = $ssasl->server_new("ldap","localhost"); +my $cb; +$server->server_start("", sub { $cb = 1 }); +ok $cb, "callback called"; $cb = 0; +$server->server_step("foo", sub { $cb = 1 }); +ok $cb, "callback called"; $cb = 0; +$server->server_step("bar", sub { $cb = 1 }); +ok $cb, "callback called"; +ok $server->is_success, "success"; diff --git a/t/server/plain.t b/t/server/plain.t new file mode 100644 index 0000000..b750121 --- /dev/null +++ b/t/server/plain.t @@ -0,0 +1,109 @@ +#!perl +use strict; +use warnings; + +use Test::More tests => 67; + +use Authen::SASL qw(Perl); +use_ok('Authen::SASL::Perl::PLAIN'); + +my %creds = ( + default => { + yann => "maelys", + YANN => "MAELYS", + }, + none => { + yann => "maelys", + YANN => "MAELYS", + }, +); + +my %params = ( + mechanism => 'PLAIN', + callback => { + getsecret => sub { + my $self = shift; + my ($args, $cb) = @_; + $cb->($creds{$args->{authname} || "default"}{$args->{user} || ""}); + }, + checkpass => sub { + my $self = shift; + my ($args, $cb) = @_; + $args ||= {}; + my $username = $args->{user}; + my $password = $args->{pass}; + my $authzid = $args->{authname}; + unless ($username) { + $cb->(0); + return; + } + my $expected = $creds{$authzid || "default"}{$username}; + if ($expected && $expected eq ($password || "")) { + $cb->(1); + } + else { + $cb->(0); + } + return; + }, + }, +); + +ok(my $ssasl = Authen::SASL->new( %params ), "new"); + +is($ssasl->mechanism, 'PLAIN', 'sasl mechanism'); + +my $server = $ssasl->server_new("ldap","localhost"); +is($server->mechanism, 'PLAIN', 'server mechanism'); + +for my $authname ('', 'none') { + is_failure(""); + is_failure("xxx"); + is_failure("\0\0\0\0\0\0\0"); + is_failure("\0\0\0\0\0\0\0$authname\0yann\0maelys"); + is_failure("yann\0maelys\0$authname", "wrong order"); + is_failure("$authname\0YANN\0maelys", "case matters"); + is_failure("$authname\0yann\n\0maelys", "extra stuff"); + is_failure("$authname\0yann\0\0maelys", "double null"); + is_failure("$authname\0yann\0maelys\0trailing", "trailing"); + + my $cb; + $server->server_start("$authname\0yann\0maelys", sub { $cb = 1 }); + ok $cb, "callback called"; + ok $server->is_success, "success finally"; +} + +## testing checkpass callback, which takes precedence +## over getsecret when specified +%params = ( + mechanism => 'PLAIN', + callback => { + getsecret => sub { $_[2]->("incorrect") }, + checkpass => sub { + my $self = shift; + my ($args, $cb) = @_; + is $args->{user}, "yyy", "username correct"; + is $args->{pass}, "zzz", "correct password"; + is $args->{authname}, "xxx", "correct realm"; + $cb->(1); + return; + } + }, +); + +ok($ssasl = Authen::SASL->new( %params ), "new"); +$server = $ssasl->server_new("ldap","localhost"); +$server->server_start("xxx\0yyy\0zzz"); +ok $server->is_success, "success"; + +sub is_failure { + my $creds = shift; + my $msg = shift; + my $cb; + $server->server_start($creds, sub { $cb = 1 }); + ok $cb, 'callback called'; + ok !$server->is_success, $msg || "failure"; + my $error = $server->error || ""; + like $error, qr/match/i, "failure"; +} +