Authen-SASL-2.16/000755 000765 000765 00000000000 12021423635 013672 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/api.txt000644 000765 000765 00000004370 11346203766 015222 0ustar00gbarrgbarr000000 000000 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 Authen-SASL-2.16/Changes000644 000765 000765 00000013476 12021422726 015200 0ustar00gbarrgbarr000000 000000 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 Authen-SASL-2.16/compat_pl000755 000765 000765 00000000557 11032157025 015603 0ustar00gbarrgbarr000000 000000 #!/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"; Authen-SASL-2.16/example_pl000755 000765 000765 00000001573 11032157025 015752 0ustar00gbarrgbarr000000 000000 #!/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"; Authen-SASL-2.16/inc/000755 000765 000765 00000000000 12021423635 014443 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/lib/000755 000765 000765 00000000000 12021423635 014440 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/Makefile.PL000644 000765 000765 00000000764 11346203766 015665 0ustar00gbarrgbarr000000 000000 # 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(); Authen-SASL-2.16/MANIFEST000644 000765 000765 00000001740 12021423633 015023 0ustar00gbarrgbarr000000 000000 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 Authen-SASL-2.16/MANIFEST.SKIP000644 000765 000765 00000000315 11257013754 015576 0ustar00gbarrgbarr000000 000000 ^_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.* Authen-SASL-2.16/META.yml000644 000765 000765 00000001177 12021423632 015146 0ustar00gbarrgbarr000000 000000 --- 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 Authen-SASL-2.16/MYMETA.json000644 000765 000765 00000001721 12021423632 015557 0ustar00gbarrgbarr000000 000000 { "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" } Authen-SASL-2.16/MYMETA.yml000644 000765 000765 00000001035 12021423632 015405 0ustar00gbarrgbarr000000 000000 --- 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 Authen-SASL-2.16/SIGNATURE000644 000765 000765 00000007414 12021423635 015164 0ustar00gbarrgbarr000000 000000 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----- Authen-SASL-2.16/t/000755 000765 000765 00000000000 12021423635 014135 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/t/anon.t000644 000765 000765 00000001070 11032157025 015251 0ustar00gbarrgbarr000000 000000 #!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'); Authen-SASL-2.16/t/callback.t000644 000765 000765 00000001226 11032157025 016055 0ustar00gbarrgbarr000000 000000 #!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'; } Authen-SASL-2.16/t/cram_md5.t000644 000765 000765 00000001235 11032157025 016010 0ustar00gbarrgbarr000000 000000 #!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'); Authen-SASL-2.16/t/digest_md5.t000644 000765 000765 00000005445 11346203766 016370 0ustar00gbarrgbarr000000 000000 #!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; Authen-SASL-2.16/t/digest_md5_verified.t000644 000765 000765 00000003327 11256563304 020237 0ustar00gbarrgbarr000000 000000 #!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' ); Authen-SASL-2.16/t/external.t000644 000765 000765 00000000773 11257013754 016162 0ustar00gbarrgbarr000000 000000 #!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'); Authen-SASL-2.16/t/lib/000755 000765 000765 00000000000 12021423635 014703 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/t/login.t000644 000765 000765 00000001137 11346203766 015446 0ustar00gbarrgbarr000000 000000 #!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 Authen-SASL-2.16/t/negotiations/000755 000765 000765 00000000000 12021423635 016640 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/t/order.t000644 000765 000765 00000002022 11032157025 015427 0ustar00gbarrgbarr000000 000000 #!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'); } } Authen-SASL-2.16/t/plain.t000644 000765 000765 00000001554 11346203766 015444 0ustar00gbarrgbarr000000 000000 #!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"; Authen-SASL-2.16/t/server/000755 000765 000765 00000000000 12021423635 015443 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/t/server/digest_md5.t000644 000765 000765 00000016011 11346203766 017665 0ustar00gbarrgbarr000000 000000 #!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; } } Authen-SASL-2.16/t/server/login.t000644 000765 000765 00000004121 11401523276 016741 0ustar00gbarrgbarr000000 000000 #!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"; Authen-SASL-2.16/t/server/plain.t000644 000765 000765 00000005425 11401523276 016744 0ustar00gbarrgbarr000000 000000 #!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"; } Authen-SASL-2.16/t/negotiations/digest_md5.t000644 000765 000765 00000003671 11346203766 021072 0ustar00gbarrgbarr000000 000000 #!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"; }); } Authen-SASL-2.16/t/negotiations/login.t000644 000765 000765 00000002670 11346203766 020154 0ustar00gbarrgbarr000000 000000 #!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"; }); } Authen-SASL-2.16/t/negotiations/plain.t000644 000765 000765 00000002665 11346203766 020153 0ustar00gbarrgbarr000000 000000 #!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"; }); } Authen-SASL-2.16/t/lib/common.pl000644 000765 000765 00000001642 11346203766 016545 0ustar00gbarrgbarr000000 000000 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; Authen-SASL-2.16/lib/Authen/000755 000765 000765 00000000000 12021423635 015664 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/lib/Authen/SASL/000755 000765 000765 00000000000 12021423635 016426 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/lib/Authen/SASL.pm000644 000765 000765 00000005262 12021422666 016774 0ustar00gbarrgbarr000000 000000 # 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; Authen-SASL-2.16/lib/Authen/SASL.pod000644 000765 000765 00000013147 12021422637 017141 0ustar00gbarrgbarr000000 000000 =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 Authen-SASL-2.16/lib/Authen/SASL/CRAM_MD5.pm000644 000765 000765 00000000540 11346203766 020164 0ustar00gbarrgbarr000000 000000 # 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; Authen-SASL-2.16/lib/Authen/SASL/EXTERNAL.pm000644 000765 000765 00000000540 11346203766 020217 0ustar00gbarrgbarr000000 000000 # 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; Authen-SASL-2.16/lib/Authen/SASL/Perl/000755 000765 000765 00000000000 12021423635 017330 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/lib/Authen/SASL/Perl.pm000644 000765 000765 00000017320 12021422637 017672 0ustar00gbarrgbarr000000 000000 # 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; Authen-SASL-2.16/lib/Authen/SASL/Perl.pod000644 000765 000765 00000010136 11346203766 020047 0ustar00gbarrgbarr000000 000000 # 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 Authen-SASL-2.16/lib/Authen/SASL/Perl/ANONYMOUS.pm000644 000765 000765 00000003405 11346203766 021272 0ustar00gbarrgbarr000000 000000 # 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 Authen-SASL-2.16/lib/Authen/SASL/Perl/CRAM_MD5.pm000644 000765 000765 00000003737 11346203766 021101 0ustar00gbarrgbarr000000 000000 # 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 Authen-SASL-2.16/lib/Authen/SASL/Perl/DIGEST_MD5.pm000644 000765 000765 00000055500 11346203766 021331 0ustar00gbarrgbarr000000 000000 # 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 Authen-SASL-2.16/lib/Authen/SASL/Perl/EXTERNAL.pm000644 000765 000765 00000003444 11346203766 021127 0ustar00gbarrgbarr000000 000000 # 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 Authen-SASL-2.16/lib/Authen/SASL/Perl/GSSAPI.pm000644 000765 000765 00000025062 11346175727 020700 0ustar00gbarrgbarr000000 000000 # 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 Authen-SASL-2.16/lib/Authen/SASL/Perl/LOGIN.pm000644 000765 000765 00000010654 11401523276 020547 0ustar00gbarrgbarr000000 000000 # 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 Authen-SASL-2.16/lib/Authen/SASL/Perl/PLAIN.pm000644 000765 000765 00000007132 11401523276 020537 0ustar00gbarrgbarr000000 000000 # 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 Authen-SASL-2.16/inc/Module/000755 000765 000765 00000000000 12021423635 015670 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/inc/Module/Install/000755 000765 000765 00000000000 12021423635 017276 5ustar00gbarrgbarr000000 000000 Authen-SASL-2.16/inc/Module/Install.pm000644 000765 000765 00000026371 12021423632 017642 0ustar00gbarrgbarr000000 000000 #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. Authen-SASL-2.16/inc/Module/Install/Base.pm000644 000765 000765 00000001766 12021423632 020515 0ustar00gbarrgbarr000000 000000 #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 Authen-SASL-2.16/inc/Module/Install/Can.pm000644 000765 000765 00000003333 12021423632 020334 0ustar00gbarrgbarr000000 000000 #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 Authen-SASL-2.16/inc/Module/Install/Fetch.pm000644 000765 000765 00000004627 12021423632 020673 0ustar00gbarrgbarr000000 000000 #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; Authen-SASL-2.16/inc/Module/Install/Makefile.pm000644 000765 000765 00000026220 12021423632 021350 0ustar00gbarrgbarr000000 000000 #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 Authen-SASL-2.16/inc/Module/Install/Metadata.pm000644 000765 000765 00000041000 12021423632 021344 0ustar00gbarrgbarr000000 000000 #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; Authen-SASL-2.16/inc/Module/Install/Win32.pm000644 000765 000765 00000003403 12021423632 020533 0ustar00gbarrgbarr000000 000000 #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; Authen-SASL-2.16/inc/Module/Install/WriteAll.pm000644 000765 000765 00000002377 12021423632 021365 0ustar00gbarrgbarr000000 000000 #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;