File Coverage

blib/lib/Config/OpenSSH/Authkey/Entry/Options.pm

Criterion	Covered	Total	%
statement	87	87	100.0
branch	26	28	92.8
condition	6	14	42.8
subroutine	12	12	100.0
pod	9	9	100.0
total	140	150	93.3

# -*- Perl -*-
#
# Representation of authorized_keys entry options, either associated
# with a particular Config::OpenSSH::Authkey::Entry object, or
# standalone.

package Config::OpenSSH::Authkey::Entry::Options;

use strict;
use warnings;

use Carp qw/croak/;

our $VERSION = '1.04';

# Delved from sshd(8), auth-options.c of OpenSSH 5.2. Insensitive match
# required, as OpenSSH uses strncasecmp(3).
my $AUTHKEY_OPTION_NAME_RE = qr/(?i)[a-z0-9_-]+/;

######################################################################
#
# Class methods

sub new {
  my $class         = shift;
  my $option_string = shift;
  my $self          = { _options => [] };

  if ( defined $option_string ) {
    $self->{_options} =
      Config::OpenSSH::Authkey::Entry::Options->split_options($option_string);
  }

  bless $self, $class;
  return $self;
}

sub split_options {
  my $class         = shift;
  my $option_string = shift;
  my @options;

  # Inspected OpenSSH auth-options.c,v 1.44 to derive this lexer:
  #
  # In OpenSSH, unparsable options result in a call to bad_options and
  # the entry being rejected. This module is more permissive, in that
  # any option name is allowed, regardless of whether OpenSSH supports
  # such an option or whether the option is the correct type (boolean
  # vs. string value). This makes the module more future proof, at the
  # cost of allowing garbage through.
  #
  # Options are stored using a list of hashrefs, which allows for
  # duplicate options, and preserves the order of options. Also, an
  # index is maintained to speed lookups of the data, and to note if
  # duplicate options exist. This is due to inconsistent handling by
  # OpenSSH_5.1p1 of command="" vs. from="" vs. environment="" options
  # when multiple entries are present. Methods are offered to detect and
  # cleanup such (hopefully rare) duplicate options.

OPTION_LEXER: {
    # String Argument Options - value is a perhaps empty string enclosed
    # in double quotes. Internal double quotes are allowed, but only if
    # these are preceded by a backslash.
    if (
      $option_string =~ m/ \G ($AUTHKEY_OPTION_NAME_RE)="( (?: \\"|[^"] )*? )"
        (?:,|[ \t]+)? /cgx
      ) {
      my $option_name = $1;
      my $option_value = $2 || q{};

      push @options, { name => $option_name, value => $option_value };

      redo OPTION_LEXER;
    }

    # Boolean options - mere presence enables them in OpenSSH
    if (
      $option_string =~ m/ \G ($AUTHKEY_OPTION_NAME_RE) (?:,|[ \t]+)? /cgx ) {
      my $option_name = $1;

      push @options, { name => $option_name };

      redo OPTION_LEXER;
    }
  }

  return wantarray ? @options : \@options;
}

######################################################################
#
# Instance methods

sub parse {
  my $self          = shift;
  my $option_string = shift;

  $self->{_options} =
    Config::OpenSSH::Authkey::Entry::Options->split_options($option_string);
  return scalar @{ $self->{_options} };
}

sub as_string {
  my $self = shift;
  my @options;
  for my $options_ref ( @{ $self->{_options} } ) {
    if ( exists $options_ref->{value} ) {
      ( my $value = $options_ref->{value} ) =~ s/(?
      push @options, $options_ref->{name} . '="' . $value . '"';
    } else {
      push @options, $options_ref->{name};
    }
  }
  return join( q{,}, @options );
}

# NOTE - boolean return the name of the option, while string value
# options the string. This may change, depending on how I like how this
# is handled...
sub get_option {
  my $self = shift;
  my $option_name = shift || croak 'get_option requires an option name';

  my @values =
    map { $_->{value} || $option_name }
    grep { $_->{name} eq $option_name } @{ $self->{_options} };

  return wantarray ? @values : defined $values[0] ? $values[0] : '';
}

sub get_options {
  map { $_->{name} } @{ shift->{_options} };
}

# Sets an option. To enable a boolean option, only supply the option
# name, and pass no value data.
sub set_option {
  my $self         = shift;
  my $option_name  = shift || croak 'set_option requires an option name';
  my $option_value = shift;

  my $updated      = 0;
  my $record_count = @{ $self->{_options} };

  for my $options_ref ( @{ $self->{_options} } ) {
    if ( $options_ref->{name} eq $option_name ) {
      $options_ref->{value} = $option_value if defined $option_value;
      ++$updated;
    }
  }
  if ( $updated == 0 ) {
    push @{ $self->{_options} },
      {
      name => $option_name,
      ( defined $option_value ? ( value => $option_value ) : () )
      };
  } elsif ( $updated > 1 ) {
    # KLUGE edge-case where duplicate entries exist for this option. Clear
    # all duplicates beyond the first entry.
    my $seen = 0;
    @{ $self->{_options} } = grep {
           $_->{name} ne $option_name
        or $_->{name} eq $option_name
        && !$seen++
    } @{ $self->{_options} };
  }

  return $record_count - @{ $self->{_options} };
}

sub unset_option {
  my $self = shift;
  my $option_name = shift || croak 'unset_option requires an option name';

  my $record_count = @{ $self->{_options} };
  @{ $self->{_options} } =
    grep { $_->{name} ne $option_name } @{ $self->{_options} };

  return $record_count - @{ $self->{_options} };
}

sub unset_options {
  shift->{_options} = [];
  return 1;
}

1;

__END__