package App::SysVRcConf::LSB;

use strict;
use List::Util qw(first any none);
use base 'Exporter';
use vars qw( $VERSION );

our @EXPORT = qw(new);

=head1 NAME

App::SysVRcConf::LSB - Process init script LSB headers

=head1 SYNOPSIS

    use App::SysVRcConf::LSB;
    my $lsb = App::SysVRcConf->new(
        root    => '/',
        initd   => '/etc/init.d/',
    );
    my $lsb_headers = $lsb->get_headers();
    my $lsb_info = $lsb->parse_headers($lsb_headers);

=head1 DESCRIPTION

App::SysVRcConf::LSB reads and parses LSB header information in init scripts.

This module is an internal implementation detail of sysv-rc-conf.

=cut

my $R_block_begin = qr/^### BEGIN INIT INFO\s*$/;
my $R_block_end = qr/^### END INIT INFO\s*$/;
my $R_keyword = qr/^# ([^:[:space:]]+):\s*(.*?)\s*$/;
my $R_continuation = qr/^#(?: {2,}|\t+)\s*(.+?)\s*$/;
my $R_padding = qr/^#\s*$/;

my $S_IDLE = 0;
my $S_LSB = 1;
my $S_MULTILINE = 2;

my @long_keywords = qw(Description);
my @terminal_states = ($S_IDLE);

my @SS_A = ($S_IDLE, $S_LSB, $S_MULTILINE);
my @SS_L = ($S_LSB, $S_MULTILINE);  # States where the LSB patterns have meaning

# Each event is defined as:
#   ( Mnemonic, Pattern,  Exists-in states, Valid-in states,
#     Action subroutine returning next state)
my @mealy_machine = (
    ["Beg", $R_block_begin,  \@SS_A, [$S_IDLE],              sub {
        my $regs = shift; my $state = shift;
        $regs->{'blocks'}++;
        return $S_LSB }],
    ["End", $R_block_end,    \@SS_L, [$S_LSB, $S_MULTILINE], sub {
        return $S_IDLE }],
    ["Key", $R_keyword,      \@SS_L, [$S_LSB, $S_MULTILINE], sub {
        my $regs = shift; my $state = shift;
        $regs->{'keywords'}->{$1} = $2;
        $regs->{'lastkey'} = $1;
        return (any { $_ eq $1 } @long_keywords) ? $S_MULTILINE : $S_LSB }],
    ["Cnt", $R_continuation, \@SS_L, [$S_MULTILINE],         sub {
        my $regs = shift; my $state = shift;
        $regs->{'keywords'}->{$regs->{'lastkey'}} .= " " . $1;
        return $state }],
    ["Pad", $R_padding,      \@SS_L, [$S_LSB, $S_MULTILINE],   sub {
        return $2 }],
);

sub new {
    my $class = shift;
    my %config = @_;
    my %valid_params = map { $_ => 1 } qw(root initd ignore_errors);
    my @invalid_params = grep { not defined $valid_params{$_} } (keys %config);
    die "LSB::new(): Invalid parameters: ".join(',', @invalid_params) if @invalid_params;

    $config{root} //= "/";
    $config{initd} //= "$config{root}etc/init.d/";

    my $self = { cfg => \%config };
    return bless $self, $class;
}

sub read_headers($) {
    my $self = shift;
    my $file = shift;
    my $fh;
    my $state = $S_IDLE;
    my %regs = (
        'keywords' => {},
        'blocks' => 0,
        'lastkey' => undef,
        'errors' => [],
    );
    return undef if (! -r "$file");

    open ($fh, "<", $file) or die "open($file): $!";
    while (<$fh>) {
        my $line = $_;
        my $event = first { $line =~ /@{$_}[1]/ && any { $_ == $state } @{@{$_}[2]} } @mealy_machine or next;
        my ($name, $pattern, $exists_states, $valid_states, $action) = @$event;

        if (none { $_ == $state } @$valid_states) {
            push @{$regs{'errors'}}, (sprintf("LSB parsing error: %s not expected in state %d at %s:%d: %s\n",
                                      $name, $state, $file, $fh->input_line_number, $line));
            last;
        }
        $state = $action->(\%regs, $state, $line =~ /$pattern/);
    }

    # Validation
    if ($regs{'blocks'} > 1) {
        push @{$regs{'errors'}}, sprintf("Too many (%d) LSB blocks defined in %s\n",
                                         $regs{'blocks'}, $file);
    }
    if (none { $_ == $state } @terminal_states) {
        push @{$regs{'errors'}}, sprintf("Not in a terminal state (%d) at EOF in %s\n",
                                         $state, $file);
    }

    close $fh;

    if (scalar @{$regs{'errors'}}) {
        print STDERR ((join '\n', (map { "LSB header parsing error: $_" } (@{$regs{'errors'}}))));
        return undef unless $self->{cfg}->{ignore_errors};
    }
    return $regs{'blocks'} ? $regs{'keywords'} : undef;
}

sub get_headers($) {
    my $self = shift;
    my $service = shift;
    my $cfg = $self->{cfg};

    return
      $self->read_headers("$cfg->{root}etc/insserv/overrides/$service") ||
      $self->read_headers("$cfg->{initd}$service");
}

sub parse_headers($) {
    my $self = shift;
    my $keywords = shift;
    my %info = ();

    foreach (keys %$keywords) {
	if (/^(Short-)?Description$/) {
	    $info{$_} = $keywords->{$_};
	} else {
	    $info{$_} = [ split(/ /, $keywords->{$_}) ];
	}
    }
    return \%info;
}

=head1 AUTHOR

Andrew Bower C<< <andrew@bower.uk> >>

=cut

1;
