view release on metacpan or  search on metacpan

script/mediapi  view on Meta::CPAN

#!/usr/bin/perl

use strict;
use warnings;
use utf8;

use lib '/usr/local/lib/perl5';  # To be used together with the cpanm command given in the README.md file.

BEGIN {
  $ENV{DISPLAY} //= ':0';
}

use IPC::Run;
use Tkx;
use X11::Protocol;

$| = 1;  # auto-flush

my ($screen_x, $screen_y);
{
  my $X = X11::Protocol->new();
  $screen_x = $X->{screens}[0]{width_in_pixels} // 320;
  $screen_y = $X->{screens}[0]{height_in_pixels} // 240;
}

open my $pigpio, '>', '/dev/pigpio';

my $wnd = Tkx::widget->new('.');

# fullscreen removes the border of the window but does not actually make it
# fullscreen (maybe because we don’t have a real window manager... which also
# means that we don’t have a border anyway).
$wnd->g_wm_attribute(-fullscreen => 1, -topmost => 1);
$wnd->g_wm_resizable(0, 0);
$wnd->configure(-cursor => 'none');
$wnd->g_wm_geometry("${screen_x}x${screen_y}");

my $media_control_frame = $wnd->new_ttk__frame(-borderwidth => 5); # The border is here only to debug
$media_control_frame->g_grid(-column => 0, -row => 0, -sticky => 'nswe');
$wnd->g_grid_columnconfigure(0, -weight => 1);
$wnd->g_grid_rowconfigure(0, -weight => 1);

# The default font does not have the media control glyphs. So let’s create a
# style using Unifont that has almost all glyphs.
# Useful link: https://en.wikipedia.org/wiki/Media_control_symbols
Tkx::ttk__style_configure('Unicode.TButton', -font => 'Unifont 15');

$media_control_frame->g_grid_columnconfigure(0, -weight => 1);
$media_control_frame->g_grid_columnconfigure(1, -weight => 1);
$media_control_frame->g_grid_rowconfigure(0, -weight => 1);
$media_control_frame->g_grid_rowconfigure(1, -weight => 1);

my $vlc_in;
my $vlc_out;
# my $vlc = IPC::Run::start ['vlc', '--intf', 'rc', '--alsa-audio-device', 'dac'], $vlc_in;
my $vlc = IPC::Run::start ['vlc', '--intf', 'rc'], $vlc_in, \$vlc_out;

$vlc_in = '';
$vlc_out = '';

# It’s unclear what is the default volume and what is the real max level that can
# be set. So, for now, we do nothing.

my $cmd_sent = 0;
my $cmd_read = 0;
my %cmd_cb;

sub send_cmd {
  my ($cmd, $sub) = @_;
  if ($cmd_read < $cmd_sent) {
    # In theory we could send multiple command. Unfortunately, in practice, VLC
    # will sometime answer with multiple answers in a row, without the
    # separating carret. So let’s slow down.
    Tkx::after('idle', sub { send_cmd($cmd, $sub) });
    return;
  }
  $vlc_in .= $cmd."\n" if defined $cmd;
  $cmd_sent++;
  print "Sending command ${cmd_sent}\n";
  if (defined $sub) {
    $cmd_cb{$cmd_sent} = $sub;
  }
  pump_vlc_in();
}

sub pump_vlc_in {
  print "pumping: $vlc_in\n";
  IPC::Run::pump $vlc if length $vlc_in;
  print "pump! ($vlc_in)\n";
  if (length $vlc_in) {
    Tkx::after('idle', \&pump_vlc_in);
  } else {
    pump_vlc_out();
  }
}

sub pump_vlc_out {
  IPC::Run::pump_nb $vlc;
  print "pumping (read): -->${vlc_out}<--\n";
  if ($vlc_out =~ m/^> /m) {
    $cmd_read++;
    my $cmd_out = substr $vlc_out, 0, $-[0];
    substr $vlc_out, 0, $+[0], '';
    print "Read command output (${cmd_read})\n";
    if (my $cb = delete $cmd_cb{$cmd_read}) {
      $cb->($cmd_out);
    }
  }
  Tkx::after('idle', \&pump_vlc_out) if $cmd_read < $cmd_sent;
}

script/mediapi  view on Meta::CPAN

        system('sudo shutdown now');
      }
    }
  } else {
    $is_playing = 0;
    refresh_status_data();
  }
}

sub read_track_info {
  my ($info) = @_;
  if ($info =~ m/track_number: (\d+)/) {
    $track_nb = $1;
    print "track_nb: '${track_nb}'\n";
  } else {
    undef $track_nb;
  }
  if ($info =~ m/track_total: (\d+)/) {
    $track_total = $1;
    print "track_total: '${track_total}'\n";
  } else {
    undef $track_total;
  }
}

sub read_track_length {
  my ($data) = @_;
  if ($data =~ m/(\d+)/) {
    $track_length = $1;
  } else {
    undef $track_length;
  }
  print "track_length: '${track_length}'\n";
}

sub read_track_time {
  my ($data) = @_;
  if ($data =~ m/(\d+)/) {
    $track_time = $1;
  } else {
    undef $track_time;
  }
  print "track_time: '${track_time}'\n";
  # This is not necessarily the last of our callback, but if it isn’t it’s not
  # a big deal.
  refresh_status_data();
}

sub refresh_status_data {
  if (!$is_playing) {
    $track_status = 'not playing';
  } else {
    $track_status = sprintf 'track %s/%s, time %s / %s', 
        ($track_nb // '??'), ($track_total // '??'),
        (defined $track_time ? sprintf('%d:%02d', $track_time / 60, $track_time % 60) : '??'),
        (defined $track_length ? sprintf('%d:%02d', $track_length / 60, $track_length % 60) : '??'),
  }
  Tkx::after(200, \&get_status);
}

my $play_btn = $media_control_frame->new_ttk__button(-text => '⏵', -style => 'Unicode.TButton', -command => sub { send_cmd('add cdda:///dev/cdrom') });
$play_btn->g_grid(-column => 0, -row => 0, -sticky => 'nswe', -padx => 10, -pady => 10);
my $pause_btn = $media_control_frame->new_ttk__button(-text => '⏸', -style => 'Unicode.TButton',
                                                      -command => sub { send_cmd('pause') });
$pause_btn->g_grid(-column => 1, -row => 0, -sticky => 'nswe', -padx => 10, -pady => 10);
my $prev_btn = $media_control_frame->new_ttk__button(-text => '⏮', -style => 'Unicode.TButton',
                                                     -command => sub { send_cmd('prev') });
$prev_btn->g_grid(-column => 0, -row => 1, -sticky => 'nswe', -padx => 10, -pady => 10);
my $next_btn = $media_control_frame->new_ttk__button(-text => '⏭', -style => 'Unicode.TButton',
                                                     -command => sub { send_cmd('next') });
$next_btn->g_grid(-column => 1, -row => 1, -sticky => 'nswe', -padx => 10, -pady => 10);
my $status_label = $media_control_frame->new_ttk__label(-textvariable => \$track_status, -anchor => 'center');
$status_label->g_grid(-column => 0, -columnspan => 2, -row => 2, -sticky => 'nswe');

# This remove the focus and "active" decoration of the button when they are selected.
# We might want some kind of feedback that they were selected though.
Tkx::bind('TButton', '<FocusIn>', [sub { $wnd->g_focus(); Tkx::widget->new($_[0])->state('!active'); }, Tkx::Ev('%W')]);

# The commands are documented at https://abyz.me.uk/rpi/pigpio/pigs.html
# For now we don’t have a gpio for that as 18 is used by the I2S audio, we need
# to route another one to that pin on the screen.
# syswrite $pigpio, "w 18 1\n";  # Switch on the backlight of the screen.

#Tkx::bind('.', '<Create>', sub {
Tkx::after('idle', sub {
  send_cmd();  # Used to read the greeting message until the first caret >.
  get_status();
});
print "Starting main loop\n";
Tkx::MainLoop();