/usr/local/CPAN/SVK/SVK/Config.pm

• package SVK::Config
  • svnconfig
  • get_auth_providers
  • _simple_prompt
  • _ssl_server_trust_prompt
  • _ssl_client_cert_prompt
  • _ssl_client_cert_pw_prompt
  • _username_prompt
  • _read_password
• EOF

# BEGIN BPS TAGGED BLOCK {{{
# COPYRIGHT:
# 
# This software is Copyright (c) 2003-2008 Best Practical Solutions, LLC
#                                          <clkao@bestpractical.com>
# 
# (Except where explicitly superseded by other copyright notices)
# 
# 
# LICENSE:
# 
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of either:
# 
#   a) Version 2 of the GNU General Public License.  You should have
#      received a copy of the GNU General Public License along with this
#      program.  If not, write to the Free Software Foundation, Inc., 51
#      Franklin Street, Fifth Floor, Boston, MA 02110-1301 or visit
#      their web page on the internet at
#      http://www.gnu.org/copyleft/gpl.html.
# 
#   b) Version 1 of Perl's "Artistic License".  You should have received
#      a copy of the Artistic License with this package, in the file
#      named "ARTISTIC".  The license is also available at
#      http://opensource.org/licenses/artistic-license.php.
# 
# This work is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
# 
# CONTRIBUTION SUBMISSION POLICY:
# 
# (The following paragraph is not intended to limit the rights granted
# to you to modify and distribute this software under the terms of the
# GNU General Public License and is only of importance to you if you
# choose to contribute your changes and enhancements to the community
# by submitting them to Best Practical Solutions, LLC.)
# 
# By intentionally submitting any modifications, corrections or
# derivatives to this work, or any other work intended for use with SVK,
# to Best Practical Solutions, LLC, you confirm that you are the
# copyright holder for those contributions and you grant Best Practical
# Solutions, LLC a nonexclusive, worldwide, irrevocable, royalty-free,
# perpetual, license to use, copy, create derivative works based on
# those contributions, and sublicense and distribute those contributions
# and any derivatives thereof.
# 
# END BPS TAGGED BLOCK }}}
package SVK::Config;
use strict;
use SVK::Version;  our $VERSION = $SVK::VERSION;

use base 'Class::Data::Inheritable';

__PACKAGE__->mk_classdata('_svnconfig');
__PACKAGE__->mk_classdata('auth_providers');

# XXX: this is 1.3 api. use SVN::Auth::* for 1.4 and we don't have to load ::Client anymore
# (well, fix svn perl bindings to wrap the prompt functions correctly first.
require SVN::Client;
__PACKAGE__->auth_providers(
    sub {
	my $keychain = SVN::_Core->can('svn_auth_get_keychain_simple_provider');
	my $win32 = SVN::_Core->can('svn_auth_get_windows_simple_provider');
        [
	    $keychain ? $keychain : (),
	    $win32    ? $win32    : (),
            SVN::Client::get_simple_provider(),
            SVN::Client::get_ssl_server_trust_file_provider(),
            SVN::Client::get_username_provider(),
            SVN::Client::get_simple_prompt_provider( \&_simple_prompt, 2 ),
            SVN::Client::get_ssl_server_trust_prompt_provider(
                \&_ssl_server_trust_prompt
            ),
            SVN::Client::get_ssl_client_cert_prompt_provider(
                \&_ssl_client_cert_prompt, 2
            ),
            SVN::Client::get_ssl_client_cert_pw_prompt_provider(
                \&_ssl_client_cert_pw_prompt, 2
            ),
            SVN::Client::get_username_prompt_provider( \&_username_prompt, 2 ),
        ];
    }
);

my $pool = SVN::Pool->new;

sub svnconfig {
    my $class = shift;
    return $class->_svnconfig if $class->_svnconfig;

    return undef if $ENV{SVKNOSVNCONFIG};

    SVN::Core::config_ensure(undef);
    return $class->_svnconfig( SVN::Core::config_get_config(undef, $pool) );
}

# Note: Use a proper default pool when calling get_auth_providers
sub get_auth_providers {
    my $class = shift;
    return $class->auth_providers->();
}

use constant OK => $SVN::_Core::SVN_NO_ERROR;

# Implement auth callbacks
sub _simple_prompt {
    my ($cred, $realm, $default_username, $may_save, $pool) = @_;

    if (defined $default_username and length $default_username) {
        print "Authentication realm: $realm\n" if defined $realm and length $realm;
        $cred->username($default_username);
    }
    else {
        _username_prompt($cred, $realm, $may_save, $pool);
    }

    $cred->password(_read_password("Password for '" . $cred->username . "': "));
    $cred->may_save($may_save);

    return OK;
}

sub _ssl_server_trust_prompt {
    my ($cred, $realm, $failures, $cert_info, $may_save, $pool) = @_;

    print "Error validating server certificate for '$realm':\n";

    print " - The certificate is not issued by a trusted authority. Use the\n",
          "   fingerprint to validate the certificate manually!\n"
      if ($failures & $SVN::Auth::SSL::UNKNOWNCA);

    print " - The certificate hostname does not match.\n"
      if ($failures & $SVN::Auth::SSL::CNMISMATCH);

    print " - The certificate is not yet valid.\n"
      if ($failures & $SVN::Auth::SSL::NOTYETVALID);

    print " - The certificate has expired.\n"
      if ($failures & $SVN::Auth::SSL::EXPIRED);

    print " - The certificate has an unknown error.\n"
      if ($failures & $SVN::Auth::SSL::OTHER);

    printf(
        "Certificate information:\n".
        " - Hostname: %s\n".
        " - Valid: from %s until %s\n".
        " - Issuer: %s\n".
        " - Fingerprint: %s\n",
        map $cert_info->$_, qw(hostname valid_from valid_until issuer_dname fingerprint)
    );

    print(
        $may_save
            ? "(R)eject, accept (t)emporarily or accept (p)ermanently? "
            : "(R)eject or accept (t)emporarily? "
    );

    my $choice = lc(substr(<STDIN> || 'R', 0, 1));

    if ($choice eq 't') {
        $cred->may_save(0);
        $cred->accepted_failures($failures);
    }
    elsif ($may_save and $choice eq 'p') {
        $cred->may_save(1);
        $cred->accepted_failures($failures);
    }

    return OK;
}

sub _ssl_client_cert_prompt {
    my ($cred, $realm, $may_save, $pool) = @_;

    print "Client certificate filename: ";
    chomp(my $filename = <STDIN>);
    $cred->cert_file($filename);

    return OK;
}

sub _ssl_client_cert_pw_prompt {
    my ($cred, $realm, $may_save, $pool) = @_;

    $cred->password(_read_password("Passphrase for '%s': "));

    return OK;
}

sub _username_prompt {
    my ($cred, $realm, $may_save, $pool) = @_;

    print "Authentication realm: $realm\n" if defined $realm and length $realm;
    print "Username: ";
    chomp(my $username = <STDIN>);
    $username = '' unless defined $username;

    $cred->username($username);

    return OK;
}

sub _read_password {
    my ($prompt) = @_;

    print $prompt;

    require Term::ReadKey;
    Term::ReadKey::ReadMode('noecho');

    my $password = '';
    while (defined(my $key = Term::ReadKey::ReadKey(0))) {
        last if $key =~ /[\012\015]/;
        $password .= $key;
    }

    Term::ReadKey::ReadMode('restore');
    print "\n";

    return $password;
}


1;