mirror of
https://github.com/cookiengineer/audacity
synced 2025-10-18 16:41:14 +02:00
Scripts in Piped-Work
- New docimages script for the tracks. - Added new option in screenshots to capture ruler as well as track. - Typo fix (focussed)
This commit is contained in:
committed by
Paul Licameli
parent
1f605ccfc8
commit
24e8bbc623
525
scripts/piped-work/pipe_test.pl
Normal file
525
scripts/piped-work/pipe_test.pl
Normal file
@@ -0,0 +1,525 @@
|
||||
#!/usr/bin/env perl
|
||||
|
||||
# Test script for communicating with audacity via mod-script-pipe
|
||||
# Audacity should be running first, with the scripting plugin loaded.
|
||||
#
|
||||
# Note that currently, some menu commands require the project to be focused for
|
||||
# them to work. Further information and a list of known problems is available
|
||||
# on the 'Scripting' page of the Audacity wiki.
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Time::HiRes qw( gettimeofday tv_interval );
|
||||
use List::Util qw( max );
|
||||
|
||||
# Where should screenshots and exported tracks be saved?
|
||||
our $home = $ENV{HOME};
|
||||
our $screenshotDir = $home.'/pipetest/';
|
||||
our $effectTestDir = $home.'/pipetest/';
|
||||
|
||||
# Variables for pipe names
|
||||
our $Name;
|
||||
our $UID;
|
||||
our $ToSrvName;
|
||||
our $FromSrvName;
|
||||
|
||||
# For timing
|
||||
our $t0;
|
||||
|
||||
# TODO: Maybe get the pipe names from audacity?
|
||||
if ($^O eq 'MSWin32') {
|
||||
$Name = 'Srv';
|
||||
$ToSrvName = '\\\\.\\pipe\\To'.$Name.'Pipe';
|
||||
$FromSrvName = '\\\\.\\pipe\\From'.$Name.'Pipe';
|
||||
} elsif ($^O eq 'linux') {
|
||||
$UID = $<;
|
||||
$ToSrvName = '/tmp/audacity_script_pipe.to.'.$UID;
|
||||
$FromSrvName = '/tmp/audacity_script_pipe.from.'.$UID;
|
||||
} elsif ($^O eq 'darwin') {
|
||||
$UID = $<;
|
||||
$ToSrvName = '/tmp/audacity_script_pipe.to.'.$UID;
|
||||
$FromSrvName = '/tmp/audacity_script_pipe.from.'.$UID;
|
||||
}
|
||||
|
||||
# Open pipes
|
||||
sub startUp{
|
||||
open( TO_SRV, "+<$ToSrvName" )
|
||||
or die "Could not open $ToSrvName";
|
||||
open( FROM_SRV, "+<$FromSrvName" )
|
||||
or die "Could not open $FromSrvName";
|
||||
|
||||
# The next 'magic incantation' causes TO_SRV to be flushed every time we
|
||||
# write something to it.
|
||||
select((select(TO_SRV),$|=1)[0]);
|
||||
}
|
||||
|
||||
# Close pipes
|
||||
sub finish{
|
||||
print "Done. Press return to end.";
|
||||
<>;
|
||||
close TO_SRV;
|
||||
close FROM_SRV;
|
||||
}
|
||||
|
||||
# Subroutines for measuring how long a command takes to complete
|
||||
sub startTiming{
|
||||
$t0 = [gettimeofday];
|
||||
}
|
||||
sub stopTiming{
|
||||
my $elapsed = tv_interval ( $t0, [gettimeofday] );
|
||||
print "[Total time for command: $elapsed seconds.]\n";
|
||||
}
|
||||
|
||||
# Write a command to the pipe
|
||||
sub sendCommand{
|
||||
my $command = shift;
|
||||
if ($^O eq 'MSWin32') {
|
||||
print TO_SRV "$command
|
||||
|
||||
\r\n\0";
|
||||
} else {
|
||||
# Don't explicitly send \0 on Linux or reads after the first one fail...
|
||||
print TO_SRV "$command\n";
|
||||
}
|
||||
print "[$command]\n";
|
||||
}
|
||||
|
||||
# Send (and time) a command, and print responses
|
||||
sub doCommand{
|
||||
startTiming();
|
||||
sendCommand(shift);
|
||||
|
||||
my @resps = getResponses();
|
||||
map { print "$_\n"; } @resps;
|
||||
|
||||
stopTiming();
|
||||
print "\n";
|
||||
return @resps;
|
||||
}
|
||||
|
||||
# Return an array of all responses
|
||||
sub getResponses{
|
||||
my $resp;
|
||||
my @responses;
|
||||
|
||||
while($resp = <FROM_SRV>) {
|
||||
chomp($resp);
|
||||
last if ($resp eq '');
|
||||
push(@responses, $resp);
|
||||
}
|
||||
|
||||
return @responses;
|
||||
}
|
||||
|
||||
# Get the value of a preference
|
||||
sub getPref{
|
||||
my $name = shift;
|
||||
sendCommand("GetPreference: PrefName=$name");
|
||||
my @resps = getResponses();
|
||||
return shift(@resps);
|
||||
}
|
||||
|
||||
# Set the value of a preference
|
||||
sub setPref{
|
||||
my $name = shift;
|
||||
my $val = shift;
|
||||
doCommand("SetPreference: PrefName=$name PrefValue=$val");
|
||||
}
|
||||
|
||||
# Send a screenshot command
|
||||
sub screenshot{
|
||||
my $filePath = shift;
|
||||
my $captureMode = shift;
|
||||
my $background = shift;
|
||||
doCommand("Screenshot: FilePath=$filePath CaptureMode=$captureMode Background=$background");
|
||||
}
|
||||
|
||||
# Send a menu command
|
||||
sub menuCommand{
|
||||
my $commandName = shift;
|
||||
doCommand("MenuCommand: CommandName=$commandName");
|
||||
}
|
||||
|
||||
# Send a command which requests a list of all available menu commands
|
||||
sub getMenuCommands{
|
||||
doCommand("GetMenus: ShowStatus=0");
|
||||
}
|
||||
|
||||
sub showMenuStatus{
|
||||
sendCommand("GetMenus: ShowStatus=1");
|
||||
my @resps = getResponses();
|
||||
map { print "$_\n"; } @resps;
|
||||
}
|
||||
|
||||
# Send a string that should be a syntax error
|
||||
sub syntaxError{
|
||||
doCommand("CommandWithNoColon foo bar");
|
||||
}
|
||||
|
||||
# Send a command that doesn't exist
|
||||
sub noSuchCommand{
|
||||
doCommand("NoSuchCommand: myParam=3");
|
||||
}
|
||||
|
||||
sub parameterTest{
|
||||
# Set a non-existent parameter
|
||||
doCommand("GetMenus: blah=2");
|
||||
# Parameter with no '='
|
||||
doCommand("MenuCommand: CommandName");
|
||||
}
|
||||
|
||||
# See what happens when commands have extra spaces in various places
|
||||
sub extraSpaces{
|
||||
doCommand("Help: CommandName=Help");
|
||||
doCommand("Help : CommandName=Help");
|
||||
doCommand("Help: CommandName =Help");
|
||||
doCommand("Help: CommandName= Help");
|
||||
doCommand("Help: CommandName=Help ");
|
||||
}
|
||||
|
||||
# Test whether we can fall back to batch mode
|
||||
sub batchFallback{
|
||||
doCommand( "Echo: Delay=1.0 Decay=0.5" );
|
||||
}
|
||||
|
||||
# Send lots of commands quickly
|
||||
sub stressTest{
|
||||
my $n = 0;
|
||||
while($n < 600){
|
||||
getMenuCommands();
|
||||
++$n;
|
||||
}
|
||||
}
|
||||
|
||||
# Get help on a command
|
||||
sub help{
|
||||
my $cmdName = shift;
|
||||
doCommand("Help: CommandName=$cmdName");
|
||||
}
|
||||
|
||||
# Get help on all of the listed commands
|
||||
sub fullHelp{
|
||||
my @cmds = qw(BatchCommand CompareAudio MenuCommand GetMenus GetTrackInfo Help Message Screenshot Select SetTrackInfo);
|
||||
foreach my $cmd (@cmds){
|
||||
help($cmd);
|
||||
}
|
||||
}
|
||||
|
||||
# From script, this works like an 'echo'
|
||||
sub message{
|
||||
my $msg = shift;
|
||||
doCommand("Message: MessageString=$msg");
|
||||
}
|
||||
|
||||
# Send a CompareAudio command with a given threshold
|
||||
sub compareAudio{
|
||||
my $threshold = shift;
|
||||
my @resps = doCommand("CompareAudio: Threshold=$threshold");
|
||||
shift(@resps);
|
||||
return @resps;
|
||||
}
|
||||
|
||||
# Delete all tracks
|
||||
sub deleteAll{
|
||||
doCommand("Select: Mode=All");
|
||||
menuCommand("RemoveTracks");
|
||||
}
|
||||
|
||||
# A test of the CompareAudio command
|
||||
sub compareTest{
|
||||
deleteAll();
|
||||
|
||||
menuCommand("NewMonoTrack");
|
||||
doCommand("Chirp:");
|
||||
menuCommand("NewMonoTrack");
|
||||
doCommand("Chirp:");
|
||||
|
||||
my $j = 0;
|
||||
while($j < 3)
|
||||
{
|
||||
my $i = 0;
|
||||
while($i < 6){
|
||||
doCommand("Select: Mode=Range StartTime=5.0 EndTime=8.0 FirstTrack=0 LastTrack=0");
|
||||
|
||||
doCommand("Amplify: Ratio=0.95");
|
||||
doCommand("Select: Mode=All");
|
||||
compareAudio(0.4 - 0.1*$j);
|
||||
++$i;
|
||||
}
|
||||
++$j;
|
||||
}
|
||||
}
|
||||
|
||||
# Print some info returned by the GetTrackInfo command
|
||||
sub getTrackInfo{
|
||||
my $trackID = shift;
|
||||
sendCommand("GetTrackInfo: Type=Name TrackIndex=0");
|
||||
my @resps = getResponses();
|
||||
my $name = shift(@resps);
|
||||
sendCommand("GetTrackInfo: Type=StartTime TrackIndex=0");
|
||||
@resps = getResponses();
|
||||
my $startTime = shift(@resps);
|
||||
sendCommand("GetTrackInfo: Type=EndTime TrackIndex=0");
|
||||
@resps = getResponses();
|
||||
my $endTime = shift(@resps);
|
||||
sendCommand("GetTrackInfo: Type=Pan TrackIndex=0");
|
||||
@resps = getResponses();
|
||||
my $pan = shift(@resps);
|
||||
sendCommand("GetTrackInfo: Type=Gain TrackIndex=0");
|
||||
@resps = getResponses();
|
||||
my $gain = shift(@resps);
|
||||
sendCommand("GetTrackInfo: Type=Mute TrackIndex=0");
|
||||
@resps = getResponses();
|
||||
my $mute = shift(@resps);
|
||||
sendCommand("GetTrackInfo: Type=Solo TrackIndex=0");
|
||||
@resps = getResponses();
|
||||
my $solo = shift(@resps);
|
||||
sendCommand("GetTrackInfo: Type=Selected TrackIndex=0");
|
||||
@resps = getResponses();
|
||||
my $selected = shift(@resps);
|
||||
sendCommand("GetTrackInfo: Type=Focused TrackIndex=0");
|
||||
@resps = getResponses();
|
||||
my $focused = shift(@resps);
|
||||
sendCommand("GetTrackInfo: Type=Linked TrackIndex=0");
|
||||
@resps = getResponses();
|
||||
my $linked = shift(@resps);
|
||||
|
||||
print " Name: $name\n";
|
||||
print "StartTime: $startTime\n";
|
||||
print " EndTime: $endTime\n";
|
||||
print " Pan: $pan\n";
|
||||
print " Gain: $gain\n";
|
||||
print " Mute: $mute\n";
|
||||
print " Solo: $solo\n";
|
||||
print " Selected: $selected\n";
|
||||
print " Focused: $focused\n";
|
||||
print " Linked: $linked\n";
|
||||
}
|
||||
|
||||
# Assortment of different tests
|
||||
sub fullTest{
|
||||
syntaxError();
|
||||
extraSpaces();
|
||||
menuCommand("NewStereoTrack");
|
||||
#screenshot($screenshotDir, "window", "None"); # (Slow)
|
||||
doCommand("Select: Mode=All");
|
||||
getMenuCommands();
|
||||
menuCommand("NewMonoTrack");
|
||||
batchFallback();
|
||||
help("Screenshot");
|
||||
message("Hello!");
|
||||
getTrackInfo(0);
|
||||
deleteAll();
|
||||
}
|
||||
|
||||
# Play for three seconds, then stop
|
||||
sub playAndStop{
|
||||
menuCommand("Play");
|
||||
sleep(3.0);
|
||||
menuCommand("Stop");
|
||||
}
|
||||
|
||||
# Select part of a stereo track
|
||||
sub selectRegion{
|
||||
my $track = shift;
|
||||
my $start = shift;
|
||||
my $end = shift;
|
||||
my $t1 = $track + 1;
|
||||
doCommand("Select: Mode=Range FirstTrack=$track LastTrack=$t1 StartTime=$start EndTime=$end");
|
||||
}
|
||||
|
||||
# Run testing on the effects that use the ClearAndPaste method
|
||||
# Allows the user to check whether effects transform time correctly
|
||||
sub testClearAndPasters{
|
||||
|
||||
# Which effects to test, and with what parameters
|
||||
my @clearAndPasters = (
|
||||
"Unchanged:", # control: nonexistent command, so does nothing
|
||||
# (so 'batch command not recognised' isn't an error)
|
||||
"Noise:", # generate
|
||||
"NoiseRemoval:", # misc clear&paste
|
||||
"ChangeSpeed: Percentage=-10.0", # misc clear&paste
|
||||
"ChangeSpeed: Percentage=40.0", # misc clear&paste
|
||||
"ChangeTempo: Percentage=-20.0", # soundtouch
|
||||
"ChangeTempo: Percentage=80.0", # soundtouch
|
||||
"ChangePitch: Percentage=25.0", # soundtouch
|
||||
"ChangePitch: Percentage=-80.0", # soundtouch
|
||||
"TimeScale: RateStart=-80.0 RateEnd=150.0 HalfStepsStart=-5.0 HalfStepsEnd=8.0 PreAnalyze=no", # SBSMS
|
||||
); # nyquist can't be called currently
|
||||
|
||||
# Allow time for user to give the project window focus (workaround for menu
|
||||
# command problem)
|
||||
sleep(1.0);
|
||||
deleteAll();
|
||||
my $len = 20.0;
|
||||
|
||||
# Since there aren't proper generator commands yet, we use the preferences
|
||||
# to control the duration.
|
||||
# This preferences is not read in Audacity 2.2.x where duration
|
||||
# is read from pluginsettings.cfg
|
||||
my $origDuration = getPref("/CsPresets/NoiseGen_Duration");
|
||||
setPref("/CsPresets/NoiseGen_Duration", $len);
|
||||
|
||||
# For each effect to test:
|
||||
# * Create some stereo noise, and chop two pieces out of it
|
||||
# * Add some labels, then apply the effect
|
||||
# @splits determines where the splits are
|
||||
my @splits = map {$_ * $len} (0.999, 0.2, 0.5, 0.6, 0.8, 0.1, 0.9);
|
||||
my $trackNum = 0;
|
||||
foreach my $effect (@clearAndPasters) {
|
||||
menuCommand("NewStereoTrack");
|
||||
selectRegion($trackNum, 0.0, $splits[0]);
|
||||
doCommand("Noise:");
|
||||
selectRegion($trackNum, $splits[1], $splits[2]);
|
||||
menuCommand("SplitDelete");
|
||||
menuCommand("AddLabel");
|
||||
selectRegion($trackNum, $splits[3], $splits[4]);
|
||||
menuCommand("SplitDelete");
|
||||
menuCommand("AddLabel");
|
||||
|
||||
# Apply the effect
|
||||
selectRegion($trackNum, $splits[5], $splits[6]);
|
||||
doCommand($effect);
|
||||
|
||||
# Make and set the track name
|
||||
my @splat = split(':', $effect);
|
||||
my $name = $splat[0];
|
||||
doCommand("SetTrackInfo: TrackIndex=$trackNum Type=Name Name=$name");
|
||||
doCommand("Select: Mode=None");
|
||||
|
||||
$trackNum = $trackNum + 3;
|
||||
}
|
||||
|
||||
# Set duration back to what it was before
|
||||
setPref("/CsPresets/NoiseGen_Duration", $origDuration);
|
||||
}
|
||||
|
||||
|
||||
###############################################################################
|
||||
# Effect testing #
|
||||
###############################################################################
|
||||
|
||||
# A list of effects to test (could be got from Audacity in future)
|
||||
sub getEffects{
|
||||
|
||||
# (These ones will need special handling)
|
||||
# AutoDuck
|
||||
# Bass and Treble
|
||||
# Repair
|
||||
# NoiseRemoval
|
||||
# ClickRemoval
|
||||
# Paulstretch
|
||||
|
||||
# TimeScale (disabled because it's so slow)
|
||||
|
||||
my @effects = qw(
|
||||
Amplify
|
||||
ChangePitch
|
||||
ChangeSpeed
|
||||
ChangeTempo
|
||||
Compressor
|
||||
Echo
|
||||
Equalization
|
||||
FadeIn
|
||||
FadeOut
|
||||
Invert
|
||||
Normalize
|
||||
Phaser
|
||||
Repeat
|
||||
Reverse
|
||||
TruncateSilence
|
||||
Wahwah
|
||||
);
|
||||
return @effects;
|
||||
}
|
||||
|
||||
# Create a chirp for an effect to be applied to.
|
||||
# The duration setting does not work in Audacity 2.2.x where duration
|
||||
# is read from pluginsettings.cfg
|
||||
sub generateBase{
|
||||
my $genCmd = "Chirp";
|
||||
my $duration = 30.0;
|
||||
menuCommand("NewMonoTrack");
|
||||
doCommand("$genCmd:");
|
||||
my $desc = $genCmd . "-" . $duration . "s";
|
||||
return $desc;
|
||||
}
|
||||
|
||||
# Apply an effect and save the results (for use as reference output)
|
||||
sub saveEffectResults{
|
||||
my $dirname = shift;
|
||||
my $effect = shift;
|
||||
deleteAll();
|
||||
|
||||
my $filename = $dirname . "/" . generateBase() . "-" . $effect . ".wav";
|
||||
doCommand($effect);
|
||||
|
||||
printHeading("Exporting to $filename\n");
|
||||
doCommand("Export: Mode=All Filename=$filename Channels=1");
|
||||
}
|
||||
|
||||
# Apply an effect and compare the result to reference output
|
||||
sub doEffectTest{
|
||||
my $dirname = shift;
|
||||
my $effect = shift;
|
||||
|
||||
deleteAll();
|
||||
my $filename = $dirname . "/" . generateBase() . "-" . $effect . ".wav";
|
||||
doCommand("SetTrackInfo: TrackIndex=0 Type=Name Name=$effect");
|
||||
doCommand($effect);
|
||||
doCommand("Import: Filename=$filename");
|
||||
doCommand("Select: Mode=All");
|
||||
my @result = compareAudio(0.001);
|
||||
return @result;
|
||||
}
|
||||
|
||||
# Export reference copies of the effects in the list
|
||||
sub exportEffects{
|
||||
my $exportDir = shift;
|
||||
my @effects = getEffects();
|
||||
foreach my $effect (@effects) {
|
||||
saveEffectResults($exportDir, $effect);
|
||||
}
|
||||
}
|
||||
|
||||
# Test each of the effects in the list
|
||||
sub testEffects{
|
||||
my $referenceDir = shift;
|
||||
my %results = ();
|
||||
|
||||
my @effects = getEffects();
|
||||
foreach my $effect (@effects) {
|
||||
printHeading("Testing effect: $effect");
|
||||
my @res = doEffectTest($referenceDir, $effect);
|
||||
$results{ $effect }[0] = $res[0];
|
||||
$results{ $effect }[1] = $res[1];
|
||||
}
|
||||
|
||||
# Print out table of results
|
||||
my $padLength = max(map { length($_) } @effects);
|
||||
|
||||
printHeading("Test results");
|
||||
print "Effect name\tSamples\tSeconds\n\n";
|
||||
for my $effect (keys %results) {
|
||||
my $padded = sprintf("%-${padLength}s", $effect);
|
||||
my $badSamples = $results{ $effect }[0];
|
||||
my $badSeconds = $results{ $effect }[1];
|
||||
print "$padded\t$badSamples\t$badSeconds\n";
|
||||
}
|
||||
}
|
||||
|
||||
# Print text with ascii lines above and below
|
||||
sub printHeading{
|
||||
my $msg = shift;
|
||||
my $line = "-" x length($msg);
|
||||
print "$line\n$msg\n$line\n\n";
|
||||
}
|
||||
|
||||
###############################################################################
|
||||
|
||||
startUp();
|
||||
|
||||
# Send some test commands
|
||||
|
||||
exportEffects($effectTestDir);
|
||||
testEffects($effectTestDir);
|
Reference in New Issue
Block a user