Info.pm (5896B)
1 package SBO::Lib::Info; 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/ get_arch get_sbo_from_loc open_read script_error slurp usage_error /; 10 use SBO::Lib::Tree qw/ get_orig_location get_sbo_location is_local /; 11 12 use Exporter 'import'; 13 14 our @EXPORT_OK = qw{ 15 check_x32 16 get_download_info 17 get_from_info 18 get_orig_version 19 get_requires 20 get_sbo_version 21 parse_info 22 }; 23 24 our %EXPORT_TAGS = ( 25 all => \@EXPORT_OK, 26 ); 27 28 =pod 29 30 =encoding UTF-8 31 32 =head1 NAME 33 34 SBO::Lib::Info - Utilities to get data from SBo .info files. 35 36 =head1 SYNOPSIS 37 38 use SBO::Lib::Info qw/ get_reqs /; 39 40 my @reqs = @{ get_requires($sbo) }; 41 42 =head1 SUBROUTINES 43 44 =cut 45 46 =head2 check_x32 47 48 my $bool = check_x32($location); 49 50 C<check_x32()> checks if the SBo in C<$location> considers 64bit builds 51 C<UNTESTED> or C<UNSUPPORTED>, and if so returns a true value. Otherwise it 52 returns a false value. 53 54 =cut 55 56 # determine whether or not a given sbo is 32-bit only 57 sub check_x32 { 58 script_error('check_x32 requires an argument.') unless @_ == 1; 59 my $dl = get_from_info(LOCATION => shift, GET => 'DOWNLOAD_x86_64'); 60 return $$dl[0] =~ /UN(SUPPOR|TES)TED/ ? 1 : undef; 61 } 62 63 =head2 get_download_info 64 65 my $downloads = get_download_info(LOCATION => $location, X64 => $x64); 66 my $downloads = get_download_info(LOCATION => $location); 67 68 C<get_download_info()> takes a C<$location> to read a .info file in, and 69 C<$x64> which is a flag to determine if the x64 link should be used or not. 70 71 If the C<$x64> flag is not given, it defaults to a true value. 72 73 It returns a hashref where each key is a download link, and the corresponding 74 value is the md5sum it should have. 75 76 =cut 77 78 # get downloads and md5sums from an sbo's .info file, first 79 # checking for x86_64-specific info if we are told to 80 sub get_download_info { 81 my %args = ( 82 LOCATION => 0, 83 X64 => 1, 84 @_ 85 ); 86 $args{LOCATION} or script_error('get_download_info requires LOCATION.'); 87 my ($get, $downs, $exit, $md5s, %return); 88 $get = ($args{X64} ? 'DOWNLOAD_x86_64' : 'DOWNLOAD'); 89 $downs = get_from_info(LOCATION => $args{LOCATION}, GET => $get); 90 # did we get nothing back, or UNSUPPORTED/UNTESTED? 91 if ($args{X64}) { 92 if (! $$downs[0] || $$downs[0] =~ qr/^UN(SUPPOR|TES)TED$/) { 93 $args{X64} = 0; 94 $downs = get_from_info(LOCATION => $args{LOCATION}, 95 GET => 'DOWNLOAD'); 96 } 97 } 98 # if we still don't have any links, something is really wrong. 99 return() unless $$downs[0]; 100 # grab the md5s and build a hash 101 $get = $args{X64} ? 'MD5SUM_x86_64' : 'MD5SUM'; 102 $md5s = get_from_info(LOCATION => $args{LOCATION}, GET => $get); 103 return() unless $$md5s[0]; 104 $return{$$downs[$_]} = $$md5s[$_] for (keys @$downs); 105 return \%return; 106 } 107 108 =head2 get_from_info 109 110 my $data = get_from_info(LOCATION => $location, GET => $key); 111 112 C<get_from_info()> retrieves the information under C<$key> from the .info file 113 in C<$location>. 114 115 =cut 116 117 # pull piece(s) of data, GET, from the $sbo.info file under LOCATION. 118 sub get_from_info { 119 my %args = ( 120 LOCATION => '', 121 GET => '', 122 @_ 123 ); 124 unless ($args{LOCATION} && $args{GET}) { 125 script_error('get_from_info requires LOCATION and GET.'); 126 } 127 state $store = {LOCATION => ['']}; 128 my $sbo = get_sbo_from_loc($args{LOCATION}); 129 return $store->{$args{GET}} if $store->{LOCATION}[0] eq $args{LOCATION}; 130 131 # if we're here, we haven't read in the .info file yet. 132 my $contents = slurp("$args{LOCATION}/$sbo.info"); 133 usage_error("get_from_info: could not read $args{LOCATION}/$sbo.info.") unless 134 defined $contents; 135 136 my %parse = parse_info($contents); 137 script_error("error when parsing $sbo.info file.") unless %parse; 138 139 $store = {}; 140 $store->{LOCATION} = [$args{LOCATION}]; 141 foreach my $k (keys %parse) { $store->{$k} = $parse{$k}; } 142 143 # allow local overrides to get away with not having quite all the fields 144 if (is_local($sbo)) { 145 for my $key (qw/DOWNLOAD_x86_64 MD5SUM_x86_64 REQUIRES/) { 146 $store->{$key} //= ['']; # if they don't exist, treat them as empty 147 } 148 } 149 return $store->{$args{GET}}; 150 } 151 152 =head2 get_orig_version 153 154 my $ver = get_orig_version($sbo); 155 156 C<get_orig_version()> returns the version in the SlackBuilds.org tree for the 157 given C<$sbo>. 158 159 =cut 160 161 sub get_orig_version { 162 script_error('get_orig_version requires an argument.') unless @_ == 1; 163 my $sbo = shift; 164 165 my $location = get_orig_location($sbo); 166 167 return $location if not defined $location; 168 169 return get_sbo_version($location); 170 } 171 172 =head2 get_requires 173 174 my $reqs = get_requires($sbo); 175 176 C<get_requires()> returns the requirements for a given C<$sbo>. 177 178 =cut 179 180 # wrapper to pull the list of requirements for a given sbo 181 sub get_requires { 182 my $location = get_sbo_location(shift); 183 return undef unless $location; 184 my $info = get_from_info(LOCATION => $location, GET => 'REQUIRES'); 185 return $info; 186 } 187 188 =head2 get_sbo_version 189 190 my $ver = get_sbo_version($location); 191 192 C<get_sbo_version()> returns the version found in the .info file in 193 C<$location>. 194 195 =cut 196 197 # find the version in the tree for a given sbo (provided a location) 198 sub get_sbo_version { 199 script_error('get_sbo_version requires an argument.') unless @_ == 1; 200 my $version = get_from_info(LOCATION => shift, GET => 'VERSION'); 201 return $version->[0]; 202 } 203 204 =head2 parse_info 205 206 my %parse = parse_info($str); 207 208 C<parse_info()> parses the contents of an .info file from C<$str> and returns 209 a key-value list of it. 210 211 =cut 212 213 sub parse_info { 214 script_error('parse_info requires an argument.') unless @_ == 1; 215 my $info_str = shift; 216 my $pos = 0; 217 my %ret; 218 219 while ($info_str =~ /\G([A-Za-z0-9_]+)="([^"]*)"\s*(?:\n|\z)/g) { 220 my ($key, $val) = ($1, $2); 221 $val =~ s/\\[ \t]*$/ /mg; 222 my @val = split " ", $val; 223 @val = '' unless @val; 224 $ret{$key} = \@val; 225 $pos = pos($info_str); 226 } 227 228 return if $pos != length($info_str); 229 230 return %ret; 231 232 } 233 234 1;