This file is indexed.

/usr/share/perl5/XMLTV/Clumps.pm is in libxmltv-perl 0.5.63-2.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
# Routines for handling the 'clump index' associated with some
# programmes.  This is a way of working around missing information in
# some listings sources by saying that two or more programmes share a
# timeslot, they appear in a particular order, but we don't know the
# exact time when one stops and the next begins.
#
# For example if the listings source gives at 11:00 'News; Weather'
# then we know that News has start time 11:00 and clumpidx 0/2, while
# Weather has start time 11:00 and clumpidx 1/2.  We know that Weather
# follows News, and they are both in the 11:00 timeslot, but not more
# than that.
#
# This clumpidx stuff does its job, but it's ugly to deal with - as
# demonstrated by the existence of this library.  I plan to replace it
# soonish.
#
# The purpose of this module is to let you alter or delete programmes
# which are part of a clump without having to worry about updating the
# others.  The module exports routines for building a symmetric
# 'relation' relating pairs of scalars; you should use that to relate
# programmes which share a clump.  Then after modifying a programme
# which has a clumpidx set, call fix_clumps() passing in the relation,
# and it will modify the other programmes in the clump.
#
# Again, this all works but a better mechanism is needed.
#
# $Id: Clumps.pm,v 1.15 2004/01/06 20:42:36 epaepa Exp $
#

package XMLTV::Clumps;
use XMLTV::Date;
use Date::Manip; # no Date_Init(), that can be done by the app
use Tie::RefHash;

# Use Log::TraceMessages if installed.
BEGIN {
    eval { require Log::TraceMessages };
    if ($@) {
	*t = sub {};
	*d = sub { '' };
    }
    else {
	*t = \&Log::TraceMessages::t;
	*d = \&Log::TraceMessages::d;
    }
}

# Won't Memoize, you can do that yourself.
use base 'Exporter';
our @EXPORT_OK = qw(new_relation related relate unrelate nuke_from_rel
		    relatives clump_relation fix_clumps);

sub new_relation();
sub related( $$$ );
sub relate( $$$ );
sub unrelate( $$$ );
sub nuke_from_rel( $$ );
sub relatives( $$ );
sub clump_relation( $ );
sub fix_clumps( $$$ );
sub check_same_channel( $ ); # private


# Routines to handle a symmmetric 'relation'.  This is used to keep
# track of which programmes are sharing a clump so that fix_clumps()
# can sort them out if needed.
#
# 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) = @_;
    # Optimize common case.
    return if not defined $orig->{clumpidx} or $orig->{clumpidx} eq '0/1';
    die if ref($rel) ne 'HASH';
    die if ref($new) ne 'ARRAY';
    our @new; local *new = $new;
#    local $Log::TraceMessages::On = 1;
    t 'fix_clumps() ENTRY';
    t 'original programme: ' . d $orig;
    t 'new programmes: ' . d \@new;
    t 'clump relation: ' . d $rel;

    sub by_start { Date_Cmp(pd($a->{start}), pd($b->{start})) }
    sub by_clumpidx {
	$a->{clumpidx} =~ m!^(\d+)/(\d+)$! or die;
	my ($ac, $n) = ($1, $2);
	$b->{clumpidx} =~ m!^(\d+)/$n$! or die;
	my $bc = $1;
	if ($ac == $bc) {
	    t 'do not sort: ' . d($a) . ' and ' . d($b);
	    warn "$a->{clumpidx} and $b->{clumpidx} do not sort";
	}
	$ac <=> $bc;
    }
    sub by_date {
	by_start($a, $b)
	  || by_clumpidx($a, $b)
	    || warn "programmes do not sort";
    }

    my @relatives = @{relatives($rel, $orig)};
    if (not @relatives) {
#	local $Log::TraceMessages::On = 1;
	t 'programme without relatives: ' . d $orig;
	warn "programme has clumpidx of $orig->{clumpidx}, but cannot find others in same clump\n";
	return;
    }
    check_same_channel(\@relatives);
    @relatives = sort by_date @relatives;
    t 'relatives of orig (sorted): ' . d \@relatives;
    check_same_channel(\@new); # could relax this later
    t 'orig turned into: ' . d \@new;

    t 'how many programmes has $prog been split into?';
    if (@new == 0) {
	t 'deleted programme entirely!';
	nuke_from_rel($rel, $orig);

	if (@relatives == 0) {
	    die;
	}
	elsif (@relatives == 1) {
	    delete $relatives[0]->{clumpidx};
	}
	elsif (@relatives >= 2) {
	    # Just decrement the index of all following programmes.
	    my $orig_clumpidx = $orig->{clumpidx};
	    $orig_clumpidx =~ /^(\d+)/ or die;
	    $orig_clumpidx = $1;
	    foreach (@relatives) {
		my $rel_clumpidx = $_->{clumpidx};
		$rel_clumpidx =~ /^(\d+)/ or die;
		$rel_clumpidx = $1;
		-- $rel_clumpidx if $rel_clumpidx > $orig_clumpidx;
		$_->{clumpidx} = "$rel_clumpidx/" . scalar @relatives;
	    }
	}
	else { die }
    }
    elsif (@new >= 1) {
#	local $Log::TraceMessages::On = 1;
	t 'split into one or more programmes';
	@new = sort by_date @$new;
	nuke_from_rel($rel, $orig);
	
	if (@relatives) {
	    # Find where the original programme slotted into the clump
	    # and insert the new programmes there.
	    #
	    my @old_all = sort by_date ($orig, @relatives);
	    check_same_channel(\@old_all);
	    t 'old clump sorted by date (incl. orig): ' . d \@old_all;
	    @new = sort by_date @new;
	    t 'new shows sorted by date: ' . d \@new;

	    # Fix the start and end times of the other shows in the
	    # clump.  The shows in @new may give different (narrower)
	    # times to the one show they came from, so that we have
	    # more information about the start and end times of the
	    # other shows in the clump.  Eg 09:30 0/2 '09:30 AAA,
	    # 10:00 BBB' sharing a clump with 09:30 1/2 'CCC'.  When
	    # the first programme gets split into two, we know that
	    # the start time for C must be 10:00 at the earliest.
	    # Clear?
	    #
	    # Keep around both parsed and unparsed versions of the
	    # same date, to keep timezone information.  This needs to
	    # be handled better.
	    #
	    my $start_new_unp = $new->[0]->{start};
	    my $start_new = pd($start_new_unp);
	    t "new shows start at $start_new";

	    # The known stop time for @new is the last date
	    # mentioned.  Eg if the last show ends at 10:00 we know
	    # @new as a whole ends at 10:00.  But if the last show has
	    # no stop time but starts at 09:30 then we know @new as a
	    # whole ends at *at the earliest* 09:30.
	    #
	    my $stop_new;
	    foreach (reverse @new) {
		foreach (pd($_->{start}), pd($_->{stop})) {
		    next if not defined;
		    if (not defined $stop_new
			or Date_Cmp($_, $stop_new) > 0) {
			$stop_new = $_;
		    }
		}
	    }
	    t "lub of new shows is $stop_new";

	    # However if other shows shared a clump, they do not start
	    # at the stop time of @new!  They overlap with it.  The
	    # shows coming later in the clump will have the same start
	    # time as the last show of @new.
	    #
	    # For example, two shows in a clump from 10:00 to 11:00.
	    # The first is split into something at 10:00 and something
	    # at 10:30.  The second part of the original clump will
	    # now 'start' at 10:30 and overlap with the last of the
	    # new shows.
	    #
	    my $start_last_new_unp = $new[-1]->{start};
	    my $start_last_new = pd($start_last_new_unp);
	    t 'last of the new programmes starts at: ' . d $start_last_new;

	    # Add the programmes coming before @new to the output.
	    # These should have stop times before @new's start.
	    #
	    my @new_all;
	    t 'add shows coming before replaced one';
	    while (@old_all) {
		my $old = shift @old_all;
		last if $old eq $orig;
		t "adding 'before' show: " . d $old;
		die if not defined $old->{start};
		die if not defined $start_new;
		die unless Date_Cmp(pd($old->{start}), $start_new) <= 0;
		my $old_stop = pd($old->{stop});
		t 'has stop time: ' . d $old_stop;
# 		if (defined $old_stop) {
# 		    die if not defined $stop_new;
# 		    die "stop time $old_stop of old programme is earlier than lub of new shows $stop_new"
# 		      if Date_Cmp($old_stop, $stop_new) < 0;
# 		    die "stop time $old_stop of old programme is earlier than start of new shows $start_new"
# 		      if Date_Cmp($old_stop, $start_new) < 0;
# 		}
		$old->{stop} = $start_new_unp;
		t "set stop time to $old->{stop}";

		push @new_all, $old;
	    }

	    # Slot in the new programmes.
	    t 'got to orig show, slot in new programmes';
	    push @new_all, @new;
	    t 'so far, list of new programmes: ' . d \@new_all;

	    # Now the shows at the end, after the programme which was
	    # split.
	    #
	    t 'do shows coming after the orig one';
	    while (@old_all) {
		my $old = shift @old_all;
		t "doing 'after' show: " . d $old;
		my $old_start = pd($old->{start});
		die if not defined $old_start;
		t "current start time: $old_start";
		die if not defined $start_new;
		die if not defined $stop_new;
		die unless Date_Cmp($start_new, $old_start) <= 0;
		die unless Date_Cmp($old_start, $stop_new) <= 0;

		# These shows overlapped with the old programme.  So
		# now they will overlap with the last of the shows it
		# was split into.
		#
		$old->{start} = $start_last_new_unp;
		t "set start time to $old->{start}";
		t 'adding programme to list: ' . d $old;

		push @new_all, $old;
	    }

	    t 'new list of programmes from original clump: ' . d \@new_all;
	    check_same_channel(\@new_all);

	    t 'now regenerate the clumpidxes';
	    while (@new_all) {
		my $first = shift @new_all;
		t 'taking first programme from list: ' . d $first;
		t 'building clump for this programme';
		my @clump = ($first);
		my $start = pd($first->{start});
		die if not defined $start;
		while (@new_all) {
		    my $next = shift @new_all;
		    die if not defined $next->{start};
		    if (not Date_Cmp(pd($next->{start}), $start)) {
			push @clump, $next;
		    }
		    else {
			unshift @new_all, $next;
			last;
		    }
		}
		t 'clump is: ' . d \@clump;
		my $clump_size = scalar @clump;
		t "$clump_size shows in clump";
		for (my $i = 0; $i < $clump_size; $i++) {
		    my $c = $clump[$i];
		    if ($clump_size == 1) {
			t 'deleting clumpidx from programme';
			delete $c->{clumpidx};
		    }
		    else {
			$c->{clumpidx} = "$i/$clump_size";
			t "set clumpidx for programme to $c->{clumpidx}";
		    }
		}

		t 're-relating programmes in this clump (if more than one)';
		foreach my $a (@clump) {
		    foreach my $b (@clump) {
			next if $a == $b;
			relate($rel, $a, $b);
		    }
		}
	    }
	    t 'finished regenerating clumpidxes';
	}
    }
}


# Private.
sub check_same_channel( $ ) {
    my $progs = shift;
    my $ch;
    foreach my $prog (@$progs) {
	for ($prog->{channel}) {
	    if (not defined) {
		t 'no channel! ' . d $prog;
		die 'programme has no channel';
	    }
	    if (not defined $ch) {
		$ch = $_;
	    }
	    elsif ($ch eq $_) {
		# Okay.
	    }
	    else {
		t 'same clump, different channels: ' . d($progs->[0]) . ' and ' . d($prog);
		die "programmes in same clump have different channels: $_, $ch";
	    }
	}
    }
}


1;