#!/usr/bin/perl -w # ------------- # DM2 Processor # ------------- # With this Perl script you can manipulate frames and skins in ranges of # blocks in DM2 files. It works on DM2 text files and (if LMPC is available), # also on DM2 binary files. # Get dm2proc (without HTML decorations) from # http://demospecs.half-empty.de/misc/dm2proc.pl # or from the CVS repository # http://cvs.sourceforge.net/viewcvs.py/lmpc/lmpc/bin/procdm2.pl. # $Id: procdm2.pl,v 1.13 2009/10/23 20:35:48 girlich Exp $ # Uwe Girlich (uwe@half-empty.de) # modules init use strict; use Getopt::Long qw(:config no_ignore_case); use IO::File; use Pod::Usage; use Pod::Text; use IPC::Open3; use File::Spec; # prototypes sub command_parse($); sub logging; sub warning; sub syntaxerror($$$); sub range_parse($); # release information sub release() { (my $release = q$Revision: 1.13 $) =~ s/^[^:]+:\s*(.*?)\s*$/$1/; $release; } sub date() { (my $date = q$Date: 2009/10/23 20:35:48 $) =~ s/^[^:]+:\s*(.*?)\s*$/$1/; $date; } sub comment() { "alpha quality"; } # default option values my $opt_input = "input.dm2"; # default input file name my $opt_output = "output.dm2"; # default output file name my $opt_command = "command.proc"; # default processing command file my $opt_lmpc = "lmpc"; # default lmpc command my $opt_version = 0; # version off my $opt_help = 0; # help off my $opt_man = 0; # manual off my $opt_logging = 0; # logging verbose level my $opt_warning = 0; # warning verbose level # parse command line GetOptions( 'input|i=s' => \$opt_input, 'output|o=s' => \$opt_output, 'command|c=s' => \$opt_command, 'lmpc=s' => \$opt_lmpc, 'version|V' => \$opt_version, 'help|?' => \$opt_help, 'man|m' => \$opt_man, 'logging|l=i' => \$opt_logging, 'warning|w=i' => \$opt_warning, ) or pod2usage(-msg=>"Syntax error", -verbose=>0); if ($opt_help) { pod2usage(-verbose=>0); warning 10, "podusage() for short help should not return.\n"; exit(1); } if ($opt_man) { pod2usage(-verbose=>2); warning 10, "podusage() for long help should not return.\n"; exit(1); } if ($opt_version) { printf "DM2 Processor %s, %s (%s)\n", release(), date(), comment(); exit(1); } my $command = command_parse($opt_command); if (not ref $command) { warning 0, "Problem parsing command file $opt_command.\n"; exit(1); } logging 10, "parsing command file $opt_command completed.\n"; my $prepost = 0; my $lmpc_ok = 0; if (-f $opt_lmpc && -x $opt_lmpc) { logging 30, "$opt_lmpc is an executable.\n"; # but maybe it is without directory and not in the PATH my ($volume,$directories,$file) = File::Spec->splitpath($opt_lmpc); if ($volume eq "" && $directories eq "") { # single filename, must be in PATH or not callable my @path = File::Spec->path(); foreach (@path) { my $abs_path = File::Spec->catfile($_,$opt_lmpc); if (-f $abs_path && -x $abs_path) { logging 20, "$opt_lmpc was found in PATH env.\n"; $lmpc_ok = 1; } } if ($lmpc_ok == 0) { logging 20, "$opt_lmpc was not found in PATH env.\n"; } } else { if (File::Spec->file_name_is_absolute($opt_lmpc)) { logging 20, "$opt_lmpc is absolute path.\n"; $lmpc_ok = 1; } else { logging 20, "$opt_lmpc is relative path.\n"; $lmpc_ok = 1; } } } else { my ($volume,$directories,$file) = File::Spec->splitpath($opt_lmpc); if ($volume eq "" && $directories eq "") { my @path = File::Spec->path(); foreach (@path) { my $abs_path = File::Spec->catfile($_,$opt_lmpc); if (-f $abs_path && -x $abs_path) { logging 20, "$opt_lmpc was found in PATH env.\n"; $lmpc_ok = 1; } } } else { logging 20, "$opt_lmpc does not exist.\n"; $lmpc_ok = 0; } } if ($lmpc_ok == 1) { logging 20, "The command $opt_lmpc is available.\n"; my $info = "$opt_lmpc --info $opt_input"; logging 30, "checking with '$info', if input is text or binary\n"; my $info_fh; my $pid = open3("<&STDIN", $info_fh, $info_fh, $info); if ($pid==0) { warning 0, "Could not execute ´$info´: $!.\n"; exit(1); } logging 35, "started child with pid $pid.\n"; if (!defined $info_fh) { warning 0, "Could not read output from '$info': $!.\n"; waitpid $pid, 0; exit(1); } logging 40, "reading output from '$info'\n"; while (<$info_fh>) { if (/$opt_input.*DM2 txt/) { $prepost = 0; logging 35, "$opt_input is really text\n"; last; } if (/$opt_input.*DM2 bin/) { logging 35, "$opt_input is really binary\n"; $prepost = 1; last; } } $info_fh->close(); logging 40, "output ended\n"; waitpid $pid, 0; } else { warning 20, "The command $opt_lmpc is not available.\n"; $prepost = 0; } my $text_in; my $text_out; if ($prepost) { logging 35, "$opt_input is assumed to contained binary\n"; $text_in = "text_in_$$.txt"; $text_out = "text_out_$$.txt"; } else { logging 35, "$opt_input is assumed to contain text\n"; $text_in = $opt_input; $text_out = $opt_output; } my $error = 0; if ($prepost) { my $preproc = "$opt_lmpc --to-txt $opt_input $text_in"; logging 20, "Calling '$preproc' to generate text file.\n"; system $preproc; if (!-f $text_in) { warning 0, "LMPC ($opt_lmpc) did not create $text_in.\n"; $error = 1; goto out; } } logging 0, "$text_in (DM2 txt) -> $text_out (DM2 txt)\n"; logging 30, "Reading $text_in.\n"; my $in_fh = new IO::File "<$text_in"; if (!defined $in_fh) { warning 0, "Could not open $text_in for reading: $!.\n"; if (!$prepost) { warning 0, "Please use '-i inputfile'.\n"; } $error = 1; goto out; } logging 30, "Writing $text_out.\n"; my $out_fh = new IO::File ">$text_out"; if (!defined $out_fh) { warning 0, "Could not open $text_out for writing: $!.\n"; $error = 1; goto out; } my $state = 0; my $block = 0; my $entity = 1; my $frame = 0; my $skin = 0; my $new_frame = 0; my $new_skin = 0; my $subst_frame = 0; my $subst_skin = 0; my %entity = (); while (<$in_fh>) { my $line = $_; # process the input line if ($line =~ /^ seq1 (\d+)/) { $block = $1; logging 30, "block number $block: "; if (!exists $command->{$block}) { logging 30, "ignore\n"; $state = 0; } else { logging 30, "work\n"; $state = 1; # Memorize all the entities where we have something # to do in this frame. %entity=(); for (keys %{$command->{$block}}) { $entity{$_} = 1; } } } if ($state == 1) { if ($line =~ /packetentities {/) { logging 40, "block number $block packetentities start\n"; $state = 2; } } if ($state == 2) { if ($line =~ / packetentity {/) { logging 40, "block number $block packetentity start\n"; $state = 3; } if ($line =~ /^ }/) { logging 40, "block number $block packetentites ended\n"; for $entity (keys %entity) { logging 40, "block $block, entity $entity missing\n"; my $line_new = " packetentity {\n entity $entity;\n"; if (exists $command->{$block}->{$entity}->{"f"}) { $frame = $command->{$block}->{$entity}->{"f"}; logging 40, "adding frame $frame\n"; $line_new .= " frame $frame;\n"; } if (exists $command->{$block}->{$entity}->{"s"}) { $skin = $command->{$block}->{$entity}->{"s"}; logging 40, "adding skin $frame\n"; $line_new .= " skin $skin;\n"; } $line = $line_new . " }\n" . $line; } %entity=(); $state = 0; } } if ($state == 3) { if ($line =~ / entity (\d+);/) { $entity = $1; logging 30, "entity number $entity: "; if (!exists $command->{$block}->{$entity}) { logging 30, "ignore\n"; $state = 2; } else { logging 30, "work\n"; $state = 4; if (exists $command->{$block}->{$entity}->{"f"}) { $frame = $command->{$block}->{$entity}->{"f"}; $new_frame = 1; $subst_frame = 0; logging 31, "frame -> $frame\n"; } if (exists $command->{$block}->{$entity}->{"s"}) { $skin = $command->{$block}->{$entity}->{"s"}; $new_skin = 1; $subst_skin = 0; logging 31, "skin -> $skin\n"; } } } } if ($state == 4) { if ($new_frame && $line =~ s/( frame )\d+(;)/$1$frame$2/) { logging 32, "frame subst OK\n"; $subst_frame = 1; } if ($new_skin && $line =~ s/( skin )\d+(;)/$1$skin$2/) { logging 32, "skin subst OK\n"; $subst_skin = 1; } if ($line =~ / }/) { if ($new_frame && !$subst_frame) { $line = " frame $frame;\n" . $line; logging 32, "frame append OK\n"; } if ($new_skin && !$subst_skin) { $line = " skin $skin;\n" . $line; logging 32, "skin append OK\n"; } logging 40, "packetentity ended\n"; $state = 2; } delete $entity{$entity}; # This is done. } print $out_fh $line; } $in_fh->close(); $out_fh->close(); if ($prepost) { my $postproc = "$opt_lmpc --to-bin $text_out $opt_output"; logging 20, "Calling '$postproc' to generate binary file.\n"; system $postproc; } out: if ($prepost) { logging 20, "Remove temporary text files $text_in and $text_out.\n"; unlink $text_in, $text_out; } # End of program. exit $error; sub command_parse($) { my $command_filename = shift; my %command = (); logging 0, "Reading command file %s.\n", $command_filename; my $command_fh=new IO::File("<$command_filename"); if (!defined $command_fh) { warning 0, "Could not open %s for reading: $!. Please use '-c commandfile'.\n", $command_filename; return 0; } my $e=0; while (<$command_fh>) { my $line = $_; $line =~ s/#.*//; # remove comment $line =~ s/^\s*//; # remove leading whitespaces $line =~ s/\s*$//; # remove trailing whitespaces $line =~ s/\s*-/-/g; # remove whitespace before - $line =~ s/-\s*/-/g; # remove whitespace after - next if $line =~ /^$/; # ignore empty line my $letter; my $args; if ($line =~ /^([a-zA-Z])\s*(.*)$/) { $letter = lc $1; $args = $2; } else { syntaxerror $command_filename, $., "no command"; return 0; } if ($letter eq "e") { if ($args =~ /^(\d+)$/) { $e = $1; } else { syntaxerror $command_filename, $., "$args is not a number"; return 0; } logging 40, "entity $e\n"; } elsif ($letter eq "f" or $letter eq "s") { my $blocks; my $frames; if ($args =~ /^([^\s]+)\s+([^\s]+)$/) { $blocks = $1; $frames = $2; } else { syntaxerror $command_filename, $., "command $letter: $args is not blockrange argsrange"; return 0; } my ($bs,$be,$bi) = range_parse($blocks); my ($fs,$fe,$fi) = range_parse($frames); logging 50, "blocks $bs ... $be (inc $bi): $letter $fs ... $fe (inc $fi)\n"; my $f = $fs; for (my $b=$bs;$bi>0?$b<=$be:$b>=$be;$b+=$bi) { $command{$b}{$e}{$letter}=$f; logging 60, "b $b e $e $letter $f\n"; $f += $fi; if ($fi>0?$f>$fe:$f<$fe) { $f = $fs; } } } else { syntaxerror $command_filename, $., "unknown command"; return 0; } } $command_fh->close(); return \%command; } # trace sub logging { my $level = shift; if ($level<=$opt_logging) { printf STDERR @_; } } sub warning { my $level = shift; if ($level<=$opt_warning) { printf STDERR @_; } } sub syntaxerror($$$) { my ($command, $line, $message) = @_; warning 0, "Command file $command: syntax error in line $line.\n$message.\n"; } sub range_parse($) { my $text = shift; if ($text =~ /^([^-]+)-([^-]+)$/) { return $1, $2, $1<$2? 1 : -1; } else { return $text, $text, 1; } } __END__ =head1 NAME procdm2 - DM2 Processor =head1 SYNOPSIS procdm2.pl [options] Options: -i|--input file input file name (default: input.dm2). -o|--output file output file name (default: output.dm2). -c|--command file command file name (default: command.proc). --lmpc file LMPC executable (default: lmpc) -V|--version print version. -h|-?|--help brief help message. -m|--man full documentation. -l|--logging level logging verbose level (default: 0, off). -w|--warning level warning verbose level (default: 0, off). =head1 OPTIONS =over 8 =item B<--input file> Defines the input file name. Default: input.dm2. The input file can be a DM2 text file or a DM2 binary file. In case of a binary file, it will be converted into a text file by calling LMPC --to-txt. =item B<--output file> Defines the output file name. Default: output.dm2. The output file has the same type (binary or text) as the input file. =item B<--command file> Defines the processing command file name. Default: command.proc. =item B<--lmpc file> Defines the name of the LMPC command. Default: lmpc. =item B<--version> Prints the program version and exits. =item B<--help> Print a brief help message and exits. =item B<--man> Prints the manual page and exits. =item B<--logging level> Set the verbose level for logging trace output. Default: 0, off. =item B<--warning level> Set the verbose level for warning trace output. Default: 0, off. =back =head1 DESCRIPTION This program will read the given input file, perform the actions defined in the command file and write the output file. =head1 PROCESSING COMMANDS The processing command text file consists of lines with commands. # starts a comment. Empty lines will be ignored. =over 8 =item B<e entity> This defines the number of the entity, for which the following commands are valid. Defaults to 1. =item B<f blockrange framerange> This commands defines, that in the blocks in blockrange the frames from framerange must be used. =item B<s blockrange skinrange> This commands defines, that in the blocks in blockrange the skins from skinrange must be used. =back =head1 RANGES A range consists of a starting number and optional a dash and an ending number. Whitespaces and backward ordering (end smaller than begin) are allowed. =head1 SEE ALSO L<http://demospecs.half-empty.de/demospecs/lmpc-stable> L<http://demospecs.half-empty.de/misc/procdm2.html> L<http://www.sourceforge.net/projects/lmpc> =head1 AUTHOR Uwe Girlich (uwe@half-empty.de) =cut