Tree.pm (3719B)
1 package SBO::Lib::Tree; 2 3 use 5.016; 4 use strict; 5 use warnings; 6 7 our $VERSION = '2.9.0'; 8 9 use SBO::Lib::Util qw/ script_error open_read idx %config /; 10 use SBO::Lib::Repo qw/ $repo_path $slackbuilds_txt /; 11 12 use Exporter 'import'; 13 14 our @EXPORT_OK = qw{ 15 get_orig_location 16 get_sbo_location 17 get_sbo_locations 18 is_local 19 }; 20 21 our %EXPORT_TAGS = ( 22 all => \@EXPORT_OK, 23 ); 24 25 =pod 26 27 =encoding UTF-8 28 29 =head1 NAME 30 31 SBO::Lib::Tree - Routines for interacting with a SlackBuilds.org tree. 32 33 =head1 SYNOPSIS 34 35 use SBO::Lib::tree qw/ is_local /; 36 37 my $bool = is_local($sbo); 38 39 =head1 SUBROUTINES 40 41 =cut 42 43 # private variables needed by most subroutines 44 my $store; 45 my %local; 46 my %orig; 47 48 =head2 get_orig_location 49 50 my $loc = get_orig_location($sbo); 51 52 C<get_orig_location()> returns the location in the SlackBuilds.org tree for the 53 given C<$sbo>. 54 55 =cut 56 57 sub get_orig_location { 58 script_error('get_orig_location requires an argument.') unless @_ == 1; 59 my $sbo = shift; 60 # Make sure we have checked for the slackbuild in question: 61 get_sbo_location($sbo); 62 return $orig{$sbo}; 63 } 64 65 =head2 get_sbo_location 66 67 my $loc = get_sbo_location($sbo, ...); 68 my $loc = get_sbo_location([$sbo, ...]); 69 70 C<get_sbo_location()> returns the location in the C<LOCAL_OVERRIDES> or the 71 SlackBuilds.org tree for the first C<$sbo> given. 72 73 Specifying more than one C<$sbo> is useful for only needing to access the 74 filesystem once when searching, and populating the internal cache. 75 76 =cut 77 78 sub get_sbo_location { 79 my @sbos = map { s/-compat32$//r } defined $_[0] && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; 80 script_error('get_sbo_location requires an argument.') unless @sbos; 81 82 # if we already have the location, return it now. 83 return $$store{$sbos[0]} if exists $$store{$sbos[0]}; 84 my %locations = get_sbo_locations(@sbos); 85 return $locations{$sbos[0]}; 86 } 87 88 =head2 get_sbo_locations 89 90 my %locations = get_sbo_locations(@sbos); 91 92 C<get_sbo_locations> tries to find all C<@sbos> and returns a hash matching the 93 package name to its location. 94 95 =cut 96 97 sub get_sbo_locations { 98 my @sbos = map { s/-compat32$//r } defined $_[0] && ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; 99 script_error('get_sbo_locations requires an argument.') unless @_; 100 101 my %locations; 102 103 # if an sbo is already in the $store, set the %location for it and filter it out 104 @sbos = grep { exists $$store{$_} ? ($locations{$_} = $$store{$_}, 0) : 1 } @sbos; 105 return %locations unless @sbos; 106 107 my ($fh, $exit) = open_read($slackbuilds_txt); 108 if ($exit) { 109 warn $fh; 110 exit $exit; 111 } 112 113 while (my $line = <$fh>) { 114 my ($loc, $sbo) = $line =~ m!LOCATION:\s+\.(/[^/]+/([^/\n]+))$! 115 or next; 116 my $found = idx($sbo, @sbos); 117 next unless defined $found; 118 119 $$store{$sbo} = $repo_path . $loc; 120 $locations{$sbo} = $$store{$sbo}; 121 122 splice @sbos, $found, 1; 123 last unless @sbos; 124 } 125 close $fh; 126 127 # after we've checked the regular sbo locations, we'll see if it needs to 128 # be overridden by a local change 129 my $local = $config{LOCAL_OVERRIDES}; 130 unless ( $local eq 'FALSE' ) { 131 for my $sbo (@sbos, keys %locations) { 132 my $loc = "$local/$sbo"; 133 next unless -d $loc; 134 $$store{$sbo} = $loc; 135 $orig{$sbo} //= $locations{$sbo}; 136 $locations{$sbo} = $loc; 137 $local{$sbo} = $local; 138 } 139 } 140 141 return %locations; 142 } 143 144 =head2 is_local 145 146 my $bool = is_local($sbo); 147 148 C<is_local()> checks whether the given C<$sbo> is in the C<LOCAL_OVERRIDES> or 149 not, and returns a true value if it is, and a false value if it isn't. 150 151 =cut 152 153 sub is_local { 154 script_error('is_local requires an argument.') unless @_ == 1; 155 my $sbo = shift; 156 # Make sure we have checked for the slackbuild in question: 157 get_sbo_location($sbo); 158 return !!$local{$sbo}; 159 } 160 161 1;