25167493130

Committed 30 Apr 2026 01:23PM UTC coverage: 83.837% (+0.05%) from 83.787%

Build # 25167493130

Build Type

push

github

Committed by

Commit Message

Coverage Stats

8740 of 10425 relevant lines covered (83.84%)

461.51 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

83.58

/lib/HTFeed/RepositoryIterator.pm

#!/usr/bin/perl

use strict;
use warnings;

use Cwd;
use File::Basename;
use File::Pairtree qw(ppath2id s2ppchars);

package HTFeed::RepositoryIterator;

# The only restriction on `path` is that it must have a component ending with `sdrX`
# where X is one or more digits
sub new {
  my $class = shift;
  my $path  = shift;

  # Resolve symlinks e.g., /sdr1 -> /sdr/1
  $path = Cwd::abs_path($path);
  # Remove trailing slash from path if necessary
  $path =~ s!/$!!;
  my @pathcomp = split('/', $path);
  # remove base & any empty components
  #@pathcomp = grep { $_ ne '' } @pathcomp;
  my $sdr_partition = undef;
  if ($path =~ qr!/?sdr/?(\d+)/?!) {
    $sdr_partition = $1;
  } else {
    die "Cannot infer SDR partition from $path";
  }
  my $self = {
    # The path to traverse. May be a subpath like /tmp/sdr1/obj/test
    path => $path,
    sdr_partition => $sdr_partition,
    objects_processed => 0,
  };
  bless($self, $class);
  return $self;
}

sub next_object {
  my $self = shift;

  my $obj = undef;
  while (1) {
    my $line = readline($self->_find_pipe);
    last unless defined $line;
    chomp $line;
    # Pairtree stuff
    next if $line =~ /pairtree_prefix$/;
    next if $line =~ /pairtree_version/;
    # ignore temporary location
    next if $line =~ qr(obj/\.tmp);
    #next if $line =~ /\Qpre_uplift.mets.xml\E/;
    #next if $self->_recent_previous_version($line);

    my ($file_objid, $path, $type) = File::Basename::fileparse($line);
    # Remove trailing slash
    $path =~ s!/$!!; 
    next if $self->{prev_path} and $path eq $self->{prev_path};

    $self->{objects_processed}++;
    $self->{prev_path} = $path;

    # Remove everything up to and including the `sdrX/` or `sdr/X`
    my $subpath = $path;
    $subpath =~ s!.*?sdr/?\d+/!!;
    my @pathcomp = split('/', $subpath);
    @pathcomp = grep { $_ ne '' } @pathcomp;
    my $namespace = $pathcomp[1];
    my $directory_objid = pop @pathcomp;
    my $objid = File::Pairtree::ppath2id(join('/', @pathcomp));
    $obj = {
      path => $path,
      namespace => $namespace,
      # Caller should make sure objid and directory_objid are equivalent,
      # and also that objid matches the contents
      objid => $objid,
      directory_objid => $directory_objid,
      contents => $self->_contents($path),
    };
    last;
  }
  return $obj;
}

sub close {
  my $self = shift;

  if ($self->{find_pipe}) {
    close $self->{find_pipe};
    $self->{find_pipe} = undef;
  }
}

# Returns a sorted arrayref with filenames (not full paths) in
# an object directory. Excludes . and ..
sub _contents {
  my $self = shift;
  my $path = shift;

  my @contents;
  opendir(my $dh, $path);
  while ( my $file = readdir($dh) ) {
    next if $file eq '.' or $file eq '..';
    push(@contents, $file);
  }
  @contents = sort @contents;
  return \@contents;
}

sub _find_pipe {
  my $self = shift;

  if (!$self->{find_pipe}) {
    my $find_pipe;
    my $find_cmd = "find $self->{path} -type f|";
    open($find_pipe, $find_cmd) or die("Can't open pipe to find: $!");
    $self->{find_pipe} = $find_pipe;
  }
  return $self->{find_pipe};
}

# NOTE: is this needed?
# Does file end with `.old` suffix and is it less than 48 hours old?
sub _recent_previous_version {
  my $self = shift;
  my $file = shift;

  if ($file =~ /.old$/) {
    my $ctime = ( stat($file) )[10];
    my $ctime_age = time() - $ctime;
    return 1 if $ctime_age < (86400 * 2);
  }
}

1;

1	#!/usr/bin/perl
2
3	use strict;	1✔
4	use warnings;	1✔
5
6	use Cwd;	1✔
7	use File::Basename;	1✔
8	use File::Pairtree qw(ppath2id s2ppchars);	1✔
9
10	package HTFeed::RepositoryIterator;
11
12	# The only restriction on `path` is that it must have a component ending with `sdrX`
13	# where X is one or more digits
14	sub new {
15	my $class = shift;	5✔
16	my $path = shift;	5✔
17
18	# Resolve symlinks e.g., /sdr1 -> /sdr/1
19	$path = Cwd::abs_path($path);	5✔
20	# Remove trailing slash from path if necessary
21	$path =~ s!/$!!;	5✔
22	my @pathcomp = split('/', $path);	5✔
23	# remove base & any empty components
24	#@pathcomp = grep { $_ ne '' } @pathcomp;
25	my $sdr_partition = undef;	5✔
26	if ($path =~ qr!/?sdr/?(\d+)/?!) {	5✔
27	$sdr_partition = $1;	5✔
28	} else {
29	die "Cannot infer SDR partition from $path";	×
30	}
31	my $self = {	5✔
32	# The path to traverse. May be a subpath like /tmp/sdr1/obj/test
33	path => $path,
34	sdr_partition => $sdr_partition,
35	objects_processed => 0,
36	};
37	bless($self, $class);	5✔
38	return $self;	5✔
39	}
40
41	sub next_object {
42	my $self = shift;	10✔
43
44	my $obj = undef;	10✔
45	while (1) {	10✔
46	my $line = readline($self->_find_pipe);	16✔
47	last unless defined $line;	16✔
48	chomp $line;	12✔
49	# Pairtree stuff
50	next if $line =~ /pairtree_prefix$/;	12✔
51	next if $line =~ /pairtree_version/;	12✔
52	# ignore temporary location
53	next if $line =~ qr(obj/\.tmp);	12✔
54	#next if $line =~ /\Qpre_uplift.mets.xml\E/;
55	#next if $self->_recent_previous_version($line);
56
57	my ($file_objid, $path, $type) = File::Basename::fileparse($line);	12✔
58	# Remove trailing slash
59	$path =~ s!/$!!;	12✔
60	next if $self->{prev_path} and $path eq $self->{prev_path};	12✔
61
62	$self->{objects_processed}++;	6✔
63	$self->{prev_path} = $path;	6✔
64
65	# Remove everything up to and including the `sdrX/` or `sdr/X`
66	my $subpath = $path;	6✔
67	$subpath =~ s!.*?sdr/?\d+/!!;	6✔
68	my @pathcomp = split('/', $subpath);	6✔
69	@pathcomp = grep { $_ ne '' } @pathcomp;	6✔
70	my $namespace = $pathcomp[1];	6✔
71	my $directory_objid = pop @pathcomp;	6✔
72	my $objid = File::Pairtree::ppath2id(join('/', @pathcomp));	6✔
73	$obj = {	6✔
74	path => $path,
75	namespace => $namespace,
76	# Caller should make sure objid and directory_objid are equivalent,
77	# and also that objid matches the contents
78	objid => $objid,
79	directory_objid => $directory_objid,
80	contents => $self->_contents($path),
81	};
82	last;	6✔
83	}
84	return $obj;	10✔
85	}
86
87	sub close {
88	my $self = shift;	×
89
90	if ($self->{find_pipe}) {	×
91	close $self->{find_pipe};	×
92	$self->{find_pipe} = undef;	×
93	}
94	}
95
96	# Returns a sorted arrayref with filenames (not full paths) in
97	# an object directory. Excludes . and ..
98	sub _contents {
99	my $self = shift;	6✔
100	my $path = shift;	6✔
101
102	my @contents;	6✔
103	opendir(my $dh, $path);	6✔
104	while ( my $file = readdir($dh) ) {	6✔
105	next if $file eq '.' or $file eq '..';	24✔
106	push(@contents, $file);	12✔
107	}
108	@contents = sort @contents;	6✔
109	return \@contents;	6✔
110	}
111
112	sub _find_pipe {
113	my $self = shift;	16✔
114
115	if (!$self->{find_pipe}) {	16✔
116	my $find_pipe;	4✔
117	my $find_cmd = "find $self->{path} -type f\|";	4✔
118	open($find_pipe, $find_cmd) or die("Can't open pipe to find: $!");	4✔
119	$self->{find_pipe} = $find_pipe;	4✔
120	}
121	return $self->{find_pipe};	16✔
122	}
123
124	# NOTE: is this needed?
125	# Does file end with `.old` suffix and is it less than 48 hours old?
126	sub _recent_previous_version {
127	my $self = shift;	×
128	my $file = shift;	×
129
130	if ($file =~ /.old$/) {	×
131	my $ctime = ( stat($file) )[10];	×
132	my $ctime_age = time() - $ctime;	×
133	return 1 if $ctime_age < (86400 * 2);	×
134	}
135	}
136
137	1;

hathitrust / feed / 25167493130

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous