File Coverage

blib/lib/Music/ABC/Archive.pm

Criterion	Covered	Total	%
statement	138	159	86.7
branch	40	68	58.8
condition	8	15	53.3
subroutine	14	17	82.3
pod	8	11	72.7
total	208	270	77.0

package Music::ABC::Archive;

use 5.008;
use strict;
use warnings;
use Carp ;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(new parse openabc filename list_by_title get_song print_song_summary get_song_titles) ] );

our @EXPORT_OK = qw(new parse openabc filename list_by_title get_song print_song_summary) ;
our @EXPORT = ( );

our $VERSION = '0.02';

use Music::ABC::Song ;

my (@header_lines, %Song_objs, %Song_data, %Unique_display_name) ;

sub new
{
    my $class = shift ;
    my $self = {} ;
    my $filename = shift ;
    $self->{FILENAME} = "" ;

    if(defined($filename)) {
	$self->{FILENAME} = $filename ;
    }

    bless ($self, $class) ;
    $self->{Is_parsed} = 0 ;
    $self->{File_is_open} = 0 ;
    return $self ;
}

sub abc_reset
{
    my $self = shift ;
    $self->{Is_parsed} = 0 ;
    %Song_data = () ;
    %Song_objs = () ;
    %Unique_display_name = () ;
    #close($self->{fh}) if $self->{File_is_open} ;
    #$self->{File_is_open} = 0 ;
}

sub filename
{
    my $self = shift ;
    my $newfilename = shift ;

    if($newfilename) {
	if($newfilename ne $self->{FILENAME}) {
	    $self->{FILENAME} = $newfilename ;
	    $self->abc_reset() ;
	}
    }

    return $self->{FILENAME} ;
}

sub openabc
{
    my $self = shift ;
    my $filename = shift ;
    my $fh ;

    if(defined($filename)) {
	$self->{FILENAME} = $filename ;
    }

    close($self->{fh}) if $self->{File_is_open} ;
    $self->{File_is_open} = 0 ;

    open($fh, "<$self->{FILENAME}") || return 0 ;
    $self->{fh} = $fh ;
    $self->{File_is_open} = 1 ;

    return 1 ;
}

sub parse
{
    my $self = shift ;
    return if $self->{Is_parsed} ;

    $self->openabc() if !$self->{File_is_open} ;

    my $display_name ;
    my $currpos = tell(${$self->{fh}}) ;
    my $songnumber ;
    my $type = "" ;
    my $key = "" ;
    my $meter = "" ;
    my $currobj ;
    my $songnum ;
    my $fname = $self->{FILENAME} ;
    my $in_song = 0 ;
    my $in_songs = 0 ;
    my $found_meter = 0 ;
    my $found_type = 0 ;
    my $fh = $self->{fh} ;


    while (<$fh>) {
	#print ;
	chomp ;
	s/\r// ;
	s/\n// ;
	my $text = $_ ;
	#print "$t[0] $t[1]\n" ;

	## 4 header types we need to explicity detect X,T,M and R
	if (/^X\:/) {
	    my @t = split(':') ;
	    $t[1] = "" if(!defined($t[1])) ;
	    $t[1] =~ s/^\s+//; # trim leading whitespace
	    $t[1] =~ s/\s+$//; # trim trailing whitespace
	    $songnum = $t[1] + 0 ;
	    $Song_objs{$songnum} = Music::ABC::Song->new(archivename=>$fname, number=>$songnum) ;
	    $Song_objs{$songnum}->filepos($currpos) ;
	    $in_song = 0 ;
	} elsif (/^T\:/) {
	    my @t = split(':') ;
	    $t[1] = "" if(!defined($t[1])) ;
	    $t[1] =~ s/^\s+//; # trim leading whitespace
	    $t[1] =~ s/\s+$//; # trim trailing whitespace
	    my $append = "" ;
	    my $name = $t[1] ;


	    my $display_name = $name . $append ;

	    while (defined($Unique_display_name{$display_name})) {
		if($append eq "") {
		    $append = 2 ;
		} else {
		    $append++ ;
		}
		$display_name = $name . " (" . $append . ")" ;
	    }

	    $Song_objs{$songnum}->display_name($display_name) ;

	    # set the display_name in the unique hash so we can avoid
	    # future name collisions
	    $Unique_display_name{$display_name} = 1 ;

	} elsif (/^R\:/) {
	    my @t = split(':') ;
	    $t[1] = "" if(!defined($t[1])) ;
	    $type = $t[1] ;
	} elsif (/^M\:/) {
	    my @t = split(':') ;
	    $t[1] = "" if(!defined($t[1])) ;
	    $meter = $t[1] ;
	}


	if(/^%/) {
	    # this line silently passes through, but
	    # isn't necessarily the start of the song
	    if(!$in_songs) {
		push @header_lines, $_ ;

	    }
	}

	if($songnum) {
	    if (/^(.):/) {
		my ($code, @v) = split(':') ;
		my $text = join ":", @v ;
		if($in_song || !($1 =~/[MR]/)) {
		    $Song_objs{$songnum}->header($1, $text) if($1 ne "|") ;
		}
	    } else {
		if(!$in_song) {
		    # type (R) and meter (M) headers are inherited from
		    # any previous occurences, or the ones we found in this song
		    # so we set them, and output them here just before the song text ;
		    $Song_objs{$songnum}->header("R", $type) ;
		    $Song_objs{$songnum}->header("M", $meter) ;
		    $Song_objs{$songnum}->type($type) ;
		    $Song_objs{$songnum}->meter($meter) ;
		}
		$in_song = 1 ;
		$in_songs = 1 ;
	    }

	    $Song_objs{$songnum}->text($_) ;
	}

	$currpos = tell($self->{fh}) ;
    }

    $self->{Is_parsed} = 1 ;
}

sub get_song
{
    my $self = shift ;
    my $songnum = shift ;
    my $no_headers = @_ || 0 ;
    my @data ;

    eval {
	$self->parse() if(!$self->{Is_parsed}) ;

	foreach(@{$Song_objs{$songnum}->text()}) {
	    next if /^[A-Z]:/ && $no_headers ;
	    next if /^[a-z]:/ && $no_headers ;
	    push (@data, $_) ;
	}
    } ;

    croak "get_song failed" if ($@) ;

    return @data ;
}

sub get_archive_header_lines
{
    my $self = shift ;
    eval {
	$self->parse() if(!$self->{Is_parsed}) ;
    } ;

    croak "get_archive_header_lines failed" if ($@) ;

    #print "Returning Header Lines:\n@header_lines\n" ;

    return @header_lines ;
}

sub print_song_summary
{
    my $self = shift ;
    my $songnum = shift ;
    my $use_html_tags = shift || 0 ;
    my @data ;

    $self->parse() if(!$self->{Is_parsed}) ;

    my $sr = $Song_objs{$songnum} ;

    return $sr->get_song_summary($use_html_tags) ;
}

sub by_name
{
    my $hrefa = $Song_objs{$a} ;
    my $hrefb = $Song_objs{$b} ;

    return $hrefa->display_name() cmp $hrefb->display_name() ;
}


sub list_by_title
{
    my $self = shift ;
    my @data ;

    $self->parse() if(!$self->{Is_parsed}) ;

    foreach my $songnum (sort by_name keys %Song_objs) {
	push (@data, [$Song_objs{$songnum}->display_name(),
		      $songnum,
		      $Song_objs{$songnum}->type(),
		      $Song_objs{$songnum}->meter(),
		      $Song_objs{$songnum}->key(),
		      $Song_objs{$songnum}->titles(),
		      ]) ;
    }

    return @data ;
}

sub get_song_titles
{
    my $self = shift ;
    my $songnum = shift || return undef ;

    $self->parse() if(!$self->{Is_parsed}) ;

    return @{$Song_objs{$songnum}->titles()} ;
}

sub DESTROY
{
    my $self = shift ;
    close($self->{fh}) if $self->{File_is_open} ;
}

1;
__END__