package Wiki::Score;
use warnings;
use strict;
use File::Find;
use File::Slurp qw/slurp/;
use Data::Dumper;
use Template;
use Wiki::Score::Templates;
=head1 NAME
Wiki::Score - The great new Wiki::Score!
=head1 VERSION
Version 0.01
=cut
our $VERSION = '0.01';
my $WIKIROOT;
my %conf;
my $force;
my $dest;
my @files;
my %ABC;
my %ABC2;
=head1 SYNOPSIS
Quick summary of what the module does.
Perhaps a little code snippet.
use Wiki::Score;
my $foo = Wiki::Score->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 $DATA = 'data/pages';
my $MEDIA = '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 $DATA = 'data/pages';
my $MEDIA = 'data/media';
my $TMPDIR = '/tmp/multiabc';
find(\&__proc_file, $DATA);
mkdir $TMPDIR unless -e $TMPDIR;
chdir $TMPDIR;
my @files;
my @cleanup;
open my $ttt, ">", "/tmp/multiabc/join2.abc";
print $ttt __join_parts($filter);
close $ttt;
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 build_part
=cut
sub build_part {
my ($WIKIROOT, $id, $p) = @_;
#my $DATA = $WIKIROOT.'/data/pages';
#my $MEDIA = $WIKIROOT.'/data/media';
my $DATA = 'data/pages';
my $MEDIA = 'data/media';
my $TMPDIR = '/tmp/multiabc';
find(\&__proc_file, $DATA);
mkdir $TMPDIR unless -e $TMPDIR;
chdir $TMPDIR;
my @files;
my @cleanup;
my $target = "/tmp/multiabc/${id}_p${p}";
open my $ttt, ">", "$target.abc";
print $ttt __join_parts($id,$p);
close $ttt;
`/usr/bin/abcm2ps -c $target.abc -O $target.ps`;
`/usr/bin/ps2pdf -sPAPERSIZE=a4 $target.ps $target.pdf`;
}
=head2 build_section
=cut
sub build_section {
my ($WIKIROOT, $id, $s) = @_;
#my $DATA = $WIKIROOT.'/data/pages';
#my $MEDIA = $WIKIROOT.'/data/media';
my $DATA = 'data/pages';
my $MEDIA = 'data/media';
my $TMPDIR = '/tmp/multiabc';
find(\&__proc_file, $DATA);
mkdir $TMPDIR unless -e $TMPDIR;
chdir $TMPDIR;
my @files;
my @cleanup;
my $target = "/tmp/multiabc/${id}_s${s}";
open my $ttt, ">", "$target.abc";
print $ttt __join_sections($id,$s);
close $ttt;
`/usr/bin/abcm2ps -c $target.abc -O $target.ps`;
`/usr/bin/ps2pdf -sPAPERSIZE=a4 $target.ps $target.pdf`;
}
=head2 __fix_permissions
=cut
sub __fix_permissions {
my @files = @_;
my @stat = stat('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";
if ($conf{'original'}) {
$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";
$res .= "^";
for my $s (1 .. $conf{'sections'}) {
$res .= " Section $s ^";
}
$res .= " \n|";
for my $p (1 .. $conf{'parts'}) {
for my $s (1 .. $conf{'sections'}) {
$res .= " 
";
$res .= " [[$conf{'slug'}:s${s}_p$p|Section $s Part $p]] |";
__create_part($s,$p,$dest,%conf);
}
$res .= " | \n|";
}
for my $s (1 .. $conf{'sections'}) {
$res .= " |";
}
$res .= " | \n"; # XXX
$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 ($s,$p,$dest,%conf) = @_;
$conf{'barpp'} ||=5;
return if -e "$dest/s${s}_p${p}.txt" && !$force;
my $c = "===== $conf{'name'} =====\n\n";
if ($conf{'original'}) {
$c .= " * [[$conf{'original'}|Pdf Original]]\n";
}
else {
$c .= " * __\n";
}
$c .= "==== Section $s Part $p ====\n\n";
my $add = $s+$p; # XXX
$c .= qq{
% multiabc name=final.pdf ns=$conf{'slug'} s=$s p=$p order=$add\nX: $s - $p\n};
$c .= __texpand($conf{template},(%conf,
part_number => $p,
voice_def => qq{%%staves $p\nV:$p clef=treble name="S$s P$p" sname="S$s P$p"}));
$c .= "\n\n";
$c .= "\n[[$conf{'slug'}:index|Voltar ao index do projecto]]\n";
open my $fh, ">", "$dest/s${s}_p${p}.txt";
print $fh $c;
close $fh;
push @files, "$dest/s${s}_p${p}.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 $_;
return unless $_ =~ m/\.txt$/;;
return if $_ eq 'final.txt';
my $file = $_;
print STDERR "Processing $file\n";
my $c = slurp($file, binmode => ':utf8');
while ($c =~ m/(.*?)<\/abc>/gsi) {
print STDERR "\tFound abc\n";
my $abc = $1;
if ($abc =~ m/multiabc\s+(.*?)\n/) {
my $mabc = $1;
my %args;
print STDERR "\tFound multiabc: $mabc\n";
while ($mabc =~ m/([^=\s]+?)\s*=([^=\s]+)/g) {
$args{$1} = $2;
}
return unless $args{'s'};
return unless $args{'p'};
$ABC2{"$args{'ns'}:$args{'name'}"}{$args{'s'}}{$args{'p'}} = $abc;
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 __join_parts {
my ($filter, $p) = @_;
$filter .= ':final.pdf'; # XXX get name
$p = 1 unless $p;
my $line = $ABC2{$filter}{$p};
my $parts = [];
my $preamble;
foreach (sort keys %$line) {
my $abc = $ABC2{$filter}{$p}{$_};
$abc =~ s/\n+\s*$/\n/;
my ($left, $right) = split /%\n/, $abc;
$preamble = $left;
push @$parts, $right;
}
__process('join_h', {'preamble'=>$preamble, 'parts'=>$parts});
}
sub __join_sections {
my ($filter, $s) = @_;
$filter .= ':final.pdf'; # XXX get name
$s = 1 unless $s;
my $preamble = '';
my $sections = [];
foreach (sort keys %{$ABC2{$filter}}) {
my $abc = $ABC2{$filter}{$s}{$_};
push @$sections, $abc;
}
__process('join_v', {'preamble'=>$preamble, 'sections'=>$sections});
}
sub __process {
my ($template_name,$vars) = @_;
my $template_config = {
INCLUDE_PATH => [ 'templates' ],
};
my $template = Template->new({
LOAD_TEMPLATES => [ Wiki::Score::Templates->new($template_config) ],
});
my $output;
$template->process($template_name, $vars, \$output);
return $output;
}
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 Wiki::Score
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 Wiki::Score