home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Key.pm < prev    next >
Encoding:
Perl POD Document  |  2001-07-11  |  7.3 KB  |  245 lines
  1. # $Id: Key.pm,v 1.19 2001/07/11 21:57:26 btrott Exp $
  2.  
  3. package Net::SSH::Perl::Key;
  4. use strict;
  5.  
  6. use Digest::MD5 qw( md5 );
  7. use Net::SSH::Perl::Buffer;
  8.  
  9. sub new {
  10.     my $class = shift;
  11.     if ($class eq __PACKAGE__) {
  12.         $class .= "::" . shift();
  13.         eval "use $class;";
  14.         die "Key class '$class' is unsupported: $@" if $@;
  15.     }
  16.     my $key = bless {}, $class;
  17.     $key->init(@_);
  18.     $key;
  19. }
  20.  
  21. use vars qw( %KEY_TYPES );
  22. %KEY_TYPES = (
  23.     'ssh-dss' => 'DSA',
  24.     'ssh-rsa' => 'RSA',
  25. );
  26.  
  27. sub new_from_blob {
  28.     my $class = shift;
  29.     my($blob) = @_;
  30.     my $b = Net::SSH::Perl::Buffer->new( MP => 'SSH1' );
  31.     $b->append($blob);
  32.     my $ssh_name = $b->get_str;
  33.     my $type = $KEY_TYPES{$ssh_name};
  34.     __PACKAGE__->new($type, @_);
  35. }
  36.  
  37. sub extract_public {
  38.     my $class = shift;
  39.     my($blob) = @_;
  40.     my($ssh_name, $data) = split /\s+/, $blob;
  41.     my $type = $KEY_TYPES{$ssh_name};
  42.     eval "use MIME::Base64";
  43.     die $@ if $@;
  44.     __PACKAGE__->new($type, decode_base64($data));
  45. }
  46.  
  47. BEGIN {
  48.     no strict 'refs';
  49.     for my $meth (qw( read_private keygen )) {
  50.         *$meth = sub {
  51.             my $class = shift;
  52.             if ($class eq __PACKAGE__) {
  53.                 $class .= "::" . shift();
  54.                 eval "use $class;";
  55.                 die "Key class '$class' is unsupported: $@" if $@;
  56.             }
  57.             $class->$meth(@_);
  58.         };
  59.     }
  60. }
  61.  
  62. use vars qw( %OBJ_MAP );
  63. %OBJ_MAP = (
  64.     'DSA PRIVATE KEY'  => [ 'DSA' ],
  65.     'SSH2 ENCRYPTED PRIVATE KEY' => [ 'DSA', [ 'SSH2' ] ],
  66.     'RSA PRIVATE KEY'  => [ 'RSA' ],
  67. );
  68.  
  69. sub read_private_pem {
  70.     my $class = shift;
  71.     my $keyfile = $_[0];
  72.     local *FH;
  73.     open FH, $keyfile or return;
  74.     chomp(my $desc = <FH>);
  75.     close FH;
  76.     return unless $desc;
  77.     my($object) = $desc =~ /^-----?\s?BEGIN ([^\n\-]+)\s?-?----$/;
  78.     $object =~ s/\s*$//;
  79.     my $rec = $OBJ_MAP{$object} or return;
  80.     $class = __PACKAGE__ . "::" . $rec->[0];
  81.     eval "use $class;";
  82.     die "Key class '$class' is unsupported: $@" if $@;
  83.     my @args = $rec->[1] ? @{ $rec->[1] } : ();
  84.     $class->read_private(@_, @args);
  85. }
  86.  
  87. sub init;
  88. sub extract_public;
  89. sub dump_public;
  90. sub as_blob;
  91. sub equal;
  92. sub size;
  93.  
  94. sub fingerprint {
  95.     my $key = shift;
  96.     my($type) = @_;
  97.     my $data = $key->fingerprint_raw;
  98.     $type && $type eq 'bubblebabble' ?
  99.         _fp_bubblebabble($data) : _fp_hex($data);
  100. }
  101.  
  102. sub _fp_bubblebabble {
  103.     eval "use Digest::BubbleBabble qw( bubblebabble )";
  104.     die "Can't load BubbleBabble implementation: $@" if $@;
  105.     eval "use Digest::SHA1 qw( sha1 )";
  106.     die "Can't load SHA1: $@" if $@;
  107.     bubblebabble( Digest => sha1($_[0]) )
  108. }
  109.  
  110. sub _fp_hex { join ':', map { sprintf "%02x", ord } split //, md5($_[0]) }
  111.  
  112. 1;
  113. __END__
  114.  
  115. =head1 NAME
  116.  
  117. Net::SSH::Perl::Key - Public or private key abstraction
  118.  
  119. =head1 SYNOPSIS
  120.  
  121.     use Net::SSH::Perl::Key;
  122.     my $key = Net::SSH::Perl::Key->new;
  123.  
  124. =head1 DESCRIPTION
  125.  
  126. I<Net::SSH::Perl::Key> implements an abstract base class interface
  127. to key objects (either DSA or RSA keys, currently). The underlying
  128. implementation for RSA is an internal, hash-reference implementation;
  129. the DSA implementation uses I<Crypt::DSA>.
  130.  
  131. =head1 USAGE
  132.  
  133. =head2 Net::SSH::Perl::Key->new($key_type [, $blob [, $compat_flag_ref ]])
  134.  
  135. Creates a new object of type I<Net::SSH::Perl::Key::$key_type>,
  136. after loading the class implementing I<$key_type>. I<$key_type>
  137. should be either C<DSA> or C<RSA1>, currently; these are the
  138. only supported key implementations at the moment.
  139.  
  140. I<$blob>, if present, should be a string representation of the key,
  141. from which the key object can be initialized. In fact, it should
  142. be the representation that is returned from the I<as_blob> method,
  143. below.
  144.  
  145. I<$compat_flag_ref> should be a reference to the SSH compatibility
  146. flag, which is generally stored inside of the I<Net::SSH::Perl>
  147. object. This flag is used by certain key implementations (C<DSA>)
  148. to work around differences between SSH2 protocol implementations.
  149.  
  150. Returns the new key object, which is blessed into the subclass.
  151.  
  152. =head2 Net::SSH::Perl::Key->read_private($key_type, $file [, $pass])
  153.  
  154. Reads a private key of type I<$key_type> out of the key file
  155. I<$file>. If the private key is encrypted, an attempt will be
  156. made to decrypt it using the passphrase I<$pass>; if I<$pass>
  157. is not provided, the empty string will be used. An empty
  158. passphrase can be a handy way of providing password-less access
  159. using publickey authentication.
  160.  
  161. If for any reason loading the key fails, returns I<undef>; most
  162. of the time, if loading the key fails, it's because the passphrase
  163. is incorrect. If you first tried to read the key using an empty
  164. passphrase, this might be a good time to ask the user for the
  165. actual passphrase. :)
  166.  
  167. Returns the new key object, which is blessed into the subclass
  168. denoted by I<$key_type> (either C<DSA> or C<RSA1>).
  169.  
  170. =head2 Net::SSH::Perl::Key->keygen($key_type, $bits)
  171.  
  172. Generates a new key and returns that key. The key returned is
  173. the private key, which (presumably) contains all of the public
  174. key data, as well. I<$bits> is the number of bits in the key.
  175.  
  176. Your I<$key_type> implementation may not support key generation;
  177. if not, calling this method is a fatal error.
  178.  
  179. Returns the new key object, which is blessed into the subclass
  180. denoted by I<$key_type> (either C<DSA> or C<RSA1>).
  181.  
  182. =head2 Net::SSH::Perl::Key->extract_public($key_type, $key_string)
  183.  
  184. Given a key string I<$key_string>, which should be a textual
  185. representation of the public portion of a key of I<$key_type>,
  186. extracts the key attributes out of that string. This is used to
  187. extract public keys out of entries in F<known_hosts> and public
  188. identity files.
  189.  
  190. Returns the new key object, which is blessed into the subclass
  191. denoted by I<$key_type> (either C<DSA> or C<RSA1>).
  192.  
  193. =head2 $key->write_private([ $file [, $pass] ])
  194.  
  195. Writes out the private key I<$key> to I<$file>, and encrypts
  196. it using the passphrase I<$pass>. If I<$pass> is not provided,
  197. the key is unencrypted, and the only security protection is
  198. through filesystem protections.
  199.  
  200. If I<$file> is not provided, returns the content that would
  201. have been written to the key file.
  202.  
  203. =head2 $key->dump_public
  204.  
  205. Performs the inverse of I<extract_public>: takes a key I<$key>
  206. and dumps out a textual representation of the public portion
  207. of the key. This is used when writing public key entries to
  208. F<known_hosts> and public identity files.
  209.  
  210. Returns the textual representation.
  211.  
  212. =head2 $key->as_blob
  213.  
  214. Returns a string representation of the public portion of the
  215. key; this is I<not> the same as I<dump_public>, which is
  216. intended to match the format used in F<known_hosts>, etc.
  217. The return value of I<as_blob> is used as an intermediary in
  218. computing other values: the key fingerprint, the known hosts
  219. representation, etc.
  220.  
  221. =head2 $key->equal($key2)
  222.  
  223. Returns true if the public portions of I<$key> are equal to
  224. those of I<$key2>, and false otherwise. This is used when
  225. comparing server host keys to keys in F<known_hosts>.
  226.  
  227. =head2 $key->size
  228.  
  229. Returns the size (in bits) of the key I<$key>.
  230.  
  231. =head2 $key->fingerprint([ I<$type> ])
  232.  
  233. Returns a fingerprint of I<$key>. The default fingerprint is
  234. a hex representation; if I<$type> is equal to C<bubblebabble>,
  235. the Bubble Babble representation of the fingerprint is used
  236. instead. The former uses an I<MD5> digest of the public key,
  237. and the latter uses a I<SHA-1> digest.
  238.  
  239. =head1 AUTHOR & COPYRIGHTS
  240.  
  241. Please see the Net::SSH::Perl manpage for author, copyright,
  242. and license information.
  243.  
  244. =cut
  245.