view release on metacpan or  search on metacpan

lib/Clumps.pm  view on Meta::CPAN

# FIXME make this OO.
#
sub new_relation() {
    die 'usage: new_relation()' if @_;
    my %h; tie %h, 'Tie::RefHash';
    return \%h;
}
sub related( $$$ ) {
    die 'usage: related(relation, a, b)' if @_ != 3;
    my ($rel, $a, $b) = @_;
    my $list = $rel->{$a};
    return 0 if not defined $list;
    foreach (@$list) {
	return 1 if "$_" eq "$b";
    }
    return 0;
}
sub relate( $$$ ) {
    die 'usage: related(relation, a, b)' if @_ != 3;
    my ($rel, $a, $b) = @_;
    unless (related($rel, $a, $b)) {
	check_same_channel([$a, $b]);
	push @{$rel->{$a}}, $b;
	push @{$rel->{$b}}, $a;
    }
}
sub unrelate( $$$ ) {
    die 'usage: related(relation, a, b)' if @_ != 3;
    my ($rel, $a, $b) = @_;
    die unless related($rel, $a, $b) and related($rel, $b, $a);
    @{$rel->{$a}} = grep { "$_" ne "$b" } @{$rel->{$a}};
    @{$rel->{$b}} = grep { "$_" ne "$a" } @{$rel->{$b}};
}
sub nuke_from_rel( $$ ) {
    die 'usage: nuke_from_rel(relation, a)' if @_ != 2;
    my ($rel, $a) = @_;
    die unless ref($rel) eq 'HASH';
    foreach (@{relatives($rel, $a)}) {
	die unless related($rel, $a, $_);
	unrelate($rel, $a, $_);
    }

    # Tidy up by removing from hash
    die if defined $rel->{$a} and @{$rel->{$a}};
    delete $rel->{$a};
}
sub relatives( $$ ) {
    die 'usage: relatives(relation, a)' if @_ != 2;
    my ($rel, $a) = @_;
    die unless ref($rel) eq 'HASH';
    if ($rel->{$a}) {
	return [ @{$rel->{$a}} ]; # make a copy
    }
    else {
	return [];
    }
}


# Private.  Wrappers for Date::Manip and XMLTV::Date;
sub pd( $ ) {
    for ($_[0]) {
	return undef if not defined;
	return parse_date($_);
    }
}


# Make a relation grouping together programmes sharing a clump.
#
# Parameter: reference to list of programmes
#
# Returns: a relation saying which programmes share clumps.
#
sub clump_relation( $ ) {
    my $progs = shift;
    my $related = new_relation();
    my %todo;
    foreach (@$progs) {
	my $clumpidx = $_->{clumpidx};
	next if not defined $clumpidx or $clumpidx eq '0/1';
	push @{$todo{$_->{channel}}->{pd($_->{start})}}, $_;
    }
    t 'updating $related from todo list';
    foreach my $ch (keys %todo) {
	our %times; local *times = $todo{$ch};
	my $times = $todo{$ch};
	foreach my $t (keys %times) {
	    t "todo list for channel $ch, time $t";
	    my @l = @{$times{$t}};
	    t 'list of programmes: ' . d(\@l);
	    foreach my $ai (0 .. $#l) {
		foreach my $bi ($ai+1 .. $#l) {
		    my $a = $l[$ai]; my $b = $l[$bi];
		    t "$a and $b related";
		    die if "$a" eq "$b";
		    warn "$a, $b over-related" if related($related, $a, $b);
		    relate($related, $a, $b);
		}
	    }
	}
    }
    return $related;
}


# fix_clumps()
#
# When a programme sharing a clump has been modified or replaced,
# patch things up so that other things in the clump are consistent.
#
# Parameters:
#   original programme
#   (ref to) list of new programmes resulting from it
#   clump relation
#
# Modifies the programme and others in its clump as necessary.
#
sub fix_clumps( $$$ ) {
    die 'usage: fix_clumps(old programme, listref of replacements, clump relation)' if @_ != 3;
    my ($orig, $new, $rel) = @_;