#!/usr/pkg/bin/perl # gus_netbsd_mixer.pl version 2005-02-10 # Copyright 2005 by Gan Uesli Starling # Program directly executes command: mixerctl -w foo=bar # See POD at EOF for full description. our $formal_name = 'GUS NetBSD Mixer'; our $formal_date = '2005-02-10'; use Tk; use Tk::Pane; use Tk::Balloon; use strict; use warnings; # Complains too much of ininitialized strings. use vars qw ( $debug_flag $feedback ); $debug_flag = 0; # Display excess details in console? print "\n\n\nNEW TRIAL RUN\n\n\n" if $debug_flag; # Start out with a hint to the user. $feedback = "Slide pot travel limitations (if any) derive from mixerctl itself."; ################### # Begin GUI stuff # ################### my $label_width = 20; my $entry_width = 50; # Colors for help info balloons and info message area. our $balloon_bg = 'darkseagreen'; our $balloon_fg = 'black'; # First declare the main GUI frame and all her daughters. my $mw = MainWindow->new( -title => " $formal_name" ); # Begin MENU BAR $mw->configure( -menu => my $menubar = $mw->Menu ); # At least one sunken frame above flat frame for buttons, etc. my $frame_top = $mw->Frame( -relief => 'sunken', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'both' ); my $frame_btm = $mw->Frame( -relief => 'flat', -borderwidth => 5 )->pack( -side => 'top', -expand => 0, -fill => 'x' ); my $pane = $frame_top->Scrolled( 'Pane', -scrollbars => 'osw', -sticky => 'new' )->pack( -side => 'top', -expand => 1, -fill => 'both' ); # Provide help info as balloon widgets. my $help_info = $frame_btm->Label( -borderwidth => 2, -relief => 'groove', -background => $balloon_bg, -foreground => $balloon_fg, )->pack( -side => 'top', -expand => 1, -fill => 'x' ); my $balloon = $mw->Balloon( -statusbar => $help_info, -balloonposition => 'mouse', -background => $balloon_bg, -foreground => $balloon_fg, ); $balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' ); # Begin MENU HELP my $menu_help = $menubar->cascade( -label => '~Help' ); $menu_help->command( -label => "About", -command => sub { GUS::help_about::start_MainLoop() } ); # Take up full width and half the height of the screen upon opening. # User may, of course, resize thereafter. $mw->geometry( $mw->screenwidth() . 'x' . $mw->screenheight() / 2 . '+0+0' ); ################################ # Begin non-template GUI stuff # ################################ # Another frame appart from that shared by input widget sets.R my $frame_2nd = $pane->Frame( -relief => 'flat', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' ); my @mixerctl_output = split "\n", `mixerctl -v -a`; foreach ( @mixerctl_output ) { if ( $_ =~ m/mute|preamp/ ) { extra_check($_) } elsif ( $_ =~ m/mute|preamp/ ) { extra($_) } elsif ( $_ =~ m/=[0-9]+ / ) { mono_scale($_) } elsif ( $_ =~ m/=[0-9]+,[0-9]+ / ) { stereo_scales($_) } elsif ( $_ =~ m/source=/ ) { source_checks($_) } } my $last_frame; sub adjust_widget { my ( $label, $setting ) = @_; my $os_reply = `mixerctl -w $label=$setting`; chop $os_reply; $feedback = $os_reply; $os_reply =~ s/.*-> //; return split /,/, $os_reply; } sub extra_check { $_ =~ s/\s+\[ off on ]//; my $label = my $setting = $_; $label =~ s/=.*//; my $abbrev = $label; $abbrev =~ s/.*\.//; $setting =~ s/.*=//; my $check = $last_frame->Checkbutton( -textvariable => \$abbrev, -width => 8, -onvalue => 'on', -offvalue => 'off', -variable => \$setting, -command => sub { adjust_widget( $label, $setting ) }, )->pack( -side => 'left', -expand => 0, -fill => 'x' ); } sub mono_scale { my $label = my $setting = my $delta = $_; $label =~ s/=.*//; $setting =~ s/[a-z|\.]+[mono|speaker|line|mic|cd|aux]+=//; $setting =~ s/ volume .*//; $delta =~ s/.*=//; my @scale = GUS::tk::frame_label_scale( $frame_2nd, $label, 0, 255, 1, 'horizontal' ); $scale[0]->configure( -relief => 'groove'); $scale[2]->set($setting); $scale[2]->configure( -command => sub { $scale[2]->set( adjust_widget( $label, $scale[2]->get() ) ) } ); GUS::tk::attach_baloons( $balloon, $scale[2], "Delta = $delta", "Delta for $label = $delta" ); $last_frame = $scale[0]; } sub stereo_scales { my $label = my $setting_1 = my $delta = $_; my $setting_2; $label =~ s/=.*//; $setting_1 =~ s/[a-z|\.]+[mono|speaker|line|mic|cd|aux]+=//; $setting_1 =~ s/ volume .*//; ( $setting_1, $setting_2 ) = split /,/, $setting_1; $delta =~ s/.*=//; my @scale = GUS::tk::frame_label_scale( $frame_2nd, $label, 0, 255, 1, 'horizontal' ); my $scale_2 = $scale[0]->Scale( -from => 0, -to => 255, -resolution => 1, -orient => 'horizontal' )->pack( -side => 'left', -expand => 1, -fill => 'x' ); $scale[2]->set($setting_1); $scale_2->set($setting_2); $scale[0]->configure( -relief => 'groove'); $scale[2]->configure( -command => sub { $setting_1 = $scale[2]->get(); $setting_2 = $scale_2->get(); ( $setting_1, $setting_2 ) = adjust_widget( $label, "$setting_1,$setting_2" ); $scale[2]->set($setting_1);; $scale_2->set($setting_2); } ); $scale_2->configure( -command => $scale[2]->cget(-command) ); GUS::tk::attach_baloons( $balloon, $scale[2], "Delta = $delta", "Delta for $label = $delta" ); GUS::tk::attach_baloons( $balloon, $scale_2, "Delta = $delta", "Delta for $label = $delta" ); $last_frame = $scale[0]; } # record.source=mic [ mic cd video aux line mixerout mixeroutmono phone ] sub source_checks { my $label = my $setting = my $sources = $_; $label =~ s/=.*//; $setting =~ s/.*=//; $setting =~ s/\s.*//; $sources =~ s/.*\[\s//; $sources =~ s/\s\]//; my @sources = split / /, $sources; # Make a row of radiobuttons. my @radio = GUS::tk::frame_label_radio( 12, $frame_2nd, "$label:", \@sources, \$setting, sub { adjust_widget( $label, $setting ) } ); $radio[0]->configure( -relief => 'groove'); } ################################ # End non-template GUI stuff # ################################ my @fdbk = GUS::tk::frame_label_entry( $frame_btm, 'mixerctl said:', \$feedback ); GUS::tk::attach_baloons( $balloon, $fdbk[2], 'mixerctl', "Feedback from NetBSD's mixerctl command shown in white textbox." ); MainLoop; # Give feedback message then do something... sub tell_then_do { my $pause = 100; # Default if no $_[2] $pause = $_[2] if $_[2]; $feedback = $_[0]; $mw->after( $pause, $_[1] ); } # Close down the Perl/Tk GUI sub quit_MainLoop { $mw->destroy() if Tk::Exists($mw); GUS::user_config::quit_MainLoop(); GUS::help_about::quit_MainLoop(); } ################### # End GUI stuff # ################### ################################################################################ ################################################################################ ## GUS PACKAGES -- CUSTOM SET ## ## FOR USE IN THIS PROGRAM ONLY ## ## REQUIRES INCLUSION OF GUS PACKAGES STANDARD SET ## ################################################################################ ################################################################################ ################################ # Begin GUS Tk widgets Package # # Subset excerpted 2005-02-10 # ################################ # A separate package for ease of re-use. package GUS::tk; use Tk; use Tk::Pane; use Tk::DirTree; use vars qw( $debug_flag $widget_id $label_width $entry_width $button_width $text_height $text_width $file_basename $feedback $color_bg $color_fg $color_bg_balloon $color_fg_balloon $color_bg_active $color_bg_inactive ); BEGIN { $debug_flag = 0; $widget_id = 0; $label_width = 12; $entry_width = 12; $button_width = 12; $main::file_basename = 'foo.txt' unless defined $main::file_basename; } use vars qw( %frame $dir_toplevel ); sub new_widget { $widget_id++; return $widget_id; } # Automate the build of a lable & entry wiget set inside GUS::tk frame. sub frame_label_entry { my ( $parent, $label_text, $text_var_ref ) = @_; my $tlw = $parent->toplevel(); my @widgets = (); push @widgets, $parent->Frame( -relief => 'flat', -borderwidth => 5, )->pack( -side => 'top', -expand => 1, -fill => 'x' ); push @widgets, $widgets[0]->Label( -width => $label_width, -text => " $label_text ", )->pack( -side => 'left' ); push @widgets, $widgets[0]->Scrolled( 'Entry', -textvariable => $text_var_ref, -width => $entry_width, -background => "white", -foreground => 'blue', -relief => 'sunken', -font => 'courier' )->pack( -side => 'left', -expand => 1, -fill => 'x' ); return @widgets; } # Automate the build of a lable & radiobutton wiget set inside a frame. sub frame_label_radio { my ( $width, $parent, $label, $text_array_ref, $var_ref, $cmd_ref ) = @_; my @widgets = (); push @widgets, $parent->Frame( -relief => 'flat', -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' ); push @widgets, $widgets[0]->Label( -width => $label_width, -text => " $label ", )->pack( -side => 'left' ); # Make N radiobuttons. foreach my $text (@$text_array_ref) { push @widgets, $widgets[0]->Radiobutton( -text => $text, -justify => 'left', -anchor => 'w', -width => $width, -value => $text, -variable => $var_ref, -command => $cmd_ref )->pack( -side => 'left', -expand => 1, -fill => 'x' ); } # End of foreach. return @widgets; } # Automate the build of a lable & scale wiget set inside a frame. sub frame_label_scale { my ( $parent, $text, $from, $to, $res, $orient ) = @_; $orient = 'horizontal' unless defined($orient); # Default option. $res = 1 unless defined($res); # Default option. my @widgets = (); push @widgets, $parent->Frame( -relief => 'flat', -borderwidth => 5, )->pack( -side => 'top', -expand => 1, -fill => 'x' ); push @widgets, $widgets[0]->Label( -width => $label_width, -text => " $text ", )->pack( -side => 'left' ); push @widgets, $widgets[0]->Scale( -from => $from, -to => $to, -resolution => $res, -orient => $orient, )->pack( -side => 'left', -expand => 1, -fill => 'x' ); return @widgets; } # Automate the build of a lable & button wiget set inside a frame. sub frame_label_buttons { my ( $parent, $label_text, $text_array_ref, $cmd_ref_array_ref, $color_array_ref ) = @_; my @widgets = (); push @widgets, $parent->Frame( -relief => 'flat', -borderwidth => 5, )->pack( -side => 'top', -expand => 1, -fill => 'x' ); push @widgets, $widgets[0]->Label( -width => $label_width, -text => " $label_text ", )->pack( -side => 'left' ); # Make N buttons. foreach my $text (@$text_array_ref) { push @widgets, $widgets[0]->Button( -width => $button_width, -text => $text, -command => shift ( @{$cmd_ref_array_ref} ), -activebackground => shift ( @{$color_array_ref} ), -relief => 'raised', )->pack( -side => 'left', -expand => 1, -fill => 'x' ); } # End of foreach. return @widgets; } #============ Begin subs for N checkbutton frames ============ # Automate the build of a lable & button wiget set inside a frame. sub frame_label_checks { # The var_ref's in var_ref_array_ref are on-off values. my ( $width, $parent, $label_text, $text_array_ref, $on_array_ref, $off_array_ref, $bool_array_ref, $cmd_ref_array_ref ) = @_; my @widgets_and_vars = (); push @widgets_and_vars, $parent->Frame( -relief => 'flat', -borderwidth => 5, )->pack( -side => 'top', -expand => 1, -fill => 'x' ); push @widgets_and_vars, $widgets_and_vars[0]->Label( -width => $label_width, -text => " $label_text ", )->pack( -side => 'left' ); # Make N checkbuttons. foreach my $text (@$text_array_ref) { my $check_var = 0; push @widgets_and_vars, $widgets_and_vars[0]->Checkbutton( -text => $text, -justify => 'left', -anchor => 'w', -width => $width, -variable => \$check_var, -relief => 'groove', )->pack( -side => 'left', -expand => 1, -fill => 'x', ); push @widgets_and_vars, \$check_var; # Assign the default on-value, if present. $widgets_and_vars[-2]->configure( -onvalue => shift @$on_array_ref ) if defined $on_array_ref; # Assign the default off-value, if present. $widgets_and_vars[-2]->configure( -offvalue => shift @$off_array_ref ) if defined $off_array_ref; # Assign checked or not-checked condition, if present. if ( defined $bool_array_ref ) { if ( shift @$bool_array_ref ) { $widgets_and_vars[-2]->select(); } else { $widgets_and_vars[-2]->deselect(); } } # Assign subroutine , if present. $widgets_and_vars[-2]->configure( -command => shift @$cmd_ref_array_ref ) if defined $cmd_ref_array_ref; } # End of foreach. return @widgets_and_vars; } # Return values of checkbutton widget set. sub poll_frame_label_checks { # Input @_ = ( frame, label, check_1, var_1, check_2, var_2 ...) # print "Checklist poll input = ", join " ", @_, "\n" if $debug_flag; my @bar = (); for ( my $i = 3 ; defined( $_[$i] ) ; $i += 2 ) { push @bar, ${ $_[$i] }; } # print "Checklist poll output = ", join " ", @bar, "\n" if $debug_flag; return @bar; } #============ End subs for N checkbutton frames ============ sub attach_baloons { my ($balloon, $widget, $baloon_msg, $status_msg) = @_; $balloon->attach( $widget, -balloonmsg => "$baloon_msg", -statusmsg => "$status_msg", ); } END { } ############################## # End GUS Tk widgets package # ############################## ############################ # Begin Help About Package # # Version 2004-03-06 # ############################ # Note: Two vars required in package main as/per following example... # our $formal_name = 'Gan Uesli Starling'; # However it's officially called. # our $formal_date = '1955-12-24'; # Official date of this relase. package GUS::help_about; BEGIN { } use Tk; use strict; no strict "refs"; # Declare variables for strict. use vars qw( $mw_about ); sub start_MainLoop { $mw_about = MainWindow->new( -title => 'About' ); my $text = $mw_about->Label( -text => "$main::formal_name\n" . "Release $main::formal_date\n\n" . "Copyright 2005, Gan Uesli Starling\n\nTrailing Edge Technologies\n" . "http://starling.us/tet\n" . "email gan\@starling.us" . "\n" )->pack(); my $bn_okay = $mw_about->Button( -width => 8, -relief => 'raised', -foreground => 'blue', -activebackground => 'green', -command => \&quit_MainLoop, -text => 'Okay' )->pack( -side => 'top' ); MainLoop; } # Close down the Perl/Tk GUI sub quit_MainLoop { $mw_about->destroy() if Tk::Exists($mw_about); } END { } ############################### # End Menu Help About Package # ############################### __END__ =head1 NAME GUS NetBSD Mixer =head1 VERSION Release date = 2005-02-10. =head1 SYNOPSIS perl gus_netbsd_mixer.pl =head1 DESCRIPTION A Perl/Tk script for NetBSD's mixerctl command =head1 SCREEN SPACE This is a Perl/Tk app. And all the widgets are inside a pane with scroll bars. So if you don't see all the widets, that is because they are inside the pane. Either expand the window to expose them all or else use the scroll bars. =head1 SLIDE POT TRAVEL Slide pot travel limitations (if any) derive from mixerctl itself. If you encounter such, try it out on the command line to see for yourself. =head1 CAVEATS Script written exclusively for NetBSD 2.0. Likely, though, it may work on earlier NetBSD versions as well. =head1 PREREQUISITES This script requires the C a graphical user interface toolkit module for Perl. =head1 AUTHOR Gan Uesli Starling > =head1 COPYRIGHT Copyright (c) 2005, Gan Uesli Starling. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut