#!/usr/bin/env perl

use v5.24;

use utf8;
use strict;
use warnings;

use Data::Dumper;
use DateTime;
use Getopt::Long qw(:config bundling);
use Time::HiRes qw(gettimeofday usleep);
use Pod::Usage;
use POSIX::strptime;

use constant {
    KIOCSOUND => 0x4B2F,
    CLOCK_CYCLE => 1_193_180,
    PAUSE_FACTOR => 1_000,
};

use feature qw(signatures);
no warnings qw(experimental::signatures);

my $options = {
    quiet => !-t STDOUT,
    start => undef,
    tty => '/dev/tty0',
};

#------------------------------------------------------------------------------

sub sound_start($freq) {
    ioctl TTY, KIOCSOUND, (CLOCK_CYCLE / $freq);
}

sub sound_stop {
    ioctl TTY, KIOCSOUND, 0;
}

sub play_for($len, $freq) {
    if ($options->{debug}) {
        print "playing $freq Hz for $len ms\n";
    }

    sound_start($freq);
    usleep($len * PAUSE_FACTOR);
    sound_stop;
}

sub wait_for($len) {
    if ($options->{debug}) {
        print "waiting for $len ms\n";
    }

    usleep($len * PAUSE_FACTOR);
}

sub abort_play {
    sound_stop;
    die $!;
}

#--  Duration based input -----------------------------------------------------

sub parse_duration {
    my $track = [];

    while (my $in = <>) {
        chomp $in;
        if ($in !~ /^\s*(?<len>\d+)\s*(?<freq>\d+)?\s*$/) {
            warn "invalid spec '$in'";
            next;
        }

        push @$track, { %+{qw(len freq)} };
    }

    return $track;
}

sub run_duration($track) {
    foreach my $s (@$track) {
        if (!$s->{freq}) {
            wait_for($s->{len});
        } else {
            play_for($s->{len}, $s->{freq});
        }
    }
}

#--  Precise input ------------------------------------------------------------

sub parse_precise {
    my $track = [];

    while (my $in = <>) {
        chomp $in;
        if ($in !~ /^\s*(?<sec>\d+)\s*(?<usec>\d+)\s*(?<freq>\d+)?\s*$/) {
            warn "invalid spec '$in'";
            next;
        }

        my $e = { %+{qw(sec usec freq)} };
        $e->{stamp} = $e->{sec} * 1_000_000 + $e->{usec};

        push @$track, $e;
    }

    return $track;
}

sub stamp_diff($as, $aus, $bs, $bus) {
    return ($bs - $as) * 1_000_000 + ($bus - $aus);
}

sub run_precise($track) {
    my @start = gettimeofday;

    foreach my $e (@$track) {
        my @next = gettimeofday;
        my $curr = stamp_diff(@start, @next);

        if ($curr < $e->{stamp}) {
            my $delay = $e->{stamp} - $curr;

            print "waiting for $delay us\n"
                if $options->{debug};

            usleep($delay);
        } elsif ($options->{debug}) {
            my $delay = $curr - $e->{stamp};
            print "running late $delay us\n";
        }

        if ($e->{freq}) {
            sound_start($e->{freq});
        } else {
            sound_stop;
        }
    }

    sound_stop;
}

#------------------------------------------------------------------------------

sub wait_for_start($when) {
    my $epoch;

    if ($when =~ /^\d+$/) {
        $epoch = $when;
    } elsif (my @tspec = POSIX::strptime($when, '%Y-%m-%dT%H:%M:%S')) {
        my %dt;
        @dt{qw(year month day)} = @tspec[5, 4, 3];
        @dt{qw(hour minute second)} = @tspec[2, 1, 0];

        $dt{year} += 1900;
        $dt{month}++;

        $epoch = DateTime->new(%dt, time_zone => 'local')->epoch;
    } else {
        die "Invalid format for --start '$when'";
    }

    my ($cs, $cus) = gettimeofday;

    if ($cs > $epoch) {
        die "Start time '$when' has already passed"
            unless $options->{'allow-delay'};
        return;
    }

    printf "waiting %d seconds until start time\n", ($epoch - $cs)
        unless $options->{quiet};
    usleep(($epoch - $cs) * 1_000_000 - $cus);
    printf "current time is %d %d\n", gettimeofday;
}

#------------------------------------------------------------------------------

my $vmt = {
    precise => {
        parse => \&parse_precise,
        run => \&run_precise,
    },
    duration => {
        parse => \&parse_duration,
        run => \&run_duration,
    },
};

GetOptions($options, qw(h help tty|t=s debug duration|D precise|P start|s=s
        allow-delay))
    or pod2usage(-verbose => 1);

$options->{quiet} = 0
    if $options->{debug};

pod2usage(-exitval => 0, -verbose => 0) if $options->{h};
pod2usage(-exitval => 0, -verbose => 2) if $options->{help};

die "Options --duration and --precise are mutually exclusive"
    if $options->{duration} and $options->{precise};

die "$options->{tty} not found or is not a character device"
    unless -c $options->{tty};

open TTY, ">$options->{tty}"
    or die "open $options->{tty}: $!";

foreach my $signal (qw(HUP INT QUIT ABRT FPE PIPE ALRM TERM USR1 USR2)) {
    $SIG{$signal} = \&abort_play;
}

my $select = $options->{precise} ? 'precise' : 'duration';
my $dispatch = $vmt->{$select};

my $track = $dispatch->{parse}->();

wait_for_start($options->{start})
    if $options->{start};

$dispatch->{run}->($track);

close TTY;

#------------------------------------------------------------------------------

=head1 NAME

    beeplay -- beep play tunes with PC speaker

=head1 SYNOPSIS

    beeplay [OPTIONS] [FILE...]

Short description of options

    -h                      show brief help and exit
        --help              show Perl POD page and exit
        --debug             print debugging information

    -D  --duration          expect relative track format
    -P  --precise           expect precise (microsecond) track format

    -s  --start=DATETIME    delay the start to given datetime in ISO8601
        --allow-delay       do not croak when --start is in the past
    -t  --tty=TTY           use TTY instead of /dev/tty0

=head1 EXTENDED SYNOPSIS

Example:

    beeplay [--duration] <<EOF
    500 440
    300
    650 880
    EOF

=over

=item

play A1 (440 Hz) for 500 ms

=item

pause for 300 ms

=item

play A2 (880 Hz) for 650 ms

=back

The same example with the C<--precise> format
that supports microseconds:

    beeplay --precise <<EOF
    000 000000 440
    000 500000
    000 800000 880
    001 450000
    EOF

=over

=item

play A1 at 0s 0ms

=item

stop playing at 0s 500ms

=item

play A2 at 0s 800ms

=item

stop playing at 1s 450ms

=back

=head1 DESCRIPTION

C<beeplay> expects description of tunes to play on its standard input
or files specified as optional arguments.

=head2 Duration-based format

By default (or with the C<--duration>) option the program expects
each line to have either one or two non-negative integers:

    LENGTH FREQUENCY

The C<LENGTH> specified the length of the event in ms. The C<FREQUENCY>
specifies the frequency to play in Hz. If is missing or zero, no tune is
played, but the script pauses for the specified amount of time.

=head2 Precise format

With the C<--precise> option the input lines have the following format,
where two or three numbers are expected:

    SEC USEC FREQUENCY

C<SEC> and C<USEC> specify seconds and microseconds from the start
of the script. The C<FREQUENCY> has the same meaning as in the I<duration-based>
format. The difference is that there is no length of events, and therefore
events with non-zero C<FREQUENCY> start tones, whereas zero or missing
C<FREQUENCY> stops tones.

=head1 OPTIONS AND ARGUMENTS

=head2 Input format selectors

At most one of the following arguments is allowed:

=over

=item C<-D>, C<--duration>

Expect duration based file format.
I<This is the default.>

=item C<-P>, C<--precise>

Expect precise file format.

=back

=head2 Other options

=over

=item C<-h>

Show brief help and exit.

=item C<--help>

Show Perl POD page and exit.

=item C<-q>,C<--quiet>

=item C<--no-quiet>

Do not print remaining time.
Default if standard output is not a terminal, unless C<--no-quiet>
is specified.

=item C<--debug>

Print debugging information. Turns off C<--quiet>.

Note that this may cause slight delays if tunes are played very
fast (up to a hundred ms). Therefore this option should be avoided
with C<--duration> input if this script is used to play tunes
on multiple machines simultaneously.

=item C<-t>,C<--tty=TTY>

Open C<TTY> to send sound commands to instead of default C</dev/tty0>.

=item C<-s>,C<--start=(EPOCH|YYYY-MM-DDTHH:MM:SS)>

After parsing the input file, wait until C<EPOCH> seconds since
1970-01-01 00:00:00 (UTC).

Alternatively you may specify ISO 8601 date in local time zone,
in the format C<YYYY-MM-DDTHH:MM:SS>, e.g.

    2019-04-01T13:55:00

The start is scheduled with high resolution clock if supported.

=item C<--allow-delay>

If C<--start> refers to a time in the past, do not exit with error
and continue normally.

=item C<FILE...>

Read tunes from specified files instead of standard input.

=back

=head1 AUTHOR

    Roman Lacko <xlacko1@fi.muni.cz>
