package Music::CoOpera;
use warnings;
use strict;
use File::Find;
use File::Slurp qw/slurp/;
use Data::Dumper;
=head1 NAME
Music::CoOpera - The great new Music::CoOpera!
=head1 VERSION
Version 0.01
=cut
our $VERSION = '0.01';
my $WIKIROOT;
my %conf;
my $force;
my $dest;
my @files;
my %ABC;
=head1 SYNOPSIS
Quick summary of what the module does.
Perhaps a little code snippet.
use Music::CoOpera;
my $foo = Music::CoOpera->new();
...
=head1 EXPORT
A list of functions that can be exported. You can delete this section
if you don't export anything, such as for a purely object-oriented module.
=head1 SUBROUTINES/METHODS
=head2 init_proj
=cut
sub init_proj {
$WIKIROOT = shift;
my $filename = shift;
$force = shift;
unless ($WIKIROOT and $filename) {
return -1;
}
my $DATA = $WIKIROOT.'/data/pages';
my $MEDIA = $WIKIROOT.'/data/media';
my $TMPDIR = '/tmp/multiabc';
%conf = __get_conf($filename);
$dest = "$DATA/$conf{'slug'}";
my $fh;
my $dest = "$DATA/$conf{'slug'}";
mkdir $dest;
push @files, $dest;
my $new_index = __create_index($dest,%conf);
if (-e "$dest/index.txt") {
my %new_index = __split_sections($new_index);
my $old_index = slurp("$dest/index.txt");
my %old_index = __split_sections($old_index);
my $tmp;
foreach (@{$new_index{'__order'}}) {
if ($_ =~ m/(partitura|partes|misc)/i) {
$tmp .= "$_\n".$new_index{$_};
}
else {
$tmp .= $old_index{$_} ? "$_\n".$old_index{$_} : "$_\n".$new_index{$_};
}
}
$new_index = $tmp;
}
open $fh, ">", "$dest/index.txt";
print $fh $new_index;
close $fh;
open $fh, ">", "$dest/t_abc.txt";
print $fh "\n". __template_abc() . "\n[[$conf{'slug'}:index|Voltar ao index do projecto]]\n";
close $fh;
push @files, "$dest/t_abc.txt";
mkdir "$MEDIA/$conf{'slug'}";
push @files, "$MEDIA/$conf{'slug'}";
# write configuration file
open $fh, ">", "$DATA/$conf{'slug'}/conf.txt";
print $fh "".slurp($filename)."\n\nRecalcular Projecto | [[$conf{'slug'}:index|Voltar ao index do projecto]]\n";
push @files, "$DATA/$conf{'slug'}/conf.txt";
close $fh;
__fix_permissions(@files);
}
=head2 build_proj
=cut
sub build_proj {
$WIKIROOT = shift;
my $filter = shift;
my $DATA = $WIKIROOT.'/data/pages';
my $MEDIA = $WIKIROOT.'/data/media';
my $TMPDIR = '/tmp/multiabc';
my $IMGDIR = $WIKIROOT.'/data/media'; ## não está a ser usado...
find(\&__proc_file, $DATA);
mkdir $TMPDIR unless -e $TMPDIR;
chdir $TMPDIR;
my @files;
my @cleanup;
foreach my $m (keys %ABC) {
if ($filter) {
next unless ($m =~ m/$filter/);
}
if ($m =~ /:/) {
print "Building $m\n";
my ($ns, $name) = split /:/, $m;
my %conf = __get_conf("$DATA/$ns/conf.txt");
open my $fh, '>', "$m.abc";
# add template abc:
my $t_abc = slurp("$DATA/$ns/t_abc.txt");
if ($t_abc =~ m/(.*)<\/code>/s) {
$t_abc = $1;
}
else {
$t_abc = '';
}
print $fh $t_abc;
print $fh __juntaabc(%{$ABC{$m}},%conf);
close $fh;
push @cleanup, "$TMPDIR/$m.abc";
`/usr/bin/abcm2ps -c $m.abc 2>&1`;
`/usr/bin/ps2pdf -sPAPERSIZE=a4 Out.ps $MEDIA/$ns/$name`;
`/usr/bin/abc2midi $m.abc -o $MEDIA/$ns/final.mid `;
push @cleanup, "$TMPDIR/Out.ps";
push @files, "$MEDIA/$ns/$name";
`/bin/cp $m.abc $MEDIA/$ns/final.abc`;
push @files, "$MEDIA/$ns/final.abc";
push @files, "$MEDIA/$ns/final.mid";
`echo "" > $DATA/$ns/final.txt`;
`cat $m.abc | iconv -f latin1 -t utf8 >> $DATA/$ns/final.txt`;
`echo "" >> $DATA/$ns/final.txt`;
push @files, "$DATA/$ns/final.txt";
}
}
__fix_permissions(@files);
__clean_tmpfiles(@cleanup);
}
=head2 __fix_permissions
=cut
sub __fix_permissions {
my @files = @_;
my @stat = stat("$WIKIROOT/data");
my $uid = $stat[4];
my $gid = $stat[5];
chown $uid, $gid, @files;
}
=head2 __clean_tmpfiles
=cut
sub __clean_tmpfiles {
unlink @_;
}
=head2 __split_sections
=cut
sub __split_sections {
my $c = shift;
my %h;
my $key;
foreach (split /^/, $c) {
if ($_ =~ m/^={2,}/) {
$key = $_;
chomp $key;
push @{$h{'__order'}}, $key;
}
else {
$h{$key} .= $_;
}
}
return %h;
}
=head2 __create_index
=cut
sub __create_index {
my ($dest,%conf)=@_;
my $res = "====== $conf{'name'} ======\n\n";
$res .= "===== Introdução =====\n\n";
$res .= "===== ...Facsimile =====\n\n";
$res .= "[[$conf{'original'}|Pdf Original]]\n\n";
$res .= "===== Partitura =====\n\n";
$res .= " * [[$conf{'slug'}:final]]\n";
$res .= " * {{:$conf{'slug'}:final.pdf?nocache|}}\n";
$res .= " * {{:$conf{'slug'}:final.abc?nocache|}}\n";
$res .= " * {{:$conf{'slug'}:final.mid?nocache|}}\n\n";
$res .= "===== Partes =====\n\n";
for (1 .. $conf{'parts'}) {
print "parte $_\n";
$res .= " * [[$conf{'slug'}:part_$_|Parte $_]]\n";
__create_part($_,$dest,%conf);
}
$res .= "===== Misc =====\n\n";
$res .= " * [[conf|Ficheiro de configuração]]\n";
$res .= " * [[t_abc|Template ABC]]\n";
$res .= " * Actualizar Projecto";
return $res;
}
=head2 __create_part
=cut
sub __create_part {
my ($n,$dest,%conf) = @_;
$conf{'barpp'} ||=5;
return if -e "$dest/part_$n.txt" && !$force;
my $p = "===== $conf{'name'} =====\n\n";
$p .= " * [[$conf{'original'}|Pdf Original]]\n";
$p .= "==== Parte $n ====\n\n";
$p .= qq{
% multiabc name=final.pdf ns=$conf{'slug'} order=$n\nX: $n\n};
$p .= __texpand($conf{template},(%conf,
part_number => $n,
voice_def => qq{%%staves $n\nV:$n clef=treble name="P. $n" sname="P$n"}));
$p .= "\n\n";
$p .= "\n[[$conf{'slug'}:index|Voltar ao index do projecto]]\n";
open my $fh, ">", "$dest/part_$n.txt";
print $fh $p;
close $fh;
push @files, "$dest/part_$n.txt";
}
=head2 __texpand
=cut
sub __texpand{ my ($t,%arg)=@_;
$t =~ s/\[\%\s*(\w+)\s*\%\]/"$arg{$1}"||"??????($1)"/ge;
$t
}
=head2 slug
=cut
sub __slug {
my $str = shift;
$str =~ s/[óÓòÒ]+/o/g;
$str =~ s/[áÁàÀ]+/a/g;
$str =~ s/[éÉèÈ]+/e/g;
$str =~ s/[íÍìÌ]+/i/g;
$str =~ s/[úÚùÙ]+/u/g;
$str =~ s/[çÇ]+/c/g;
$str =~ s/[\s\t\W]+/_/g;
return lc($str);
}
sub __get_conf {
my $filename = shift;
my %conf;
my $content = slurp($filename, binmode => ':utf8');
if ($content =~ m/(.*)<\/code>/s) {
#$content =~ s/<\/*code>\s*//g;
$content = $1;
my($opts, $template) = split (/%%\n/, $content, 2);
## my($opts, $template) = split /%%/, $content;
foreach (split /\n/, $opts) {
my ($k, $v) = split /\s*=\s*/, $_;
$conf{$k} = eval $v if $k;
}
$conf{'template'} = $template;
if ($conf{'name'}) {
$conf{'slug'} = __slug($conf{'name'});
}
return %conf;
}
open my $fh, "<", $filename;
while(<$fh>) {
next if $_ =~ m/^$/;
if($_ =~ m/^%%$/){ $conf{template} = join("",<$fh>); last}
chomp;
my ($k, $v) = split /\s*=\s*/, $_;
$conf{$k} = eval $v;
}
close $fh;
if ($conf{'name'}) {
$conf{'slug'} = __slug($conf{'name'});
}
return %conf;
}
sub __getMeta{
my ($a,%op) = @_;
my %ignore=();
my $base="";
for( split(/[ \t,;]/,$op{rem})){$ignore{$_}++};
while($a =~ m{(?:\n|^)(([A-Z]:|\%\%\w+)\s*(.*))}g ){
my ($l,$k)=($1,$2);
$k=~s/://;
next if $ignore{$k};
$base .= "$l\n";
}
$base;
}
sub __proc_file {
return if $_ =~ m/^\.{1,2}/;
return unless -f $File::Find::name;
return if $_ eq 'final.txt';
my $file = $File::Find::name;
print "Processing $file\n";
my $c = slurp($file, binmode => ':utf8');
while ($c =~ m/(.*?)<\/abc>/gsi) {
print "\tFound abc\n";
my $abc = $1;
if ($abc =~ m/multiabc\s+(.*?)\n/) {
my $mabc = $1;
my %args;
print "\tFound multiabc: $mabc\n";
while ($mabc =~ m/([^=\s]+?)\s*=([^=\s]+)/g) {
$args{$1} = $2;
}
if ($args{'name'} and $args{'order'}) {
if ($args{'ns'}) {
$ABC{"$args{'ns'}:$args{'name'}"}{$args{'order'}} = $abc;
}
else {
$ABC{$args{'name'}}{$args{'order'}} = $abc;
}
}
}
}
}
sub __juntaabc {
my %p=@_;
my $vs= [sort {$a<=>$b} grep {/^\d+$/} keys %p];
$p{staves} ||= "[ ".join(" ",@$vs)." ]";
$p{T} ||= $p{name};
my $m1 = __getMeta($p{1} , rem => 'X V W T %%staves');
my $M2 = $p{meta} || $m1;
my $voices = "";
for (@$vs){ if($p{$_} =~ /\n(V:.*)/) {$voices .= "$1\n"}}
my $r=qq{X:1
T: $p{T}
$M2%
%%staves $p{staves}
$voices};
for (@$vs){
my $m1 = __getMeta($p{$_} , rem => 'X V W T C %%staves');
$r .= "V: $_\n$m1". __delMeta($p{$_}) ."\n\%\%\%-------------\n" }
$r
}
sub __delMeta {
my $a = shift;
my $b = qr([A-UVWZX]:|\%\%staves);
$a =~ s{(?:^|\n)($b)\s*(.*)}{}g;
$a =~ s{\n\n+}{\n}g;
$a =~ s{^\n+}{};
$a =~ s{\n+$}{};
$a;
}
sub __template_abc {
my $t=< >>
=head1 BUGS
Please report any bugs or feature requests to C, or through
the web interface at L. I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc Music::CoOpera
You can also look for information at:
=over 4
=item * RT: CPAN's request tracker
L
=item * AnnoCPAN: Annotated CPAN documentation
L
=item * CPAN Ratings
L
=item * Search CPAN
L
=back
=head1 ACKNOWLEDGEMENTS
=head1 LICENSE AND COPYRIGHT
Copyright 2011 Nuno Carvalho.
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.
=cut
1; # End of Music::CoOpera