File Coverage

blib/lib/Crypt/SecretBuffer/PEM.pm

Criterion	Covered	Total	%
statement	110	115	95.6
branch	43	62	69.3
condition	12	24	50.0
subroutine	15	15	100.0
pod	9	9	100.0
total	189	225	84.0

package Crypt::SecretBuffer::PEM;
# VERSION
# ABSTRACT: Parse PEM format from a SecretBuffer
$Crypt::SecretBuffer::PEM::VERSION = '0.021';
use strict;
use warnings;
use Carp;
use Scalar::Util qw( blessed );
use Crypt::SecretBuffer qw/ secret span MATCH_NEGATE MATCH_REVERSE MATCH_ANCHORED MATCH_MULTI ISO8859_1 BASE64 /;


sub parse {
   my ($class, $span, %options)= @_;
   my $secret_headers= !!$options{secret_headers};
   my $notrim= !exists $options{trim_headers}? 0 : !$options{trim_headers};
   while (my $begin= $span->scan("-----BEGIN ")) {
      $span->pos($begin->lim);
      my $label= $span->parse(qr/[A-Z0-9 ]+/);
      next unless $label && $span->parse("-----\n");
      $begin->lim($span->pos);
      my $label_str= '';
      $label->copy_to($label_str);
      # back up the span by 1 char so that it starts with \n, just in case there is an END
      # line immediately following the BEGIN line.
      $span->pos($span->pos-1);
      my $end= $span->scan("\n-----END $label_str-----");
      unless ($end) {
         carp "PEM begin marker for $label_str lacks an END marker";
         next;
      }
      $end->ltrim("\n");
      $span->pos($end->lim);
      $span->ltrim("\r");
      $span->ltrim("\n"); # consume line ending

      # Let block be its own SecretBuffer
      my $block= $span->clone(pos => $begin->pos, lim => $span->pos)->copy;
      my $inner= $block->span(pos => $begin->len, lim => $end->pos - $begin->pos);
      if (!$block->span($end->pos - $begin->pos - 1, 1)->ends_with("\n")) {
         carp "PEM end marker found not at the start of a line";
         next;
      }
      # Treat each line containing a ":" as a "name: value" header
      my @headers;
      while (my $sep_or_eol= $inner->scan(qr/[:\n]/)) {
         if ($sep_or_eol->starts_with(':')) {
            my ($name, $value);
            my $name_span= $inner->clone(lim => $sep_or_eol->pos);
            $name_span->trim unless $notrim;
            $name_span->copy_to($name);
            $inner->pos($sep_or_eol->lim);
            my $eol= $inner->scan("\n") or die "BUG"; # inner ends with "\n", checked above
            my $val_span= $inner->clone(lim => $eol->pos);
            # notrim means don't remove arbitrary leading/trailing whitespace.
            # the space char after ':' is part of the specification, so should be removed.
            $notrim? $val_span->ltrim(' ') : $val_span->trim;
            $inner->pos($eol->lim);
            if ($secret_headers) {
               push @headers, $name, $val_span;
            } else {
               $val_span->copy_to($value);
               push @headers, $name, $value;
            }
         }
         else {
            # If any headers were found, there needs to be a blank line
            if (@headers) {
               if ($sep_or_eol->pos == $inner->pos) { # "\n" at start of 'inner'
                  $inner->pos($sep_or_eol->lim);
               } else {
                  carp "PEM headers for $label_str did not end with a blank line"
               }
            }
            last;
         }
      }
      $inner->encoding(BASE64);
      return $class->new(
         buffer => $block,
         label => $label_str,
         header_kv => \@headers,
         content => $inner,
      );
   }
   return undef;
}

sub parse_all {
   my ($class, $span, %options)= @_;
   my @pem;
   while (my $pem= $class->parse($span, %options)) {
      push @pem, $pem;
   }
   return @pem;
}

sub new {
   my $class= shift;
   my $self= bless {}, $class;
   while (@_) {
      my ($attr, $val)= splice(@_, 0, 2);
      $self->$attr($val);
   }
   $self;
}


sub buffer         { $_[0]{buffer}=  $_[1] if @_ > 1; $_[0]{buffer} }
sub label          { $_[0]{label}=   $_[1] if @_ > 1; $_[0]{label} }
sub content        { $_[0]{content}= $_[1] if @_ > 1; $_[0]{content} }
sub header_kv {
   if (@_ > 1) {
      _validate_header_kv($_[1]);
      $_[0]{header_kv}= $_[1];
      $_[0]{headers}->raw_kv_array($_[1])
         if defined $_[0]{headers};
   }
   $_[0]{header_kv}
}
sub headers {
   my $self= shift;
   require Crypt::SecretBuffer::PEM::Headers;
   $self->{headers} ||=
      Crypt::SecretBuffer::PEM::Headers
         ->new(raw_kv_array => $self->header_kv)
         ->_create_tied_hashref;
}

sub _validate_header_kv {
   my $kv= shift;
   croak "Expected even-length arrayref"
      unless ref $kv eq 'ARRAY' && ($#$kv & 1);
   for (0..($#$kv-1)/2) {
      my ($k, $v)= ($kv->[$_*2], $kv->[$_*2+1]);
      croak "PEM header Key is undefined"
         unless defined $k;
      croak "PEM Header name '$k' contains wide characters"
         unless utf8::downgrade($k, 1);
      # Sanity checks, key cannot contain control chars or ':' or leading or trailing whitespace
      croak "PEM Header name '$k' contains ':' or control characters"
         if $k =~ /[\0-\x1F\x7F:]/;
      carp "PEM header name '$k' contains leading/trailing whitespace"
         if $k =~ /^\s/ or $k =~ /\s\z/;
      croak "PEM header value for '$k' is undefined"
         unless defined $v;
      my $is_secret= blessed($v) && ($v->isa('Crypt::SecretBuffer::Span') || $v->isa('Crypt::SecretBuffer'));
      croak "PEM header value for $k' contains wide characters"
         unless $is_secret || utf8::downgrade($v, 1);
      croak "PEM header value for '$k' contains control characters"
         if $is_secret? ($v->scan(qr/[\0-\x1F\x7F]/))
                      : ($v =~ /[\0-\x1F\x7F]/);
      carp "PEM header value for '$k' contains leading/trailing whitespace"
         if $is_secret? ($v->scan(qr/[\s]/, MATCH_ANCHORED) or $v->scan(qr/[\s]/, MATCH_ANCHORED|MATCH_REVERSE))
                      : ($v =~ /^\s/ or $v =~ /\s\z/);
   }
   1;
}


sub serialize {
   my $self= shift;
   my $out= secret('-----BEGIN '.$self->label."-----\n");
   my @header_kv= @{ $self->header_kv || [] };
   if (@header_kv) {
      # re-validate since individual values are mutable and may have changed since the
      # attribute was assigned.
      _validate_header_kv(\@header_kv);
      for (0..$#header_kv) {
         $out->append($header_kv[$_])->append($_ & 1? "\n" : ": ");
      }
      $out->append("\n"); # empty line terminates headers
   }
   my $content_span= span($self->content);
   $content_span->append_to($out, encoding => BASE64);
   $out->append(($content_span->length? "\n" : '')
                .'-----END '.$self->label."-----\n");
   return $out;
}

# avoid depending on namespace::clean
delete @{Crypt::SecretBuffer::PEM::}{qw(
   carp confess croak blessed secret span MATCH_NEGATE MATCH_REVERSE MATCH_ANCHORED MATCH_MULTI
   ISO8859_1 BASE64
)};

1;

__END__