File Coverage

blib/lib/Cron/Sequencer/CLI.pm

Criterion	Covered	Total	%
statement	128	129	99.2
branch	57	58	98.2
condition	20	20	100.0
subroutine	8	8	100.0
pod	0	2	0.0
total	213	217	98.1

#!perl

use v5.20.0;
use warnings;

# The parts of this that we use have been stable and unchanged since v5.20.0:
use feature qw(postderef);
no warnings 'experimental::postderef';


use parent qw(Exporter);
require DateTime;
require DateTime::Format::ISO8601;
use Getopt::Long qw(GetOptionsFromArray);

our $VERSION = '0.05';
our @EXPORT_OK = qw(calculate_start_end parse_argv);

my %known_json = map { $_, 1 } qw(seq split pretty canonical);

    my ($pod2usage, @argv) = @_;

    my @groups;
    my $current = [];
    my $json;

    # Split the command line into sections:
    for my $item (@argv) {
        if ($item eq '--') {
            push @groups, $current;
            $current = [];
        } elsif ($item =~ /\A--json(?:=(.*)|)\z/s && !@groups) {
            # GetOpt::Long doesn't appear to have a way to specify to specify an
            # option that can take an argument, but it so, the argument must be
            # given in the '=' form.
            # We'd like to support `--json` and `--json=pretty` but have
            # `--json pretty` mean the same as `./pretty --json`

            if (length $1) {
                for my $opt (split ',', $1) {
                    $pod2usage->(exitval => 255,
                                 message => "Unknown --json option '$opt'")
                        unless $known_json{$opt};
                    $json->{$opt} = 1;
                }
                $pod2usage->(exitval => 255,
                             message => "Can't use --json=seq with --json=split")
                    if $json->{seq} && $json->{split};
            } else {
                # Flag that we saw --json
                $json //= {};
            }
        } else {
            push @$current, $item;
        }
    }
    push @groups, $current;

    my %global_options = (
        group => 1,
    );

    Getopt::Long::Configure('pass_through', 'auto_version', 'auto_help');
    unless(GetOptionsFromArray($groups[0], \%global_options,
                               'show=s',
                               'from=s',
                               'to=s',
                               'hide-env',
                               'group!',
                           )) {
        $pod2usage->(exitval => 255, verbose => 1);
    }

    my ($start, $end) = calculate_start_end(\%global_options);

    my @input;

    Getopt::Long::Configure('no_pass_through', 'no_auto_version');
    for my $group (@groups) {
        my %options;
        unless(GetOptionsFromArray($group, \%options,
                                   'env=s@',
                                   'ignore=s@'
                               )) {
            $pod2usage->(exitval => 255, verbose => 1);
        }
        $pod2usage->(exitval => 255,
                     message => "--env and --hide-env options can't be used together")
            if $global_options{'hide-env'} && $options{env};

        push @input, map {{ source => $_, %options{qw(env ignore)} }} @$group;
    }

    $pod2usage->(exitval => 255)
        unless @input;

    my $output = [%global_options{qw(hide-env group)}, count => scalar @input];

    push @$output, json => $json
        if $json;

    return ($start, $end, $output, @input);
}

    my $options = shift;

    my ($start, $end);

    if (defined $options->{from} || defined $options->{to}) {
        die "$0: Can't use --show with --from or --to\n"
            if defined $options->{show};

        # Default is midnight gone
        my $from = $options->{from} // '+0';
        if ($from =~ /\A[1-9][0-9]*\z/) {
            # Absolute epoch seconds
            $start = $from;
        } elsif ($from =~ /\A[-+](?:0|[1-9][0-9]*)\z/) {
            # Seconds relative to midnight gone
            $start = DateTime->today()->epoch() + $from;
        } else {
            my $line;
            eval {
                $line = __LINE__ + 1;
                $start = DateTime::Format::ISO8601->parse_datetime($from)->epoch();
            };
            unless (defined $start) {
                # Seems that we can't override DateTime::Format::ISO8601 on_fail
                # *cleanly*. DateTime::Format::Builder on_fail is trying to use
                # $Carp::CarpLevel to keep itself and its calls to
                # DateTime::Format::Builder::Parser out of the backtrace, but it
                # and Carp don't quite agree on the right number to use, with
                # the unfortunate result that it triggers a full backtrace
                # (effectively croak turns into confess, because Carp runs out
                # of call stack before $Carp::CarpLevel is exhausted. No, I
                # didn't know that it did this. "Today I Learned")

                # I don't want to confuse the user with a backtrace. This seems
                # like the simplest solution.

                my $message = $@;
                my $file = quotemeta __FILE__;
                $message =~ s/ at $file line $line.*//s;
                die "$0: Can't parse --from: $message\n";
            }
        }

        # Default is to show 1 hour
        my $to = $options->{to} // '+3600';
        if ($to =~ /\A[1-9][0-9]+\z/) {
            # Absolute epoch seconds
            $end = $to;
        } elsif ($to =~ /\A\+[1-9][0-9]*\z/) {
            # Seconds relative to from
            # As $end >= $start, '+0' doesn't make sense
            $end = $start + $to;
        } else {
            my $line;
            eval {
                $line = __LINE__ + 1;
                $end = DateTime::Format::ISO8601->parse_datetime($to)->epoch();
            };
            unless (defined $end) {
                my $message = $@;
                my $file = quotemeta __FILE__;
                $message =~ s/ at $file line $line.*//s;
                die "$0: Can't parse --to: $message\n";
            }
        }

        die "$0: End $end must be after start $start (--from=$from --to=$to)\n"
            if $end <= $start;
    } else {
        my $show = $options->{show} // 'today';
        if ($show =~ /\A\s*(last|this|next)\s+(minute|hour|day|week)\s*\z/) {
            my $which = $1;
            my $what = $2;
            my $start_of_period = DateTime->now()->truncate(to => $what);
            if ($which eq 'last') {
                $end = $start_of_period->epoch();
                $start_of_period->subtract($what . 's' => 1);
                $start = $start_of_period->epoch();
            } else {
                $start_of_period->add($what . 's' => 1)
                    if $which eq 'next';
                $start = $start_of_period->epoch();
                $start_of_period->add($what . 's' => 1);
                $end = $start_of_period->epoch();
            }
        } elsif ($show =~ /\A\s*(last|next)\s+([1-9][0-9]*)\s+(minute|hour|day|week)s\s*\z/) {
            my $which = $1;
            my $count = $2;
            my $what = $3;

            # I was going to name this $now, but then realised that if I add or
            # subtract on it, it won't be very "now" any more...
            my $aargh_mutable = DateTime->now();

            if ($which eq 'last') {
                $end = $aargh_mutable->epoch();
                $aargh_mutable->subtract($what . 's' => $count);
                $start = $aargh_mutable->epoch();
            } else {
                $start= $aargh_mutable->epoch();
                $aargh_mutable->add($what . 's' => $count);
                $end = $aargh_mutable->epoch();
            }
        } elsif ($show =~ /\A\s*yesterday\s*\z/) {
            my $midnight = DateTime->today();
            $end = $midnight->epoch();
            $midnight->subtract(days => 1);
            $start = $midnight->epoch();
        } elsif ($show =~ /\A\s*(today|tomorrow)\s*\z/) {
            my $midnight = DateTime->today();
            $midnight->add(days => 1)
                if $1 eq 'tomorrow';
            $start = $midnight->epoch();
            $midnight->add(days => 1);
            $end = $midnight->epoch();
        } elsif ($show =~ /\A(?:last|this|next)\z/) {
            die "$0: Unknown time period '$show' for --show (did you forget to escape the space after it?)\n";
        } else {
            my ($line, $midnight);
            eval {
                $line = __LINE__ + 1;
                $midnight = DateTime::Format::ISO8601->parse_datetime($show)->truncate(to => 'day');
            };
            unless (defined $midnight) {
                my $message = $@;
                my $file = quotemeta __FILE__;
                $message =~ s/ at $file line $line.*//s;
                die "$0: Can't parse --show: $message\n";
            }
            $start = $midnight->epoch();
            $midnight->add(days => 1);
            $end = $midnight->epoch();
        }
    }

    return ($start, $end);
}

=head1 NAME

Cron::Sequencer::CLI

=head1 SYNOPSIS

This module exists to make it easy to test the command line option parsing
of L<bin/cron-sequencer>. It's for "internal use only", and subject to change
(or deletion) without warning.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself. If you would like to contribute documentation,
features, bug fixes, or anything else then please raise an issue / pull request:

    https://github.com/Humanstate/cron-sequencer

=head1 AUTHOR

Nicholas Clark - C<[e-mail]>

=cut

1;