├── Portscout.pm ├── Portscout ├── API.pm ├── Config.pm ├── Const.pm ├── DataSrc.pm ├── DataSrc │ ├── Ports.pm │ └── XML.pm ├── Make.pm ├── SQL.pm ├── SQL │ ├── Pg.pm │ └── SQLite.pm ├── SiteHandler.pm ├── SiteHandler │ ├── GitHub.pm │ ├── PyPI.pm │ └── SourceForge.pm ├── Template.pm └── Util.pm ├── README ├── UPDATING ├── docs ├── portscout-portconfig.txt └── xml-datasrc-example.xml ├── portscout.conf ├── portscout.pl ├── portscout.pod ├── sql ├── pgsql_destroy.sql ├── pgsql_init.sql ├── pgsql_upgrade_0.7.1_to_0.7.2.sql ├── pgsql_upgrade_0.7.3_to_0.7.4.sql ├── pgsql_upgrade_0.7.4_to_0.8.sql ├── pgsql_upgrade_0.8_to_0.8.1.sql ├── sqlite_destroy.sql ├── sqlite_init.sql └── sqlite_upgrade_0.8_to_0.8.1.sql ├── t ├── 00-use.t ├── 01-vercompare.t ├── 10-postgresql.t └── 10-sqlite.t ├── templates ├── index.html ├── maintainer.html ├── reminder-no-maintainer.mail ├── reminder.mail └── restricted-ports.html └── web └── rss.cgi /Portscout.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2006-2010, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: Portscout.pm,v 1.6 2010/05/05 01:54:16 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout; 30 | 31 | use strict; 32 | 33 | require 5.006; 34 | 35 | use Portscout::SQL; 36 | use Portscout::SiteHandler; 37 | use Portscout::DataSrc; 38 | use Portscout::Template; 39 | 40 | 41 | 1; 42 | -------------------------------------------------------------------------------- /Portscout/API.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2011, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: API.pm,v 1.8 2011/05/15 17:27:05 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::API; 30 | 31 | use Portscout::Const; 32 | use Portscout::Util; 33 | use Portscout::Config; 34 | 35 | require Exporter; 36 | 37 | use strict; 38 | 39 | require 5.006; 40 | 41 | our @ISA = qw(Exporter); 42 | 43 | 44 | #------------------------------------------------------------------------------ 45 | # Func: new() 46 | # Desc: Constructor. 47 | # 48 | # Args: n/a 49 | # 50 | # Retn: $self 51 | #------------------------------------------------------------------------------ 52 | 53 | sub new 54 | { 55 | my $self = {}; 56 | my $class = shift; 57 | 58 | $self->{dbh} = connect_db(); 59 | $self->{sths} = {}; 60 | 61 | prepare_sql( 62 | $self->{dbh}, 63 | $self->{sths}, 64 | qw(portdata_exists portdata_update portdata_insert sitedata_exists 65 | sitedata_insert portdata_getver portdata_getnewver 66 | portdata_clearnewver portconfig_update portconfig_isstatic) 67 | ); 68 | 69 | bless ($self, $class); 70 | return $self; 71 | } 72 | 73 | 74 | #------------------------------------------------------------------------------ 75 | # Func: AddPort() 76 | # Desc: Add an item of software (port) to the database. 77 | # 78 | # Args: \%port - Hash containing data: 79 | # name - Port name (required) 80 | # category - Category (required) 81 | # version - Current port version (required) 82 | # maintainer - Port maintainer e-mail (required) 83 | # distfiles - Array of filenames. (required) 84 | # sites - Array of sites to find files (required) 85 | # distname - "distname" (as in ports) 86 | # suffix - Distfile suffix (e.g. ".tar.gz") 87 | # comment - Description of port 88 | # masterport - "cat/name" of this port's master 89 | # options - Hash of port options, from "PORTSCOUT" var. 90 | # 91 | # Retn: $success - true/false 92 | #------------------------------------------------------------------------------ 93 | 94 | sub AddPort 95 | { 96 | my ($self) = shift; 97 | my ($port) = @_; 98 | 99 | my ($exists, $iss, $_distfiles, $_sites); 100 | 101 | my $dbh = $self->{dbh}; 102 | my $sths = $self->{sths}; 103 | 104 | my $nvcleared = 0; 105 | 106 | # Check for required fields 107 | 108 | foreach my $key (qw( 109 | name category version maintainer distfiles sites 110 | )) { 111 | if (!exists $port->{$key} || !$port->{$key}) { 112 | print STDERR "Insufficient data for port " 113 | . "$port->{category}/$port->{name}: missing $key\n"; 114 | return 0; 115 | } 116 | } 117 | 118 | foreach my $key (qw(sites distfiles)) { 119 | if (ref $port->{$key} ne 'ARRAY') { 120 | if ($port->{$key} =~ /\s/) { 121 | print STDERR "Wrong format for $key: should be an arrayref or single item.\n"; 122 | return 0; 123 | } 124 | $port->{$key} = [ $port->{$key} ]; 125 | } 126 | } 127 | 128 | # Optional fields 129 | 130 | $port->{distname} ||= ''; 131 | $port->{suffix} ||= ''; 132 | $port->{comment} ||= ''; 133 | $port->{masterport} ||= ''; 134 | $port->{options} ||= {}; 135 | 136 | # Sanity checks 137 | 138 | if ($port->{name} =~ /[\s\/]/ || $port->{category} =~ /[\s\/]/) { 139 | print STDERR "Bad port name or category provided.\n"; 140 | return 0; 141 | } 142 | 143 | # Add port to database 144 | 145 | $sths->{portdata_exists}->execute($port->{name}, $port->{category}); 146 | ($exists) = $sths->{portdata_exists}->fetchrow_array; 147 | 148 | $_sites = join(' ', @{$port->{sites}}); 149 | $_distfiles = join(' ', @{$port->{distfiles}}); 150 | 151 | if ($exists) 152 | { 153 | my $oldver; 154 | 155 | # Clear newver if current version changed. 156 | $sths->{portdata_getver}->execute($port->{name}, $port->{category}); 157 | ($oldver) = $sths->{portdata_getver}->fetchrow_array; 158 | if ($oldver ne $port->{version}) { 159 | $sths->{portdata_clearnewver}->execute($port->{name}, $port->{category}) 160 | unless ($settings{precious_data}); 161 | $nvcleared = 1; 162 | } 163 | 164 | $sths->{portdata_update}->execute( 165 | $port->{version}, 166 | $port->{comment}, 167 | $port->{category}, 168 | $_distfiles, 169 | $port->{distname}, 170 | $port->{suffix}, 171 | $_sites, 172 | $port->{maintainer}, 173 | $port->{masterport}, 174 | $port->{name}, 175 | $port->{category} 176 | ) unless ($settings{precious_data}); 177 | } 178 | else 179 | { 180 | $sths->{portdata_insert}->execute( 181 | $port->{name}, 182 | $port->{category}, 183 | $port->{distname}, 184 | $port->{version}, 185 | $port->{comment}, 186 | $_distfiles, 187 | $port->{suffix}, 188 | $_sites, 189 | $port->{maintainer}, 190 | $port->{masterport} 191 | ) unless ($settings{precious_data}); 192 | } 193 | 194 | # Portconfig stuff 195 | 196 | $sths->{portconfig_isstatic}->execute($port->{name}, $port->{category}); 197 | ($iss) = $sths->{portconfig_isstatic}->fetchrow_array; 198 | 199 | if ($settings{portconfig_enable} && !$iss) { 200 | my (%pcfg); 201 | 202 | foreach my $var (keys %{$port->{options}}) { 203 | my ($val, $fullport); 204 | 205 | $val = $port->{options}->{$var}; 206 | $fullport = "$port->{category}/$port->{name}"; 207 | 208 | if ($var !~ /^[A-Za-z]+$/i) { 209 | print STDERR "Invalid portconfig tuple ($var) found " . 210 | "in port $fullport\n"; 211 | next; 212 | } 213 | 214 | if ($var eq 'site') { 215 | $pcfg{indexsite} = $val 216 | if ($val =~ /^(?:ftp|https?):\/\/[^\/]+/i); 217 | next; 218 | } 219 | 220 | if ($var eq 'limit') { 221 | # Check regex isn't going to explode 222 | eval { 223 | no warnings 'all'; 224 | my $re = ''; 225 | $re =~ /$val/; 226 | 1; 227 | }; 228 | 229 | if ($@) { 230 | print STDERR 'Bad regex provided by portconfig ' . 231 | "variable in port $fullport\n"; 232 | next; 233 | }; 234 | 235 | $pcfg{limitver} = $val; 236 | next; 237 | } 238 | 239 | if ($var eq 'ignore') { 240 | if ($val == 1 or lc $val eq 'yes') { 241 | $pcfg{ignore} = 1; 242 | } else { 243 | $pcfg{ignore} = 0; 244 | } 245 | next; 246 | } 247 | 248 | if ($var eq 'skipb') { 249 | if ($val == 1 or lc $val eq 'yes') { 250 | $pcfg{skipbeta} = 1; 251 | } else { 252 | $pcfg{skipbeta} = 0; 253 | } 254 | next; 255 | } 256 | 257 | if ($var eq 'skipv') { 258 | $val =~ s/,+/ /g; 259 | $pcfg{skipversions} = $val; 260 | next; 261 | } 262 | 263 | if ($var eq 'limitw') { 264 | $val = lc $val; 265 | if ($val =~ /^(\d{1,2}),(even|odd)$/i) { 266 | $pcfg{limitwhich} = $1; 267 | $pcfg{limiteven} = $2 eq 'even' ? 1 : 0; 268 | } else { 269 | print STDERR 'Bad limitw value provided by ' . 270 | "portconfig variable in port $fullport\n"; 271 | } 272 | next; 273 | } 274 | 275 | # We've checked for all the variables we support 276 | 277 | print STDERR "Unknown portconfig key ($var) found " . 278 | "in port $fullport\n"; 279 | } 280 | 281 | # Nullify any variables we haven't accumulated 282 | foreach ('indexsite', 'limitver', 'skipversions', 'limiteven', 'limitwhich') { 283 | $pcfg{$_} = undef if (!exists $pcfg{$_}); 284 | } 285 | 286 | # ...except these, which shouldn't be NULL 287 | $pcfg{skipbeta} = 1 if !exists($pcfg{skipbeta}); 288 | $pcfg{ignore} = 0 if !exists($pcfg{ignore}); 289 | 290 | $sths->{portconfig_update}->execute( 291 | $pcfg{indexsite}, $pcfg{limitver}, $pcfg{limiteven}, 292 | $pcfg{skipbeta}, $pcfg{skipversions}, $pcfg{limitwhich}, 293 | $pcfg{ignore}, $port->{name}, $port->{category} 294 | ) if (!$settings{precious_data}); 295 | 296 | # Ensure indexsite is added to sitedata 297 | push @{$port->{sites}}, $pcfg{indexsite} if ($pcfg{indexsite}); 298 | 299 | my $newver; 300 | 301 | $sths->{portdata_getnewver}->execute($port->{name}, $port->{category}); 302 | ($newver) = $sths->{portdata_getnewver}->fetchrow_array; 303 | 304 | # Determine if the portconfig constraints 305 | # invalidate the current new version. 306 | if ($newver and !$nvcleared) { 307 | my $invalid = 0; 308 | 309 | $pcfg{ignore} and $invalid = 1; 310 | 311 | if (defined $pcfg{limiteven} and $pcfg{limitwhich} >= 0) { 312 | checkevenodd($newver, $pcfg{limiteven}, $pcfg{limitwhich}) 313 | or $invalid = 1; 314 | } 315 | 316 | if ($pcfg{skipversions}) { 317 | my @sv = split /\s+/, $pcfg{skipversions}; 318 | foreach (@sv) { 319 | if ($newver eq $_) { 320 | $invalid = 1; 321 | last; 322 | } 323 | } 324 | } 325 | 326 | if ($pcfg{limitver}) { 327 | $newver =~ /$pcfg{limitver}/ 328 | or $invalid = 1; 329 | } 330 | 331 | if ($pcfg{skipbeta} && isbeta($port->{version})) { 332 | isbeta($newver) 333 | and $invalid = 1; 334 | } 335 | 336 | if ($invalid and !$settings{precious_data}) { 337 | $sths->{portdata_clearnewver}->execute($port->{name}, 338 | $port->{category}); 339 | } 340 | } 341 | } 342 | 343 | # Sites 344 | 345 | if (@{$port->{sites}}) { 346 | # Add master site hosts to database 347 | $self->AddSite($_) foreach (@{$port->{sites}}); 348 | } 349 | 350 | return 1; 351 | } 352 | 353 | 354 | #------------------------------------------------------------------------------ 355 | # Func: AddSite() 356 | # Desc: Register a site to the database. 357 | # 358 | # Args: $site - Site to add, either a string or a URI object. 359 | # 360 | # Retn: $success - true/false 361 | #------------------------------------------------------------------------------ 362 | 363 | sub AddSite 364 | { 365 | my ($self) = shift; 366 | my ($site) = @_; 367 | 368 | my $dbh = $self->{dbh}; 369 | my $sths = $self->{sths}; 370 | 371 | my $exists; 372 | 373 | $site = URI->new($site) if (!ref $site); 374 | 375 | $sths->{sitedata_exists}->execute($site->host); 376 | ($exists) = $sths->{sitedata_exists}->fetchrow_array; 377 | 378 | $sths->{sitedata_insert}->execute($site->scheme, $site->host) 379 | if (!$exists && !$settings{precious_data}); 380 | } 381 | 382 | 383 | 1; 384 | -------------------------------------------------------------------------------- /Portscout/Config.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2010, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: Config.pm,v 1.5 2010/05/20 18:28:40 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::Config; 30 | 31 | require Exporter; 32 | 33 | use Getopt::Long; 34 | 35 | use Portscout::Const; 36 | 37 | use strict; 38 | 39 | require 5.006; 40 | 41 | our @ISA = qw(Exporter); 42 | our @EXPORT = qw(%settings); 43 | 44 | 45 | #------------------------------------------------------------------------------ 46 | # Globals 47 | #------------------------------------------------------------------------------ 48 | 49 | our %settings; 50 | 51 | my (@paths, %settings_types, $bool_opts); 52 | 53 | 54 | #------------------------------------------------------------------------------ 55 | # Default Configuration Options 56 | #------------------------------------------------------------------------------ 57 | 58 | # Useful settings 59 | 60 | %settings = ( 61 | ports_dir => '/usr/ports', 62 | templates_dir => 'templates', 63 | html_data_dir => '_html', 64 | sup_data_dir => '_supdata', 65 | 66 | datasrc => 'Portscout::DataSrc::Ports', 67 | datasrc_opts => '', 68 | 69 | cache_sup_data => 1, # Keep old supdata (could be useful) 70 | precious_data => 0, # Don't write anything to database 71 | num_children => 15, # Number of child processes to spawn 72 | workqueue_size => 20, # Size of work queue per child 73 | ftp_retries => 3, # Retry on "connections-per-IP" failures 74 | ftp_passive => 1, # Use passive FTP where possible 75 | ftp_timeout => 120, # FTP timeout, in seconds 76 | http_timeout => 120, # HTTP timeout, in seconds 77 | 78 | mastersite_limit => 4, 79 | oldfound_enable => 1, 80 | 81 | restrict_maintainer => '', 82 | restrict_category => '', 83 | restrict_port => '', 84 | 85 | indexfile_enable => 1, 86 | 87 | robots_enable => 1, 88 | robots_checking => 'strict', 89 | 90 | local_timezone => 'GMT', 91 | 92 | portconfig_enable => 1, 93 | freebsdhacks_enable => 1, 94 | sillystrings_enable => 0, 95 | 96 | default_html_sort => 'maintainer', 97 | 98 | version_compare => 'internal', 99 | 100 | db_user => APPNAME, 101 | db_name => APPNAME, 102 | db_connstr => 'DBI:Pg:dbname='.APPNAME, 103 | 104 | mail_enable => 1, 105 | mail_from => APPNAME, 106 | mail_subject => 'FreeBSD ports you maintain which are out of date', 107 | mail_subject_unmaintained => 'Unmaintained FreeBSD ports which are out of date', 108 | mail_method => 'sendmail', 109 | mail_host => 'localhost', 110 | 111 | cluster_enable => 0, 112 | system_affinity => 0, 113 | 114 | user => '', 115 | group => '', 116 | 117 | debug => 0, 118 | quiet => 0, 119 | 120 | quickmake_enable => 0, 121 | 122 | hide_unchanged => 0 123 | ); 124 | 125 | 126 | #------------------------------------------------------------------------------ 127 | # Process, parse and store 128 | #------------------------------------------------------------------------------ 129 | 130 | # Roughly work out variable types 131 | 132 | $bool_opts = 'ftp_passive|system_affinity|hide_unchanged|debug|quiet'; 133 | 134 | foreach (keys %settings) { 135 | if (/^(?:.+_enable|.+_data|$bool_opts)$/) { 136 | $settings_types{$_} = TYPE_BOOL; 137 | } elsif ($settings{$_} =~ /^\d+$/) { 138 | $settings_types{$_} = TYPE_INT; 139 | } else { 140 | $settings_types{$_} = TYPE_STRING; 141 | } 142 | } 143 | 144 | @paths = ('.', '/etc', PREFIX.'/etc'); 145 | 146 | # Override defaults with config file 147 | 148 | ParseConfigFile(CONFIG_FILE, \@paths, \%settings) 149 | or die 'Unable to parse config file'; 150 | 151 | # Finally, take note of command line options 152 | 153 | GetOptions( 154 | %{&{sub { 155 | my %s; 156 | foreach (keys %settings) { 157 | my ($t, $c); 158 | $t = $settings_types{$_} || TYPE_STRING; 159 | 160 | if ($t == TYPE_BOOL) { 161 | $c = '!'; 162 | } elsif ($t == TYPE_INT) { 163 | $c = '=i'; 164 | } else { 165 | $c = '=s'; 166 | } 167 | 168 | $s{$_.$c} = \$settings{$_}; 169 | } 170 | return \%s; 171 | }}} 172 | ) or exit 1; 173 | 174 | # Clean-up some variables 175 | 176 | if ($settings{restrict_port} =~ /\//) { 177 | # Ensure cats in restrict_port make it into 178 | # restrict_category. 179 | my %rcats; 180 | 181 | %rcats = map +($_, 1), 182 | split /,/, $settings{restrict_category}; 183 | 184 | foreach (split /,/, $settings{restrict_port}) { 185 | if (/^(.*)\/(.*)$/) { 186 | $rcats{$1} = 1; 187 | } 188 | } 189 | 190 | $settings{restrict_category} = join(',', keys %rcats); 191 | } 192 | 193 | 194 | #------------------------------------------------------------------------------ 195 | # Func: ParseConfigFile() 196 | # Desc: Search for and parse specified configuration file. 197 | # 198 | # Args: $file - Name of config file 199 | # \@paths - List of paths to search for config file 200 | # \%varlist - Where to put configuration options. Possibly 201 | # populated with default values. 202 | # 203 | # Retn: $success - true/false (false = BAD file, not missing file) 204 | #------------------------------------------------------------------------------ 205 | 206 | sub ParseConfigFile 207 | { 208 | my ($file, $paths, $varlist) = @_; 209 | 210 | my $filename; 211 | my $lineno; 212 | 213 | while ($_ = shift @$paths) { 214 | if ( -f $_.'/'.$file ) { 215 | $filename = $_.'/'.$file; 216 | last; 217 | } 218 | } 219 | 220 | # Return true: we can fall back to defaults 221 | return 1 unless ($filename); 222 | 223 | $lineno = 0; 224 | 225 | open my $cf, "<$filename" or die "Can't open config file"; 226 | 227 | while (my $line = <$cf>) 228 | { 229 | my ($var, $val, $quoted); 230 | 231 | $lineno++; 232 | 233 | # Remove comments 234 | $line =~ s/#.*$//; 235 | 236 | # Skip empty lines 237 | next unless ($line); 238 | 239 | if ($line =~ /^\s*(.*?)\s*=\s*(.*?)\s*$/) { 240 | ($var, $val) = ($1, $2); 241 | } else { 242 | next; 243 | } 244 | 245 | $var =~ s/\s+/_/g; 246 | 247 | if ($val =~ s/^(["'])//) { 248 | $val =~ s/$1$//; 249 | $quoted = 1; 250 | } 251 | 252 | $var = lc $var; 253 | 254 | if ($var !~ /^[a-z\_]+$/) { 255 | print STDERR "Invalid variable name found in config file $filename, line $lineno\n"; 256 | return 0; 257 | } 258 | 259 | # Substitute special values 260 | 261 | if (!$quoted) { 262 | $val = 1 if (lc $val eq 'true'); 263 | $val = 0 if (lc $val eq 'false'); 264 | } 265 | 266 | (1) while ( 267 | $val =~ s/%\((.*?)\)/ 268 | exists $$varlist{$1} ? $$varlist{$1} : '' 269 | /ge 270 | ); 271 | 272 | $$varlist{$var} = $val; 273 | } 274 | 275 | close $cf; 276 | 277 | return 1; 278 | } 279 | 280 | 281 | 1; 282 | -------------------------------------------------------------------------------- /Portscout/Const.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2011, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: Const.pm,v 1.5 2011/05/15 17:27:05 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::Const; 30 | 31 | require Exporter; 32 | 33 | use strict; 34 | 35 | require 5.006; 36 | 37 | our @ISA = qw(Exporter); 38 | 39 | 40 | #------------------------------------------------------------------------------ 41 | # Constants 42 | #------------------------------------------------------------------------------ 43 | 44 | use constant { 45 | APPNAME => 'portscout', 46 | APPVER => '0.8.1', 47 | AUTHOR => 'Shaun Amott', 48 | 49 | USER_AGENT => 'portscout/0.8.1', 50 | 51 | DB_VERSION => 2011040901, 52 | 53 | MAX_PATH => 1024, 54 | 55 | PREFIX => '/usr/local', 56 | CONFIG_FILE => 'portscout.conf', 57 | 58 | METHOD_GUESS => 1, 59 | METHOD_LIST => 2, 60 | 61 | ROBOTS_ALLOW => 0, 62 | ROBOTS_UNKNOWN => 1, 63 | ROBOTS_BLANKET => 2, 64 | ROBOTS_SPECIFIC => 3, 65 | 66 | TYPE_INT => 1, 67 | TYPE_BOOL => 2, 68 | TYPE_STRING => 3, 69 | }; 70 | 71 | 72 | #------------------------------------------------------------------------------ 73 | # Export our constants. 74 | #------------------------------------------------------------------------------ 75 | 76 | our @EXPORT = grep s/^Portscout::Const:://, keys %constant::declared; 77 | 78 | 79 | 1; 80 | -------------------------------------------------------------------------------- /Portscout/DataSrc.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2010, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: DataSrc.pm,v 1.1 2010/05/05 01:54:16 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::DataSrc; 30 | 31 | use strict; 32 | 33 | require 5.006; 34 | 35 | 36 | #------------------------------------------------------------------------------ 37 | # API Method Stubs. 38 | #------------------------------------------------------------------------------ 39 | 40 | sub Init { 1; } 41 | sub Build { 1; } 42 | sub Rebuild { 1; } 43 | sub Count { -1; } 44 | 45 | sub bad_versions { []; } 46 | 47 | 48 | #------------------------------------------------------------------------------ 49 | # Func: new() 50 | # Desc: Constructor. 51 | # 52 | # Args: n/a 53 | # 54 | # Retn: $self 55 | #------------------------------------------------------------------------------ 56 | 57 | sub new 58 | { 59 | my $class = shift; 60 | 61 | my ($src, $options) = @_; 62 | 63 | my $self = { 64 | opts => $options ? ParseOptions($options) : {} 65 | }; 66 | 67 | # Little shortcut 68 | $src = "Portscout::DataSrc$src" 69 | if ($src =~ /^::/); 70 | 71 | eval "use $src"; 72 | die $@ if $@; 73 | 74 | bless ($self, $src || $class); 75 | 76 | $self->Init(); 77 | 78 | return $self; 79 | } 80 | 81 | 82 | #------------------------------------------------------------------------------ 83 | # Func: ParseOptions() 84 | # Desc: Parse DataSrc options into a hash. 85 | # 86 | # Args: $opts - Options in flat config file form (basically: space-separated, 87 | # comma-delimited tuples). 88 | # 89 | # Retn: \%res - Hash of options. 90 | #------------------------------------------------------------------------------ 91 | 92 | sub ParseOptions 93 | { 94 | my ($opts) = @_; 95 | 96 | my (%res, $key, $val, $insquote, $indquote, $gotkey); 97 | 98 | $insquote = 0; 99 | $indquote = 0; 100 | $key = ''; 101 | $val = ''; 102 | 103 | foreach my $c (split //, $opts) { 104 | if ($c eq "'" && !$indquote) { 105 | $insquote = !$insquote; 106 | next; 107 | } 108 | 109 | if ($c eq '"' && !$insquote) { 110 | $indquote = !$indquote; 111 | next; 112 | } 113 | 114 | if (!$insquote && !$indquote) { 115 | if ($c eq ':') { 116 | $gotkey = 1; 117 | next; 118 | } 119 | 120 | if ($c eq ' ' or $c eq "\t") { 121 | $res{$key} = $val if ($key); 122 | $key = $val = ''; 123 | $gotkey = 0; 124 | next; 125 | } 126 | } 127 | 128 | if ($gotkey) { 129 | $val .= $c; 130 | } else { 131 | $key .= $c; 132 | } 133 | } 134 | 135 | $res{$key} = $val if ($key); 136 | 137 | return \%res; 138 | } 139 | 140 | 141 | 1; 142 | -------------------------------------------------------------------------------- /Portscout/DataSrc/Ports.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2010, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: Ports.pm,v 1.17 2011/04/09 17:19:03 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::DataSrc::Ports; 30 | 31 | use base qw(Portscout::DataSrc); 32 | 33 | use File::stat; 34 | 35 | use URI; 36 | 37 | use Portscout::Const; 38 | use Portscout::Config; 39 | use Portscout::API; 40 | use Portscout::Util; 41 | use Portscout::Make; 42 | 43 | use strict; 44 | 45 | require 5.006; 46 | 47 | 48 | #------------------------------------------------------------------------------ 49 | # Globals 50 | #------------------------------------------------------------------------------ 51 | 52 | our %settings; 53 | 54 | 55 | #------------------------------------------------------------------------------ 56 | # Func: new() 57 | # Desc: Constructor. 58 | # 59 | # Args: n/a 60 | # 61 | # Retn: $self 62 | #------------------------------------------------------------------------------ 63 | 64 | sub new 65 | { 66 | my $class = shift; 67 | 68 | my $self = {}; 69 | 70 | bless ($self, $class); 71 | 72 | return $self; 73 | } 74 | 75 | 76 | #------------------------------------------------------------------------------ 77 | # Func: Init() 78 | # Desc: Initialise. 79 | # 80 | # Args: n/a 81 | # 82 | # Retn: n/a 83 | #------------------------------------------------------------------------------ 84 | 85 | sub Init 86 | { 87 | my $self = shift; 88 | 89 | $self->{opts}->{type} = $self->{opts}->{type} 90 | ? lc $self->{opts}->{type} 91 | : 'freebsd'; 92 | 93 | Portscout::Make->Root($settings{ports_dir}); 94 | Portscout::Make->Debug($settings{debug}); 95 | 96 | Portscout::Make->Type($self->{opts}->{type}) 97 | if ($self->{opts}->{type}); 98 | 99 | Portscout::Make->Wanted( 100 | qw(DISTNAME DISTFILES EXTRACT_SUFX MASTER_SITES MASTER_SITE_SUBDIR 101 | DISTVERSION SLAVE_PORT MASTER_PORT PORTSCOUT MAINTAINER COMMENT) 102 | ); 103 | 104 | if ($self->{opts}->{type} eq 'freebsd') { 105 | Portscout::Make->InitCache( 106 | qw(OSVERSION OSREL PORTOBJCFORMAT ARCH OPSYS UID 107 | PKGINSTALLVER CONFIGURE_MAX_CMD_LEN) 108 | ); 109 | } 110 | } 111 | 112 | 113 | #------------------------------------------------------------------------------ 114 | # Func: Build() 115 | # Desc: Perform a full database build. 116 | # 117 | # Args: n/a 118 | # 119 | # Retn: $success - true/false 120 | #------------------------------------------------------------------------------ 121 | 122 | sub Build 123 | { 124 | my $self = shift; 125 | 126 | return $self->BuildDB(); 127 | } 128 | 129 | 130 | #------------------------------------------------------------------------------ 131 | # Func: Rebuild() 132 | # Desc: Perform a partial (incremental) database build. 133 | # 134 | # Args: n/a 135 | # 136 | # Retn: $success - true/false 137 | #------------------------------------------------------------------------------ 138 | 139 | sub Rebuild 140 | { 141 | my $self = shift; 142 | 143 | return $self->BuildDB(1); 144 | } 145 | 146 | 147 | #------------------------------------------------------------------------------ 148 | # Func: Count() 149 | # Desc: Quick 'n' dirty ports count. 150 | # 151 | # Args: n/a 152 | # 153 | # Retn: $num_ports - Number of ports in tree. 154 | #------------------------------------------------------------------------------ 155 | 156 | sub Count 157 | { 158 | my $self = shift; 159 | 160 | my $num_ports = 0; 161 | 162 | opendir my $pd, $settings{ports_dir} 163 | or return -1; 164 | 165 | while (my $cat = readdir $pd) { 166 | next if ($cat =~ /^[A-Z.]/ or $cat eq 'distfiles'); 167 | 168 | open my $mf, "$settings{ports_dir}/$cat/Makefile" 169 | or next; 170 | 171 | while (<$mf>) { 172 | $num_ports++ if /^\s*SUBDIR\s*\+=\s*/; 173 | } 174 | } 175 | 176 | return $num_ports; 177 | } 178 | 179 | 180 | #------------------------------------------------------------------------------ 181 | # Func: BuildDB() 182 | # Desc: Build database. 183 | # 184 | # Args: $incremental - true if we're just doing a partial update. 185 | # 186 | # Retn: $success - true/false 187 | #------------------------------------------------------------------------------ 188 | 189 | sub BuildDB 190 | { 191 | my $self = shift; 192 | 193 | my ($incremental) = @_; 194 | 195 | my (%sths, $dbh, @cats, %portsmaintok, $mfi, $move_ports, 196 | $num_ports, $got_ports, $buildtime); 197 | 198 | my @ports; 199 | 200 | my $ps = Portscout::API->new; 201 | 202 | my $lastbuild = getstat('buildtime', TYPE_INT); 203 | 204 | print "Incremental build: Looking for updated ports...\n\n" 205 | if ($incremental); 206 | 207 | $got_ports = 0; 208 | $num_ports = 0; 209 | $buildtime = time; 210 | 211 | $dbh = connect_db(); 212 | 213 | prepare_sql($dbh, \%sths, 214 | qw(portdata_masterport_str2id portdata_masterport_enslave 215 | portdata_findslaves) 216 | ); 217 | 218 | @cats = split /\s+/, Portscout::Make->Make($settings{ports_dir}, 'SUBDIR'); 219 | 220 | $mfi = stat $settings{ports_dir} . '/MOVED' 221 | or die "Couldn't stat MOVED file"; 222 | 223 | $move_ports = 1 if ($mfi->mtime > $lastbuild); 224 | 225 | # If the user has specified a maintainer restriction 226 | # list, try to get to get the list of desired ports 227 | # from the INDEX file. 228 | 229 | if ($settings{restrict_maintainer} && $settings{indexfile_enable}) { 230 | print "Querying INDEX for maintainer associations...\n"; 231 | 232 | my %maintainers = map +($_, 1), 233 | split /,/, lc $settings{restrict_maintainer}; 234 | 235 | my $index_file = 236 | $settings{ports_dir}.'/'. 237 | Portscout::Make->Make($settings{ports_dir}, 'INDEXFILE'); 238 | 239 | open my $if, "<$index_file" 240 | or die 'Unable to open INDEX file'; 241 | 242 | while (<$if>) { 243 | my (@fields, $maintainer, $port); 244 | 245 | @fields = split /\|/; 246 | $maintainer = lc($fields[5]); 247 | $port = $fields[1]; 248 | $port =~ s/^(?:.*\/)?([^\/]+)\/([^\/]+)$/$1\/$2/; 249 | 250 | if ($maintainers{$maintainer}) { 251 | $portsmaintok{$port} = $maintainer; 252 | print "Maintainer match: $maintainer $port \n" 253 | unless ($settings{quiet}); 254 | } 255 | } 256 | 257 | close $if; 258 | } 259 | 260 | # Iterate over ports directories 261 | 262 | while (my $cat = shift @cats) { 263 | next if (! -d $settings{ports_dir}."/$cat"); 264 | 265 | # Skip category if user doesn't want it. 266 | wantport(undef, $cat) or next; 267 | 268 | opendir my $catdir, $settings{ports_dir}."/$cat"; 269 | 270 | print "Scanning $cat ...\n" 271 | unless ($settings{quiet}); 272 | 273 | while (my $name = readdir $catdir) { 274 | next if ($name =~ /^\./); 275 | next if ($name =~ /^CVS$/); 276 | next if (! -d $settings{ports_dir}."/$cat/$name"); 277 | 278 | # If we're doing an incremental build, check the 279 | # port directory's mtime; skip if not updated. 280 | if ($incremental) { 281 | my ($updated); 282 | opendir my $portdir, $settings{ports_dir}."/$cat/$name"; 283 | print "Scanning $cat/$name ... " 284 | unless ($settings{quiet}); 285 | while (my $subfile = readdir $portdir) { 286 | my ($subfile_path, $fi); 287 | 288 | $subfile_path = $settings{ports_dir}."/$cat/$name/$subfile"; 289 | next if (! -f $subfile_path); 290 | 291 | $fi = stat $subfile_path 292 | or die "Couldn't stat $subfile_path: $!"; 293 | 294 | if ($fi->mtime > $lastbuild) { 295 | print "$subfile (mtime: $fi->mtime) modified updated since last build: $lastbuild \n" 296 | if ($settings{debug}); 297 | $updated = 1; 298 | last; 299 | } 300 | } 301 | 302 | if (!$updated) { 303 | print "Not modified since last build: $lastbuild \n" 304 | if ($settings{debug}); 305 | next; 306 | } 307 | } 308 | 309 | # Check this port is wanted by user 310 | wantport($name, $cat) or next; 311 | 312 | # Check maintainer if we were able to ascertain 313 | # it from the INDEX file (otherwise, we've got to 314 | # wait until make(1) has been queried. 315 | if ($settings{restrict_maintainer} 316 | && $settings{indexfile_enable}) { 317 | next if (!$portsmaintok{"$cat/$name"}); 318 | } 319 | print "Matched: $cat/$name\n" 320 | unless ($settings{quiet}); 321 | push @ports, "$cat/$name"; 322 | } 323 | } 324 | 325 | # Find slave ports, which might not have been 326 | # directly modified. 327 | 328 | if ($incremental) { 329 | foreach (@ports) { 330 | if (/^(.*)\/(.*)$/) { 331 | my ($name, $cat) = ($2, $1); 332 | 333 | print "findslaves -> $cat/$name\n" 334 | if ($settings{debug}); 335 | $sths{portdata_findslaves}->execute($name, $cat); 336 | while (my $port = $sths{portdata_findslaves}->fetchrow_hashref) { 337 | wantport($name, $cat) or next; 338 | 339 | push @ports, "$port->{cat}/$port->{name}" 340 | unless (arrexists(\@ports, "$port->{cat}/$port->{name}")); 341 | } 342 | } 343 | } 344 | } 345 | 346 | $num_ports = $#ports + 1; 347 | 348 | print "\n" unless (!$num_ports or $settings{quiet}); 349 | 350 | print $num_ports 351 | ? "Building...\n\n" 352 | : "None found!\n"; 353 | 354 | # Build the ports we found 355 | 356 | while (my $port = shift @ports) { 357 | my ($cat, $name); 358 | 359 | ($cat, $name) = ($1, $2) if $port =~ /^(.*)\/(.*)$/; 360 | 361 | $got_ports++; 362 | 363 | print '[' . strchop($cat, 15) . '] ' unless ($settings{quiet}); 364 | info($name, "(got $got_ports out of $num_ports)"); 365 | 366 | BuildPort($ps, $dbh, \%sths, $name, $cat); 367 | } 368 | 369 | # Go through and convert all masterport cat/name strings 370 | # into numerical ID values 371 | 372 | if ($num_ports) { 373 | print "\n" unless ($settings{quiet}); 374 | print "Cross-referencing master/slave ports...\n"; 375 | 376 | unless ($settings{precious_data}) { 377 | $sths{portdata_masterport_str2id}->execute; 378 | $sths{portdata_masterport_enslave}->execute; 379 | } 380 | } 381 | 382 | setstat('buildtime', $buildtime); 383 | 384 | finish_sql(\$dbh, \%sths); 385 | 386 | if ($move_ports && $self->{opts}->{type} eq 'freebsd') { 387 | if (!MovePorts($incremental ? 0 : 1)) { 388 | #$dbh->disconnect; 389 | return 0; 390 | } 391 | } 392 | 393 | #$dbh->disconnect; 394 | return 1; 395 | } 396 | 397 | 398 | #------------------------------------------------------------------------------ 399 | # Func: BuildPort() 400 | # Desc: Compile data for one port, and add to the database. 401 | # 402 | # Args: $ps - Portscout::API ref. 403 | # $dbh - Database handle. 404 | # \%sths - Statement handles. 405 | # $name - Port name. 406 | # $cat - Port category. 407 | # 408 | # Retn: $success - true/false 409 | #------------------------------------------------------------------------------ 410 | 411 | sub BuildPort 412 | { 413 | my ($ps, $dbh, $sths, $name, $cat) = @_; 414 | 415 | my (@sites, @distfiles, %pcfg); 416 | my ($ver, $distname, $distfiles, $sufx, $subdir, 417 | $distver, $masterport, $maintainer, $comment); 418 | my ($mv); 419 | 420 | # Query make for variables -- this is a huge bottleneck 421 | 422 | if ($settings{quickmake_enable}) { 423 | #$mv = Portscout::Make->QuickMake("$cat/$port"); 424 | die 'quickmake not yet (fully) implemented'; 425 | } else { 426 | $mv = Portscout::Make->Make("$settings{ports_dir}/$cat/$name"); 427 | } 428 | 429 | defined $mv or return 0; 430 | 431 | $maintainer = $mv->{MAINTAINER} || ''; 432 | $distname = $mv->{DISTNAME} || ''; 433 | $sufx = $mv->{EXTRACT_SUFX} || ''; 434 | $subdir = $mv->{MASTER_SITE_SUBDIR} || ''; 435 | $distver = $mv->{DISTVERSION} || ''; 436 | $comment = $mv->{COMMENT} || ''; 437 | 438 | $mv->{$_} =~ s/\s+/ /g foreach (keys %$mv); 439 | 440 | # Never allow spaces in SUBDIR 441 | $subdir =~ s/\s+.*$//; 442 | 443 | # Now we can check the maintainer restriction (if any) 444 | wantport(undef, undef, $maintainer) or return 0; 445 | 446 | $masterport = (lc $mv->{SLAVE_PORT} eq 'yes') ? $mv->{MASTER_PORT} : ''; 447 | 448 | $masterport = $1 if ($masterport =~ /^\Q$settings{ports_dir}\E\/(.*)\/$/); 449 | 450 | # Get rid of unexpanded placeholders 451 | 452 | foreach my $site (split /\s+/, $mv->{MASTER_SITES}) { 453 | $site =~ s/\%SUBDIR\%/$subdir/g; 454 | $site =~ s/\/+$/\//; 455 | $site =~ s/:[A-Za-z0-9][A-Za-z0-9\,]*$//g; # site group spec. 456 | 457 | next if ($site eq ""); 458 | 459 | $site = URI->new($site)->canonical; 460 | next if (length $site->host == 0); 461 | 462 | push @sites, $site; 463 | } 464 | 465 | foreach my $file (split /\s+/, $mv->{DISTFILES}) { 466 | $file =~ s/:[A-Za-z0-9][A-Za-z0-9\,]*$//g; 467 | push @distfiles, $file; 468 | } 469 | 470 | # Remove ports-system "site group" specifiers 471 | 472 | $distname =~ s/:[A-Za-z0-9][A-Za-z0-9\,]*$//g; 473 | 474 | # Attempt to extract real version from 475 | # distname (this needs refining) 476 | 477 | if ($distver) 478 | { 479 | $ver = $distver; 480 | } 481 | elsif ($distname =~ /\d/) 482 | { 483 | my $name_q; 484 | $ver = $distname; 485 | $name_q = quotemeta $name; 486 | 487 | $name_q =~ s/^(p5|mod|py|ruby|hs)(?:[\-\_])/($1\[\\-\\_\])?/; 488 | 489 | # XXX: fix me 490 | 491 | my $chop = 492 | 'sources?|bin|src|snapshot|freebsd\d*|freebsd-?\d\.\d{1,2}|' 493 | . 'linux|unstable|elf|i\d86|x86|sparc|mips|linux-i\d86|html|' 494 | . 'en|en_GB|en_US|full-src|orig|setup|install|export|' 495 | . 'fbsd[7654]\d{1,2}|export|V(?=\d)'; 496 | 497 | foreach (split '\|', $chop) { 498 | unless ($name =~ /($_)/i) { 499 | $ver =~ s/[\.\-\_]?($chop)$//gi; 500 | $ver =~ s/^($chop)[\.\-\_]?//gi; 501 | } 502 | } 503 | 504 | unless ($ver =~ s/.*$name_q[-_\.]//i) { 505 | # Resort to plan B 506 | if ($ver =~ /^(.*)-(.*)$/) { 507 | $ver = $2; 508 | } elsif ($name !~ /\d/) { 509 | $ver =~ s/^\D*(\d.*)$/$1/; 510 | } 511 | } 512 | 513 | $ver = '' if ($ver eq $name); 514 | } 515 | 516 | # Create options hash 517 | 518 | foreach (split /\s+/, $mv->{PORTSCOUT}) { 519 | if (/^([A-Za-z]+):(.*)$/i) { 520 | $pcfg{lc $1} = $2; 521 | } 522 | } 523 | 524 | # Store port data 525 | 526 | $ps->AddPort({ 527 | 'name' => $name, 528 | 'category' => $cat, 529 | 'version' => $ver, 530 | 'maintainer' => $maintainer, 531 | 'comment' => $comment, 532 | 'distname' => $distname, 533 | 'suffix' => $sufx, 534 | 'masterport' => $masterport, 535 | 'distfiles' => \@distfiles, 536 | 'sites' => \@sites, 537 | 'options' => \%pcfg 538 | }); 539 | 540 | return 1; 541 | } 542 | 543 | 544 | #------------------------------------------------------------------------------ 545 | # Func: MovePorts() 546 | # Desc: Handle any ports which have been moved. 547 | # 548 | # Args: $addonly - Should we just record the entries, or start moving 549 | # ports around? (true = the former) 550 | # 551 | # Retn: $success - true/false 552 | #------------------------------------------------------------------------------ 553 | 554 | sub MovePorts 555 | { 556 | my ($addonly) = @_; 557 | 558 | my (%sths, $dbh); 559 | 560 | my $error = 0; 561 | 562 | my $moved_file = $settings{ports_dir}.'/MOVED'; 563 | 564 | print "Processing MOVED entries...\n"; 565 | 566 | return 0 unless (-f $moved_file); 567 | 568 | $dbh = connect_db(); 569 | 570 | prepare_sql($dbh, \%sths, 571 | qw(moveddata_exists portdata_setmoved portdata_removestale 572 | moveddata_insert) 573 | ); 574 | 575 | open my $mf, "<$moved_file" or $error = 1; 576 | 577 | while (<$mf>) 578 | { 579 | my $exists; 580 | 581 | next if /^#/; 582 | 583 | my ($port_from, $port_to, $date, $reason) = split /\|/; 584 | 585 | my ($port_fromcat, $port_fromname, $port_tocat, $port_toname); 586 | 587 | next unless ($port_from); 588 | 589 | $sths{moveddata_exists}->execute($port_from, $port_to, $date); 590 | ($exists) = $sths{moveddata_exists}->fetchrow_array; 591 | next if ($exists); 592 | 593 | if ($addonly) { 594 | info($port_from, 'Record MOVED entry: date ' . $date); 595 | $sths{moveddata_insert}->execute($port_from, $port_to, $date, $reason) 596 | unless ($settings{precious_data}); 597 | next; 598 | } 599 | 600 | info($port_from, ($port_to ? 'Moving to ' . $port_to 601 | : 'Deleting')); 602 | 603 | if ($port_from) 604 | { 605 | ($port_fromcat, $port_fromname) = ($1, $2) 606 | if ($port_from =~ /^(.*)\/(.*)/); 607 | 608 | ($port_tocat, $port_toname) = ($1, $2) 609 | if ($port_to =~ /^(.*)\/(.*)/); 610 | 611 | # Mark for removal 612 | $sths{portdata_setmoved}->execute($port_fromname, $port_fromcat) 613 | unless ($settings{precious_data}); 614 | } 615 | 616 | # Record entry 617 | $sths{moveddata_insert}->execute($port_from, $port_to, $date, $reason) 618 | unless ($settings{precious_data}); 619 | } 620 | 621 | print "Finalising pending MOVED terminations...\n"; 622 | 623 | # Remove ports that were ear-marked 624 | $sths{portdata_removestale}->execute 625 | unless ($addonly || $settings{precious_data}); 626 | 627 | close $mf; 628 | 629 | finish_sql(\$dbh, \%sths); 630 | 631 | return ($error ? 0 : 1); 632 | } 633 | 634 | 635 | 1; 636 | -------------------------------------------------------------------------------- /Portscout/DataSrc/XML.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2011, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: XML.pm,v 1.8 2011/05/15 17:27:05 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::DataSrc::XML; 30 | 31 | use base qw(Portscout::DataSrc); 32 | 33 | use XML::XPath; 34 | use XML::XPath::XMLParser; 35 | 36 | use Portscout::API; 37 | use Portscout::Util; 38 | 39 | use strict; 40 | 41 | require 5.006; 42 | 43 | 44 | #------------------------------------------------------------------------------ 45 | # Globals 46 | #------------------------------------------------------------------------------ 47 | 48 | our %settings; 49 | 50 | 51 | #------------------------------------------------------------------------------ 52 | # Func: new() 53 | # Desc: Constructor. 54 | # 55 | # Args: n/a 56 | # 57 | # Retn: $self 58 | #------------------------------------------------------------------------------ 59 | 60 | sub new 61 | { 62 | my $class = shift; 63 | 64 | my $self = {}; 65 | 66 | bless ($self, $class); 67 | 68 | return $self; 69 | } 70 | 71 | 72 | #------------------------------------------------------------------------------ 73 | # Func: Build() 74 | # Desc: Parse the XML file; store results in the database. 75 | # 76 | # Args: n/a 77 | # 78 | # Retn: $success - true/false 79 | #------------------------------------------------------------------------------ 80 | 81 | sub Build 82 | { 83 | my $self = shift; 84 | 85 | my ($xpath, $items); 86 | 87 | my (%singlemap, %multimap, %defaults); 88 | 89 | my $got_ports = 0; 90 | my $num_ports = $self->Count(); # XXX: caching? 91 | 92 | my $ps = Portscout::API->new; 93 | 94 | %singlemap = ( 95 | 'name' => 'name', 96 | 'category' => 'category', 97 | 'desc' => 'comment', 98 | 'version' => 'version', 99 | 'maintainer' => 'maintainer', 100 | 'distname' => 'distname', 101 | 'suffix' => 'suffix', 102 | 'master' => 'masterport' 103 | ); 104 | 105 | %multimap = ( 106 | 'distfiles' => {name => 'distfiles', child => 'file', type => 'array'}, 107 | 'sites' => {name => 'sites', child => 'site', type => 'array'}, 108 | 'options' => {name => 'options', child => 'option', type => 'hash'} 109 | ); 110 | 111 | %defaults = ( 112 | 'category' => 'software', 113 | 'suffix' => '.tar.gz', 114 | 'distname' => '%(name)-%(version)', 115 | 'distfiles' => [ '%(distname)%(suffix)' ] 116 | ); 117 | 118 | if (!$self->{opts}->{file}) { 119 | die "No XML source file specified"; 120 | } elsif (! -f $self->{opts}->{file}) { 121 | die "Can't read XML file"; 122 | } 123 | 124 | $xpath = XML::XPath->new(filename => $self->{opts}->{file}); 125 | 126 | $items = $xpath->findnodes('/items/item'); 127 | 128 | foreach my $item ($items->get_nodelist) { 129 | my $data = $xpath->findnodes('*', $item); 130 | 131 | # Some defaults 132 | my %port; 133 | 134 | # Iterate over elements 135 | foreach my $datum ($data->get_nodelist) { 136 | my ($key, $val); 137 | 138 | $key = $datum->getLocalName(); 139 | $val = $datum->string_value(); 140 | 141 | $val =~ s/^\s*//; 142 | $val =~ s/\s*$//; 143 | $val =~ s/\n//s; 144 | 145 | if ($singlemap{$key}) { 146 | # Simple string value 147 | 148 | $port{$singlemap{$key}} = $val; 149 | next; 150 | } elsif ($multimap{$key}) { 151 | # Array of values in child nodes 152 | 153 | my ($name, $type, $child, $nodes); 154 | 155 | $name = $multimap{$key}->{name}; 156 | $type = $multimap{$key}->{type}; 157 | $child = $multimap{$key}->{child}; 158 | 159 | if (!exists $port{$name}) { 160 | $port{$name} = ($type eq 'array') ? [] : {}; 161 | } 162 | 163 | $nodes = $xpath->findnodes($child, $datum); 164 | foreach my $subnode ($nodes->get_nodelist) { 165 | my ($skey, $sval); 166 | if ($type eq 'array') { 167 | $sval = $subnode->string_value(); 168 | push @{$port{$name}}, $sval; 169 | } else { 170 | $skey = $subnode->getAttribute('name'); 171 | $sval = $subnode->getAttribute('value'); 172 | $port{$name}->{$skey} = $sval; 173 | } 174 | } 175 | next; 176 | } 177 | } 178 | 179 | # Fill in defaults 180 | 181 | foreach my $key (keys %defaults) { 182 | if (!exists $port{$key}) { 183 | if (!ref $defaults{$key}) { 184 | $port{$key} = $defaults{$key} 185 | } elsif (ref $defaults{$key} eq 'ARRAY') { 186 | $port{$key} = [ @{$defaults{$key}} ]; 187 | } elsif (ref $defaults{$key} eq 'HASH') { 188 | $port{$key} = { %{$defaults{$key}} }; 189 | } 190 | } 191 | } 192 | 193 | # Perform auto replacements 194 | 195 | foreach my $key (keys %port) { 196 | if (!ref $port{$key}) { 197 | (1) while ( 198 | $port{$key} =~ s/%\((.*?)\)/ 199 | my $v = $singlemap{$1} || $1; 200 | (exists $port{$v} && !ref $port{$v}) ? $port{$v} : '' 201 | /ge 202 | ); 203 | } elsif (ref $port{$key} eq 'ARRAY') { 204 | for (my $i = 0; $i <= $#{$port{$key}}; $i++) { 205 | (1) while ( 206 | ${$port{$key}}[$i] =~ s/%\((.*?)\)/ 207 | my $v = $singlemap{$1} || $1; 208 | (exists $port{$v} && !ref $port{$v}) ? $port{$v} : '' 209 | /ge 210 | ); 211 | } 212 | } 213 | } 214 | 215 | # Check that this port is actually desired 216 | 217 | if (!wantport($port{name}, $port{category}, $port{maintainer})) { 218 | $num_ports--; 219 | next; 220 | } 221 | 222 | $got_ports++; 223 | 224 | print '[' . strchop($port{category}, 15) . '] ' unless ($settings{quiet}); 225 | info($port{name}, "(got $got_ports out of $num_ports)"); 226 | 227 | $ps->AddPort(\%port); 228 | } 229 | 230 | print "\nDone.\n"; 231 | 232 | return 1; 233 | } 234 | 235 | 236 | #------------------------------------------------------------------------------ 237 | # Func: Rebuild() 238 | # Desc: As above, but only update what has changed. 239 | # 240 | # Args: n/a 241 | # 242 | # Retn: $success - true/false 243 | #------------------------------------------------------------------------------ 244 | 245 | sub Rebuild 246 | { 247 | my $self = shift; 248 | 249 | # XXX: need to, at the least, uncheck new vers 250 | $self->Build(); 251 | 252 | return 1; 253 | } 254 | 255 | 256 | #------------------------------------------------------------------------------ 257 | # Func: Count() 258 | # Desc: Return a count of the software items. 259 | # 260 | # Args: n/a 261 | # 262 | # Retn: $count - Result. 263 | #------------------------------------------------------------------------------ 264 | 265 | sub Count 266 | { 267 | my $self = shift; 268 | 269 | my ($xpath, $items, $num_ports); 270 | 271 | $xpath = XML::XPath->new(filename => $self->{opts}->{file}); 272 | 273 | $items = $xpath->findnodes('/items/item'); 274 | 275 | $num_ports++ foreach ($items->get_nodelist); 276 | 277 | return $num_ports; 278 | } 279 | 280 | 281 | 1; 282 | 283 | =pod 284 | 285 | =head1 NAME 286 | 287 | Portscout::DataSrc::XML 288 | 289 | XML file DataSrc backend for Portscout. 290 | 291 | =head1 DESCRIPTION 292 | 293 | This module provides a simple means of describing software you want to 294 | monitor to Portscout. Instead of checking the FreeBSD ports tree, 295 | Portscout will read the required data from an XML file. 296 | 297 | The XML module is also intended as a demonstration for developers 298 | wishing to extend Portscout to support other repositories. 299 | 300 | =head1 CONFIGURATION 301 | 302 | Update F to enable XML as the DataSrc backend: 303 | 304 | datasrc = Portscout::DataSrc::XML 305 | datasrc_opts = file:/path/to/file.xml 306 | 307 | =head1 FILE FORMAT 308 | 309 | The file should be in the following format. It must contain well-formed 310 | XML and be in the location specified in F. 311 | 312 | 313 | 314 | software 315 | foo 316 | Foomatic Professional 317 | 0.4.3 318 | .tar.gz 319 | %(name)-%(version) 320 | 321 | %(distname)%(suffix) 322 | 323 | 324 | http://foo.example.net/releases/ 325 | ftp://mirror.local/pub/foo/ 326 | 327 | 328 | 330 | 331 | 332 | software 333 | bar 334 | Barware 335 | 1.8 336 | 337 | http://example.org/software/bar/ 338 | 339 | 340 | 341 | 342 | =head1 TIPS 343 | 344 | You can refer to other values within each EitemE element as shown 345 | above, using the %(variable) notation. 346 | 347 | Note that the values for EcategoryE, EsuffixE, 348 | EdistnameE and EdistfilesE in the "Foo" entry above are 349 | the defaults and can be omitted. 350 | 351 | =head1 USING THE BACKEND 352 | 353 | Once you have your file ready, you can use the standard C and 354 | C commands to update Portscout's internal database with any 355 | changes. 356 | 357 | =cut 358 | -------------------------------------------------------------------------------- /Portscout/Make.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2006-2011, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: Make.pm,v 1.14 2011/05/15 17:27:05 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::Make; 30 | 31 | use strict; 32 | 33 | require 5.006; 34 | 35 | 36 | #------------------------------------------------------------------------------ 37 | # Globals 38 | #------------------------------------------------------------------------------ 39 | 40 | my $root_dir; 41 | my $make_cache; 42 | 43 | my $maketype = 'freebsd'; 44 | 45 | my $debug = 0; 46 | 47 | my %wanted = (); 48 | 49 | my $qfail = 0; 50 | 51 | 52 | #------------------------------------------------------------------------------ 53 | # Func: new() 54 | # Desc: Constructor - does nothing useful. 55 | # 56 | # Args: n/a 57 | # 58 | # Retn: $self 59 | #------------------------------------------------------------------------------ 60 | 61 | sub new 62 | { 63 | my $self = {}; 64 | my $class = shift; 65 | 66 | bless ($self, $class); 67 | return $self; 68 | } 69 | 70 | 71 | #------------------------------------------------------------------------------ 72 | # Accessor functions 73 | #------------------------------------------------------------------------------ 74 | 75 | sub Root 76 | { 77 | my $self = shift; 78 | 79 | if (@_) { 80 | $root_dir = shift; 81 | $root_dir =~ s/^(.+)\/$/$1/; 82 | } 83 | 84 | return $root_dir; 85 | } 86 | 87 | sub Wanted 88 | { 89 | my $self = shift; 90 | 91 | %wanted = (); 92 | 93 | while (my $k = shift) { 94 | $wanted{$k} = 1 95 | } 96 | } 97 | 98 | sub Type 99 | { 100 | my $self = shift; 101 | 102 | $maketype = lc shift if (@_); 103 | 104 | return $maketype; 105 | } 106 | 107 | sub Debug 108 | { 109 | my $self = shift; 110 | 111 | $debug = shift if (@_); 112 | 113 | return $debug; 114 | } 115 | 116 | 117 | #------------------------------------------------------------------------------ 118 | # Func: Make() 119 | # Desc: Ask make(1) to expand and return values for specified variables 120 | # 121 | # Args: $dir - Directory to execute make in. Appends $root_dir 122 | # if there's no leading slash. 123 | # @vars - List of variables. (optional) 124 | # 125 | # Retn: [results] - Ref. to hash of results - unless there was only 126 | # one variable, in which case return a string. 127 | #------------------------------------------------------------------------------ 128 | 129 | sub Make 130 | { 131 | my $self = shift; 132 | 133 | my ($dir, @vars) = @_; 134 | 135 | my (%results, @outp, $list, $cache, $lb); 136 | 137 | $cache = $make_cache ? $make_cache : ''; 138 | 139 | $dir = "$root_dir/$dir" if ($dir !~ /^\//); 140 | 141 | @vars = keys %wanted if (scalar @vars == 0); 142 | 143 | if ($maketype eq 'freebsd') { 144 | $list = join(' -V ', @vars); 145 | } else { 146 | $list = join(' -V ', 147 | map { 148 | my $v = $_; 149 | $v =~ s/^(.*)$/'\${$1}'/; 150 | $v 151 | } @vars 152 | ); 153 | } 154 | 155 | # Ensure we aren't affected by locally installed stuff 156 | $lb = 'LOCALBASE=/nonexistent'; 157 | 158 | @outp = split /\n/, qx(make -C $dir -V $list $cache $lb 2>/dev/null); 159 | 160 | if ($?) { 161 | warn "make failed for $dir"; 162 | return; 163 | } 164 | 165 | if ($#vars == 0) { 166 | return $outp[0]; 167 | } 168 | 169 | foreach (@vars) { 170 | $results{$_} = shift @outp; 171 | } 172 | 173 | return \%results; 174 | } 175 | 176 | 177 | #------------------------------------------------------------------------------ 178 | # Func: InitCache() 179 | # Desc: Prepare a cache of make(1) variables for Make(). This essentially 180 | # saves a dozen forks each time make is invoked, saving us precious 181 | # time while populating the database. 182 | # 183 | # Args: @vars - List of variables to cache. 184 | # 185 | # Retn: $success - true/false 186 | #------------------------------------------------------------------------------ 187 | 188 | sub InitCache 189 | { 190 | my $self = shift; 191 | 192 | my (@vars) = @_; 193 | 194 | my ($mv, $list); 195 | 196 | $make_cache = ''; 197 | 198 | return 0 if (!$root_dir || !@vars); 199 | 200 | $mv = $self->Make($root_dir, @vars); 201 | 202 | if ($#vars == 0) { 203 | $make_cache = "$vars[0]=$mv"; 204 | return 1; 205 | } 206 | 207 | $make_cache .= "$_=". ($mv->{$_} || '') 208 | foreach (keys %$mv); 209 | 210 | return 1; 211 | } 212 | 213 | 214 | #------------------------------------------------------------------------------ 215 | # Func: QuickMake() 216 | # Desc: Attempt to retrieve the information we require without using make(1) 217 | # at all. At the first sign of trouble, bail out and just use make. 218 | # 219 | # Args: $port - Port name (dir/port). 220 | # 221 | # Retn: \%results - Ref. to hash of results. 222 | #------------------------------------------------------------------------------ 223 | 224 | sub QuickMake 225 | { 226 | my $self = shift; 227 | 228 | my ($port) = @_; 229 | 230 | my %defaultvars = ( 231 | PORTSDIR => $root_dir, 232 | PREFIX => '/usr/local', 233 | DATADIR => '${PREFIX}/share/${PORTNAME}', 234 | WRKDIR => '${WRKDIRPREFIX}${.CURDIR}/work', 235 | WRKDIRPREFIX => '', 236 | '.CURDIR' => "$root_dir/$port", 237 | MACHINE_ARCH => 'i386', 238 | 239 | DISTNAME => '${PORTNAME}-${DISTVERSIONPREFIX}${DISTVERSION:C/:(.)/\1/g}${DISTVERSIONSUFFIX}', 240 | DISTFILES => '${DISTNAME}${EXTRACT_SUFX}', 241 | DISTVERSION => '${PORTVERSION:S/:/::/g}', 242 | DISTVERSIONSUFFIX => '', 243 | DISTVERSIONPREFIX => '', 244 | 245 | MASTER_SITE_SUBDIR => '' 246 | ); 247 | 248 | my %vars = (); 249 | 250 | open my $mf, "<$root_dir/$port/Makefile" 251 | or die "Unable to open Makefile for $port"; 252 | 253 | my $multifrag = ''; 254 | 255 | while (my $line = <$mf>) { 256 | my $ismultiline; 257 | 258 | ## $line =~ s/(?Make($port); 316 | } 317 | 318 | # Merge in default vars 319 | foreach (keys %defaultvars) { 320 | $vars{$_} = $defaultvars{$_} 321 | if (!exists $vars{$_}); 322 | } 323 | 324 | # Manually determine suffix. 325 | if (!$vars{'EXTRACT_SUFX'}) { 326 | if (exists $vars{'USE_BZIP2'}) { 327 | $vars{'EXTRACT_SUFX'} = '.tar.bz2'; 328 | } elsif (exists $vars{'USE_ZIP'}) { 329 | $vars{'EXTRACT_SUFX'} = '.zip'; 330 | } elsif (exists $vars{'USE_MAKESELF'}) { 331 | $vars{'EXTRACT_SUFX'} = '.run'; 332 | } else { 333 | $vars{'EXTRACT_SUFX'} = '.tar.gz'; 334 | } 335 | } 336 | 337 | $qfail = 0; 338 | 339 | foreach (keys %vars) { 340 | while (_resolvevars(\%vars, $_)) { 341 | if ($qfail) { 342 | $qfail = 0; 343 | return $self->Make($port); 344 | } 345 | } 346 | 347 | $vars{$_} =~ s/\$\{000(.*?)000\}/\$\{$1\}/g; 348 | } 349 | 350 | # Manually do complex DISTVERSION->PORTVERSION conversion 351 | if (!$vars{'PORTVERSION'} && $vars{'DISTVERSION'}) { 352 | my $portversion = ''; 353 | foreach (split(/\s+/, lc $vars{'DISTVERSION'})) { 354 | my $word = $_; 355 | $word =~ s/([a-z])[a-z]+/$1/g; 356 | $word =~ s/([0-9])([a-z])/$1.$2/g; 357 | $word =~ s/:(.)/$1/g; 358 | $word =~ s/[^a-z0-9+]+/./g; 359 | $portversion .= ' ' if ($portversion); 360 | $portversion .= $word; 361 | } 362 | $vars{'PORTVERSION'} = $portversion; 363 | } 364 | 365 | # We need to resolve MASTER_SITES using bsd.sites.mk and 366 | # the additional layer of macros. We can just use this 367 | # file (rather than the whole ports framework), so the 368 | # overhead is fairly small. 369 | if ($vars{'MASTER_SITES'} && exists $wanted{'MASTER_SITES'}) { 370 | my $results; 371 | my $args = ''; 372 | 373 | $args .= '$_="' . quotemeta($vars{$_}) . '" ' 374 | foreach (keys %vars); 375 | 376 | $results = qx(make -f bsd.sites.mk -C $root_dir/Mk/ $args -V MASTER_SITES); 377 | $results = '' if (!$results); 378 | chomp $results; 379 | 380 | #$results =~ s/%SUBDIR%/$vars{'MASTER_SITE_SUBDIR'}/g; 381 | 382 | $vars{'MASTER_SITES'} = $results; 383 | } 384 | 385 | foreach (keys %vars) { 386 | delete $vars{$_} 387 | if (!exists $wanted{$_}); 388 | } 389 | 390 | return \%vars; 391 | } 392 | 393 | 394 | #------------------------------------------------------------------------------ 395 | # Func: _resolvevars() 396 | # Desc: Attempt to "resolve" variables -- substituting values from elsewhere 397 | # and performing the basic transformations supported by make(1). 398 | # 399 | # Args: \%vars - Existing variables hash. 400 | # $key - Variable to resolve. 401 | # 402 | # Retn: $done - Was a transformation performed? 403 | #------------------------------------------------------------------------------ 404 | 405 | sub _resolvevars 406 | { 407 | my ($vars, $key) = @_; 408 | 409 | my $varmatch = qr/\$\{([A-Z_.][A-Z0-9_]*)(:[ULRE]|:[SC](.).*?\3.*?\3[1]?[g]?)*\}/; 410 | 411 | $vars->{$key} =~ 412 | s/$varmatch/ # XXX: chained ops 413 | my $var = $1; 414 | my $op = $2; 415 | my $delim = $3; 416 | 417 | _resolvevars($vars, $var) 418 | if ($vars->{$var} && $vars->{$var} =~ $varmatch); 419 | 420 | (!$qfail) 421 | ? _resolver($vars, $var, $op, $delim) 422 | : ''; 423 | /ge; 424 | 425 | # High probability of failure... 426 | #$qfail = 1 if ($vars->{$key} =~ /\$/); 427 | } 428 | 429 | 430 | #------------------------------------------------------------------------------ 431 | # Func: _resolver() 432 | # Desc: Second-level resolver. 433 | # 434 | # Args: \%vars - Existing variables hash. 435 | # $var - Variable name. 436 | # $op - Operation that we hope to emulate. 437 | # $delim - Delimiter used (in the case of replacement ops.) 438 | # 439 | # Retn: $rvar - Resolved variable. 440 | #------------------------------------------------------------------------------ 441 | 442 | sub _resolver 443 | { 444 | my ($vars, $var, $op, $delim) = @_; 445 | 446 | my $saveforlater = qr/^MASTER_SITE_/; 447 | 448 | if (exists $vars->{$var}) { 449 | if ($op and $op eq ':U') { 450 | return uc $vars->{$var}; 451 | } elsif ($op and $op eq ':L') { 452 | return lc $vars->{$var}; 453 | } elsif ($op and ($op eq ':R' or $op eq ':E')) { 454 | my $opvar = ''; 455 | foreach my $word (split /\s+/, $vars->{$var}) { 456 | my ($rest, $sufx); 457 | if ($word =~ /^(.*)\.(.*?)$/) { 458 | $rest = $1; 459 | $sufx = $2; 460 | } else { 461 | $rest = $word; 462 | $sufx = ''; 463 | } 464 | 465 | if ($op eq ':R') { 466 | $word = $rest; # Remove suffix 467 | } else { 468 | $word = $sufx; # Leave just suffix 469 | } 470 | 471 | $opvar .= ' ' if ($opvar); 472 | $opvar .= $word; 473 | } 474 | return $opvar; 475 | } elsif ($op and $op =~ m/^:S/) { 476 | my (@bits, $opvar, $flag_g, $caret, $dollar); 477 | @bits = split /(?{$var}) { 500 | if ($flag_g) { 501 | $word =~ s/$caret\Q$bits[1]\E$dollar/$bits[2]/g; 502 | } else { 503 | $word =~ s/$caret\Q$bits[1]\E$dollar/$bits[2]/; 504 | } 505 | $opvar .= ' ' if ($opvar); 506 | $opvar .= $word; 507 | } 508 | return $opvar; 509 | } elsif ($op and $op =~ m/^:C/) { 510 | my (@bits, $opvar, $first, $flag_g, $flag_1); 511 | @bits = split /(?{$var}) { 521 | unless ($flag_1 && !$first) { 522 | if ($flag_g) { 523 | $word =~ s/$bits[1]/$bits[2]/g; 524 | } else { 525 | $word =~ s/$bits[1]/$bits[2]/; 526 | } 527 | $first = 1; 528 | } 529 | $opvar .= ' ' if ($opvar); 530 | $opvar .= $word; 531 | } 532 | return $opvar; 533 | } elsif ($op) { 534 | unless (!exists $wanted{$_} or $var =~ $saveforlater) { 535 | warn "Unresolvable variable ($var) found. Unknown operator. Bailing out." 536 | if ($debug); 537 | $qfail = 1; 538 | } 539 | } else { 540 | return $vars->{$var}; 541 | } 542 | } else { 543 | unless (!exists $wanted{$_} or $var =~ $saveforlater) { 544 | warn "Unresolvable variable ($var) found. Bailing out." 545 | if ($debug); 546 | $qfail = 1; 547 | } else { 548 | return "\${000${var}000}"; 549 | } 550 | } 551 | } 552 | 553 | 554 | 1; 555 | -------------------------------------------------------------------------------- /Portscout/SQL.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2011, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: SQL.pm,v 1.20 2011/05/15 17:27:05 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::SQL; 30 | 31 | require Exporter; 32 | 33 | use strict; 34 | 35 | require 5.006; 36 | 37 | our @ISA = qw(Exporter); 38 | 39 | 40 | #------------------------------------------------------------------------------ 41 | # Globals 42 | #------------------------------------------------------------------------------ 43 | 44 | our %sql; 45 | 46 | 47 | #------------------------------------------------------------------------------ 48 | # SQL that is common to all supported database engines. 49 | #------------------------------------------------------------------------------ 50 | 51 | $sql{portdata_exists} = 52 | q(SELECT 1 53 | FROM portdata 54 | WHERE name = ? 55 | AND cat = ? 56 | AND moved != true 57 | LIMIT 1); 58 | 59 | $sql{portdata_getver} = 60 | q(SELECT ver 61 | FROM portdata 62 | WHERE name = ? 63 | AND cat = ? 64 | AND moved != true); 65 | 66 | $sql{portdata_getnewver} = 67 | q(SELECT newver 68 | FROM portdata 69 | WHERE name = ? 70 | AND cat = ? 71 | AND moved != true); 72 | 73 | $sql{portdata_clearnewver} = 74 | q(UPDATE portdata 75 | SET newver = NULL, method = NULL 76 | WHERE name = ? 77 | AND cat = ? 78 | AND moved != true); 79 | 80 | $sql{portdata_update} = 81 | q(UPDATE portdata 82 | SET ver = ?, comment = ?, cat = ?, distfiles = ?, distname = ?, 83 | sufx = ?, mastersites = ?, maintainer = ?, masterport = ?, 84 | updated = CURRENT_TIMESTAMP 85 | WHERE name = ? 86 | AND cat = ? 87 | AND moved != true); 88 | 89 | $sql{portdata_insert} = 90 | q(INSERT 91 | INTO portdata (name, cat, distname, ver, comment, 92 | distfiles, sufx, mastersites, maintainer, 93 | method, masterport) 94 | VALUES (?,?,?,?,?,?,?,?,?,0,?)); 95 | 96 | $sql{portdata_masterport_str2id} = 97 | q(UPDATE portdata 98 | SET masterport_id = (SELECT id 99 | FROM portdata 100 | AS master 101 | WHERE master.cat = split_part(portdata.masterport, '/', 1) 102 | AND master.name = split_part(portdata.masterport, '/', 2) 103 | LIMIT 1) 104 | WHERE masterport is not NULL 105 | AND masterport != '' 106 | AND moved != true); 107 | 108 | # Note: enslaved only meaningful when masterport_id != 0 109 | $sql{portdata_masterport_enslave} = 110 | q(UPDATE portdata 111 | SET enslaved = (1 IN (SELECT 1 112 | FROM portdata 113 | AS master 114 | WHERE master.id = portdata.masterport_id 115 | AND master.ver = portdata.ver 116 | AND master.distfiles = portdata.distfiles 117 | AND master.mastersites = portdata.mastersites)) 118 | WHERE masterport_id != 0 119 | AND masterport_id is not NULL 120 | AND moved != true); 121 | 122 | $sql{portconfig_update} = 123 | q(UPDATE portdata 124 | SET indexsite = ?, limitver = ?, limiteven = ?, 125 | skipbeta = ?, skipversions = ?, limitwhich = ?, 126 | ignore = ? 127 | WHERE name = ? 128 | AND cat = ? 129 | AND moved != true); 130 | 131 | $sql{portconfig_isstatic} = 132 | q(SELECT pcfg_static 133 | FROM portdata 134 | WHERE name = ? 135 | AND cat = ? 136 | AND moved != true); 137 | 138 | # BuildPortsDBFast 139 | 140 | $sql{portdata_findslaves} = 141 | q(SELECT name, cat 142 | FROM portdata 143 | WHERE masterport_id = (SELECT id 144 | FROM portdata 145 | WHERE name = ? 146 | AND cat = ? 147 | LIMIT 1) 148 | AND moved != true); 149 | 150 | # CheckPortsDB 151 | 152 | $sql{portdata_select} = 153 | q(SELECT * 154 | FROM portdata 155 | WHERE ( (masterport_id = 0 OR masterport_id is NULL) OR (enslaved != true) ) 156 | AND ( systemid = (SELECT id 157 | FROM systemdata 158 | WHERE host = ? 159 | LIMIT 1) 160 | OR systemid is NULL ) 161 | AND moved != true 162 | AND ignore != true 163 | ORDER BY random()); 164 | 165 | $sql{portdata_count} = $sql{portdata_select}; 166 | $sql{portdata_count} =~ s/^SELECT \*/SELECT COUNT (*)/i; 167 | $sql{portdata_count} =~ s/ORDER BY.*$/LIMIT 1/i; 168 | 169 | $sql{portdata_setchecked} = 170 | q(UPDATE portdata 171 | SET checked = CURRENT_TIMESTAMP 172 | WHERE id = ? 173 | OR (masterport_id = ? AND enslaved = true)); 174 | 175 | $sql{portdata_setnewver} = 176 | q(UPDATE portdata 177 | SET newver = ?, method = ?, newurl = ?, 178 | discovered = CURRENT_TIMESTAMP 179 | WHERE id = ? 180 | OR (masterport_id = ? AND enslaved = true)); 181 | 182 | $sql{sitedata_exists} = 183 | q(SELECT COUNT(*) 184 | FROM sitedata 185 | WHERE host = ?); 186 | 187 | $sql{sitedata_select} = 188 | q(SELECT host, robots, robots_paths, liecount, 189 | (CURRENT_TIMESTAMP >= robots_nextcheck) AS robots_outofdate, 190 | abs(successes + (5*failures)) AS _w 191 | FROM sitedata 192 | WHERE position(host in ?) > 0 193 | AND ignore is not true 194 | ORDER BY _w ASC); 195 | 196 | $sql{sitedata_failure} = 197 | q(UPDATE sitedata 198 | SET failures = failures + 1 199 | WHERE host = ?); 200 | 201 | $sql{sitedata_success} = 202 | q(UPDATE sitedata 203 | SET successes = successes + 1 204 | WHERE host = ?); 205 | 206 | $sql{sitedata_insert} = 207 | q(INSERT 208 | INTO sitedata (type, host) 209 | VALUES (?,?)); 210 | 211 | $sql{sitedata_initliecount} = 212 | q(UPDATE sitedata 213 | SET liecount = 8 214 | WHERE host = ?); 215 | 216 | $sql{sitedata_decliecount} = 217 | q(UPDATE sitedata 218 | SET liecount = liecount - 1 219 | WHERE host = ?); 220 | 221 | #$sql{sitedata_setrobots} 222 | 223 | # UncheckPortsDB 224 | 225 | $sql{portdata_uncheck} = 226 | q(UPDATE portdata 227 | SET checked = NULL, newver = NULL, status = NULL, 228 | newurl = NULL, method = NULL); 229 | 230 | # GenerateHTML 231 | 232 | #$sql{portdata_genresults} 233 | 234 | $sql{portdata_selectall} = 235 | q(SELECT * 236 | FROM portdata 237 | WHERE moved != true 238 | ORDER BY cat,name); 239 | 240 | $sql{portdata_selectmaintainer} = 241 | q(SELECT * 242 | FROM portdata 243 | WHERE lower(maintainer) = lower(?) 244 | AND moved != true 245 | ORDER BY cat,name); 246 | 247 | $sql{portdata_selectall_limited} = 248 | q(SELECT name, cat, limitver, limiteven, limitwhich, indexsite, skipversions, 249 | skipbeta 250 | FROM portdata 251 | WHERE ( limitver is not NULL ) 252 | OR ( limitwhich is not NULL ) 253 | OR ( indexsite is not NULL ) 254 | OR ( skipversions is not NULL ) 255 | AND moved != true 256 | ORDER BY cat,name); 257 | 258 | # ShowUpdates 259 | 260 | $sql{portdata_selectupdated} = 261 | q(SELECT lower(maintainer) AS maintainer, 262 | cat, name, ver, newver 263 | FROM portdata 264 | WHERE ver != newver 265 | ORDER BY lower(maintainer)); 266 | 267 | 268 | # MovePorts 269 | 270 | $sql{moveddata_exists} = 271 | q(SELECT 1 272 | FROM moveddata 273 | WHERE fromport = ? 274 | AND toport = ? 275 | AND date = ? 276 | LIMIT 1); 277 | 278 | $sql{moveddata_insert} = 279 | q(INSERT 280 | INTO moveddata (fromport, toport, date, reason) 281 | VALUES (?,?,?,?)); 282 | 283 | $sql{portdata_move} = 284 | q(UPDATE portdata 285 | SET cat = ?, name = ? 286 | WHERE cat = ? 287 | AND name = ? 288 | AND moved != true); 289 | 290 | $sql{portdata_setmoved} = 291 | q(UPDATE portdata 292 | SET moved = true 293 | WHERE name = ? 294 | AND cat = ?); 295 | 296 | $sql{portdata_removestale} = 297 | q(DELETE 298 | FROM portdata 299 | WHERE moved = true 300 | AND pcfg_static != true); 301 | 302 | $sql{portdata_exists} = 303 | q(SELECT 1 304 | FROM portdata 305 | WHERE name = ? 306 | AND cat = ? 307 | LIMIT 1); 308 | 309 | # MailMaintainers 310 | 311 | $sql{maildata_select} = 312 | q(SELECT address 313 | FROM maildata); 314 | 315 | $sql{portdata_findnewnew} = 316 | q(SELECT name,cat,ver,newver 317 | FROM portdata 318 | WHERE lower(maintainer) = lower(?) 319 | AND newver != ver 320 | AND newver is not NULL 321 | AND moved != true 322 | AND ignore != true 323 | AND (( mailed != ver AND mailed != newver ) 324 | OR mailed is NULL ) 325 | ORDER BY cat,name ASC); 326 | 327 | $sql{portdata_setmailed} = 328 | q(UPDATE portdata 329 | SET mailed = ? 330 | WHERE name = ? 331 | AND cat = ? 332 | AND moved != true); 333 | 334 | # AddMailAddrs 335 | 336 | $sql{maildata_exists} = 337 | q(SELECT 1 338 | FROM maildata 339 | WHERE lower(address) = lower(?) 340 | LIMIT 1); 341 | 342 | $sql{maildata_insert} = 343 | q(INSERT 344 | INTO maildata (address) 345 | VALUES (?)); 346 | 347 | # RemoveMailAddrs 348 | 349 | $sql{maildata_delete} = 350 | q(DELETE 351 | FROM maildata 352 | WHERE lower(address) = lower(?)); 353 | 354 | # AllocatePorts 355 | 356 | $sql{portdata_countleft} = 357 | q(SELECT COUNT(*) 358 | FROM portdata 359 | WHERE moved != true 360 | AND systemid is NULL); 361 | 362 | $sql{portdata_deallocate} = 363 | q(UPDATE portdata 364 | SET systemid = NULL); 365 | 366 | $sql{allocators_count} = 367 | q(SELECT COUNT(*) 368 | FROM allocators 369 | LIMIT 1); 370 | 371 | $sql{allocators_select} = 372 | q(SELECT * 373 | FROM allocators 374 | ORDER BY seq ASC, allocator); 375 | 376 | # Misc. 377 | 378 | $sql{portscout_version} = 379 | q(SELECT dbver 380 | FROM portscout 381 | ORDER BY dbver DESC 382 | LIMIT 1); 383 | 384 | $sql{portscout_getstat} = 385 | q(SELECT val 386 | FROM stats 387 | WHERE key = ? 388 | LIMIT 1); 389 | 390 | $sql{portscout_setstat} = 391 | q(UPDATE stats 392 | SET val = ? 393 | WHERE key = ?); 394 | 395 | 396 | #------------------------------------------------------------------------------ 397 | # Func: new() 398 | # Desc: Constructor. 399 | # 400 | # Args: n/a 401 | # 402 | # Retn: $self 403 | #------------------------------------------------------------------------------ 404 | 405 | sub new 406 | { 407 | my $self = {}; 408 | my $class = shift; 409 | 410 | bless ($self, $class); 411 | return $self; 412 | } 413 | 414 | 415 | #------------------------------------------------------------------------------ 416 | # Func: Load() 417 | # Desc: Initialise; load the SQL from the required module. 418 | # 419 | # Args: $db - DBI engine name. 420 | # 421 | # Retn: $success - true/false 422 | #------------------------------------------------------------------------------ 423 | 424 | sub Load 425 | { 426 | my $self = shift; 427 | 428 | my ($db) = @_; 429 | 430 | return 0 if (!$db); 431 | 432 | eval 'use Portscout::SQL::' . $db . ' qw(RegisterHacks);'; 433 | 434 | if ($@) { 435 | warn $@; 436 | return 0; 437 | } 438 | 439 | return 1; 440 | } 441 | 442 | 443 | 1; 444 | -------------------------------------------------------------------------------- /Portscout/SQL/Pg.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2010, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: Pg.pm,v 1.6 2010/05/15 20:19:55 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::SQL::Pg; 30 | 31 | require Exporter; 32 | 33 | use strict; 34 | 35 | require 5.006; 36 | 37 | our @ISA = qw(Exporter); 38 | our @EXPORT_OK = qw(RegisterHacks); 39 | 40 | 41 | #------------------------------------------------------------------------------ 42 | # Globals 43 | #------------------------------------------------------------------------------ 44 | 45 | my $sql = \%Portscout::SQL::sql; 46 | 47 | 48 | #------------------------------------------------------------------------------ 49 | # SQL that is different for this database engine. 50 | #------------------------------------------------------------------------------ 51 | 52 | # CheckPortsDB 53 | 54 | $$sql{sitedata_setrobots} = 55 | q(UPDATE sitedata 56 | SET robots = ?, 57 | robots_paths = ?, 58 | robots_nextcheck = CURRENT_TIMESTAMP + INTERVAL '2 weeks' 59 | WHERE host = ?); 60 | 61 | # GenerateHTML 62 | 63 | $$sql{portdata_genresults} = 64 | q(SELECT maintainer, 65 | total, 66 | COALESCE(withnewdistfile, 0) AS withnewdistfile, 67 | CAST (100*(COALESCE(withnewdistfile, 0)*1.0/total*1.0) AS FLOAT) 68 | AS percentage 69 | INTO TEMP results 70 | 71 | FROM ( 72 | SELECT lower(maintainer) AS maintainer, 73 | COUNT(maintainer) AS total, 74 | COUNT(newver != ver) AS withnewdistfile 75 | FROM portdata 76 | WHERE moved != true 77 | GROUP BY lower(maintainer) 78 | ) 79 | AS pd1 80 | ); 81 | 82 | _transformsql(); 83 | 84 | 85 | #------------------------------------------------------------------------------ 86 | # Func: new() 87 | # Desc: Constructor. 88 | # 89 | # Args: n/a 90 | # 91 | # Retn: $self 92 | #------------------------------------------------------------------------------ 93 | 94 | sub new 95 | { 96 | my $self = {}; 97 | my $class = shift; 98 | 99 | bless ($self, $class); 100 | return $self; 101 | } 102 | 103 | 104 | #------------------------------------------------------------------------------ 105 | # Func: RegisterHacks() 106 | # Desc: Implement any missing database functions. This minimises the number of 107 | # different versions of queries we have to maintain. Needs to be called 108 | # after each new database connection. 109 | # 110 | # Args: \$dbh - Database handle, already connected. 111 | # 112 | # Retn: n/a 113 | #------------------------------------------------------------------------------ 114 | 115 | sub RegisterHacks 116 | { 117 | my ($self) = shift; 118 | 119 | return; 120 | } 121 | 122 | 123 | #------------------------------------------------------------------------------ 124 | # Func: _transformsql() 125 | # Desc: Transform the SQL queries into a form that works with this database. 126 | # This is so we can share as many of the SQL queries as possible, rather 127 | # than duplicating them for minor changes. 128 | # 129 | # Args: n/a 130 | # 131 | # Retn: n/a 132 | #------------------------------------------------------------------------------ 133 | 134 | sub _transformsql 135 | { 136 | return; 137 | } 138 | 139 | 140 | 1; 141 | -------------------------------------------------------------------------------- /Portscout/SQL/SQLite.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2010, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: SQLite.pm,v 1.9 2010/05/24 02:16:02 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::SQL::SQLite; 30 | 31 | require Exporter; 32 | 33 | use strict; 34 | 35 | require 5.006; 36 | 37 | our @ISA = qw(Exporter); 38 | our @EXPORT_OK = qw(RegisterHacks); 39 | 40 | 41 | #------------------------------------------------------------------------------ 42 | # Globals 43 | #------------------------------------------------------------------------------ 44 | 45 | my $sql = \%Portscout::SQL::sql; 46 | 47 | 48 | #------------------------------------------------------------------------------ 49 | # SQL that is different for this database engine. 50 | #------------------------------------------------------------------------------ 51 | 52 | # CheckPortsDB 53 | 54 | $$sql{sitedata_setrobots} = 55 | q(UPDATE sitedata 56 | SET robots = ?, 57 | robots_paths = ?, 58 | robots_nextcheck = datetime(CURRENT_TIMESTAMP, '+14 days') 59 | WHERE host = ?); 60 | 61 | # GenerateHTML 62 | 63 | $$sql{portdata_genresults_init} = 64 | q(DELETE FROM results); 65 | 66 | $$sql{portdata_genresults} = 67 | q(INSERT 68 | INTO results 69 | 70 | SELECT lower(maintainer) AS maintainer, 71 | total, 72 | COALESCE(withnewdistfile, 0) AS withnewdistfile, 73 | CAST (100*(COALESCE(withnewdistfile, 0)*1.0/total*1.0) AS FLOAT) 74 | AS percentage 75 | 76 | FROM ( 77 | SELECT maintainer, 78 | COUNT(maintainer) AS total, 79 | COUNT(newver != ver) AS withnewdistfile 80 | FROM portdata 81 | WHERE moved != 1 82 | GROUP BY maintainer 83 | )); 84 | 85 | _transformsql(); 86 | 87 | 88 | #------------------------------------------------------------------------------ 89 | # Func: new() 90 | # Desc: Constructor. 91 | # 92 | # Args: n/a 93 | # 94 | # Retn: $self 95 | #------------------------------------------------------------------------------ 96 | 97 | sub new 98 | { 99 | my $self = {}; 100 | my $class = shift; 101 | 102 | bless ($self, $class); 103 | return $self; 104 | } 105 | 106 | 107 | #------------------------------------------------------------------------------ 108 | # Func: RegisterHacks() 109 | # Desc: Implement any missing database functions. This minimises the number of 110 | # different versions of queries we have to maintain. Needs to be called 111 | # after each new database connection. 112 | # 113 | # Args: \$dbh - Database handle, already connected. 114 | # 115 | # Retn: n/a 116 | #------------------------------------------------------------------------------ 117 | 118 | sub RegisterHacks 119 | { 120 | my ($self) = shift; 121 | 122 | my ($dbh) = @_; 123 | 124 | # Stolen from DBD::PgLite 125 | $dbh->func( 126 | 'split_part', 127 | 3, 128 | sub { 129 | my ($str, $delim, $i) = @_; 130 | $i ||= 1; 131 | return (split(/\Q$delim\E/, $str))[$i-1]; 132 | }, 133 | 'create_function' 134 | ); 135 | 136 | $dbh->func( 137 | 'position', 138 | 2, 139 | sub { 140 | my ($part, $whole) = @_; 141 | return index($whole, $part) + 1; 142 | }, 143 | 'create_function' 144 | ); 145 | 146 | return; 147 | } 148 | 149 | 150 | #------------------------------------------------------------------------------ 151 | # Func: _transformsql() 152 | # Desc: Transform the SQL queries into a form that works with this database. 153 | # This is so we can share as many of the SQL queries as possible, rather 154 | # than duplicating them for minor changes. 155 | # 156 | # Args: n/a 157 | # 158 | # Retn: n/a 159 | #------------------------------------------------------------------------------ 160 | 161 | sub _transformsql 162 | { 163 | # A bit over-engineered... 164 | foreach my $k (keys %$sql) { 165 | my ($from, $to); 166 | 167 | $$sql{$k} =~ s/true/1/g; 168 | $$sql{$k} =~ s/false/0/g; 169 | 170 | # Try to implement age() 171 | if ($$sql{$k} =~ s/age\((.*?)\)\s*([<>=])\s*'(\d+ hours?|minutes?|seconds?)'/datetime($1) _EQU_ datetime('now', '_SIG_$3')/g) { 172 | my ($sig) = $2; 173 | if ($sig eq '>') { $$sql{$k} =~ s/_EQU_//g; $$sql{$k} =~ s/_SIG_/-/; } 175 | if ($sig eq '=') { $$sql{$k} =~ s/_EQU_/=/g; $$sql{$k} =~ s/_SIG_/-/; } 176 | } 177 | 178 | # Convert position(X in Y) to position(X, Y) for 179 | # our function implemented above. 180 | $$sql{$k} =~ s/position\((.*?)\s*[Ii][Nn]\s*(.*?)\)/position($1, $2)/g; 181 | 182 | # Use case-insensitive maintainer INDEX when required 183 | #$$sql{$k} =~ s/lower\(maintainer\)\s*=\s*lower\(\?\)/maintainer COLLATE NOCASE = ?/gi 184 | $$sql{$k} =~ s/lower\(maintainer\)\s*=\s*lower\(\?\)/maintainer = ?/gi; 185 | $$sql{$k} =~ s/lower\(address\)\s*=\s*lower\(\?\)/address = ?/gi; 186 | $$sql{$k} =~ s/ORDER\s*BY\s*lower\(maintainer\)/ORDER BY maintainer/gi; 187 | } 188 | 189 | return; 190 | } 191 | 192 | 193 | 1; 194 | -------------------------------------------------------------------------------- /Portscout/SiteHandler.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2010, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: SiteHandler.pm,v 1.2 2010/04/29 01:07:51 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::SiteHandler; 30 | 31 | use XML::XPath; 32 | use XML::XPath::XMLParser; 33 | 34 | use Portscout::SiteHandler::GitHub; 35 | use Portscout::SiteHandler::PyPI; 36 | use Portscout::SiteHandler::SourceForge; 37 | 38 | use strict; 39 | 40 | require 5.006; 41 | 42 | 43 | #------------------------------------------------------------------------------ 44 | # Globals 45 | #------------------------------------------------------------------------------ 46 | 47 | our @sitehandlers; 48 | 49 | 50 | #------------------------------------------------------------------------------ 51 | # Func: new() 52 | # Desc: Constructor. 53 | # 54 | # Args: n/a 55 | # 56 | # Retn: $self 57 | #------------------------------------------------------------------------------ 58 | 59 | sub new 60 | { 61 | my $self = {}; 62 | my $class = shift; 63 | 64 | bless ($self, $class); 65 | return $self; 66 | } 67 | 68 | 69 | #------------------------------------------------------------------------------ 70 | # Func: FindHandler() 71 | # Desc: Iterate over known handlers to find one, if any, that can handle the 72 | # given site. 73 | # 74 | # Args: $url - A URL we want to "handle". 75 | # 76 | # Retn: $sitehandler or undef 77 | #------------------------------------------------------------------------------ 78 | 79 | sub FindHandler 80 | { 81 | my $self = shift; 82 | 83 | my ($url) = @_; 84 | 85 | foreach (@sitehandlers) { 86 | return new $_ if $_->CanHandle($url); 87 | } 88 | 89 | return undef; 90 | } 91 | 92 | 93 | 1; 94 | -------------------------------------------------------------------------------- /Portscout/SiteHandler/GitHub.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2014, Jasper Lievisse Adriaanse 3 | # 4 | # Permission to use, copy, modify, and distribute this software for any 5 | # purpose with or without fee is hereby granted, provided that the above 6 | # copyright notice and this permission notice appear in all copies. 7 | # 8 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | # 16 | #------------------------------------------------------------------------------ 17 | 18 | package Portscout::SiteHandler::GitHub; 19 | 20 | use JSON qw(decode_json); 21 | use LWP::UserAgent; 22 | 23 | use Portscout::Const; 24 | use Portscout::Config; 25 | 26 | use strict; 27 | 28 | require 5.006; 29 | 30 | 31 | #------------------------------------------------------------------------------ 32 | # Globals 33 | #------------------------------------------------------------------------------ 34 | 35 | push @Portscout::SiteHandler::sitehandlers, __PACKAGE__; 36 | 37 | our %settings; 38 | 39 | 40 | #------------------------------------------------------------------------------ 41 | # Func: new() 42 | # Desc: Constructor. 43 | # 44 | # Args: n/a 45 | # 46 | # Retn: $self 47 | #------------------------------------------------------------------------------ 48 | 49 | sub new 50 | { 51 | my $self = {}; 52 | my $class = shift; 53 | 54 | $self->{name} = 'GitHub'; 55 | 56 | bless ($self, $class); 57 | return $self; 58 | } 59 | 60 | 61 | #------------------------------------------------------------------------------ 62 | # Func: CanHandle() 63 | # Desc: Ask if this handler (package) can handle the given site. 64 | # 65 | # Args: $url - URL of site. 66 | # 67 | # Retn: $res - true/false. 68 | #------------------------------------------------------------------------------ 69 | 70 | sub CanHandle 71 | { 72 | my $self = shift; 73 | 74 | my ($url) = @_; 75 | 76 | return ($url =~ /^https?:\/\/([^\/.]+\.)?github\.com\/(.*?)\/tar.gz/); 77 | } 78 | 79 | 80 | #------------------------------------------------------------------------------ 81 | # Func: GetFiles() 82 | # Desc: Extract a list of files from the given URL. In the case of GitHub, 83 | # we are actually pulling the files from the project's Atom feed and 84 | # extract the release url, containing the tag it was based on. 85 | # 86 | # Args: $url - URL we would normally fetch from. 87 | # \%port - Port hash fetched from database. 88 | # \@files - Array to put files into. 89 | # 90 | # Retn: $success - False if file list could not be constructed; else, true. 91 | #------------------------------------------------------------------------------ 92 | 93 | sub GetFiles 94 | { 95 | my $self = shift; 96 | 97 | my ($url, $port, $files) = @_; 98 | my $files_count_before = scalar @$files; 99 | my $projname; 100 | 101 | # Extract project name from URL 102 | if ($url =~ /https?:\/\/codeload\.github\.com\/(.+?)\/tar.gz\//) { 103 | $projname = $1; 104 | } elsif ($url =~ /https:\/\/github\.com\/(.+?)\/archive\//) { 105 | $projname = $1; 106 | } elsif ($url =~ /https:\/\/github.com\/downloads\/(.+)\//) { 107 | $projname = $1; 108 | } else { 109 | _debug("Couldn't extract project name from URL $url"); 110 | return 0; 111 | } 112 | 113 | # See if there are any releases 114 | my $releases = _call_github_api('/repos/' . $projname . '/releases') 115 | or return 0; 116 | foreach my $release (@$releases) { 117 | if (!$release->{prerelease} && !$release->{draft}) { 118 | my $release_url = $release->{tarball_url}; 119 | push(@$files, $release_url); 120 | } 121 | } 122 | 123 | # In case there aren't any releases, try tags tags instead 124 | if (scalar @$files == $files_count_before) { 125 | my $tags = _call_github_api('/repos/' . $projname . '/tags') 126 | or return 0; 127 | foreach my $tag (@$tags) { 128 | my $tag_url = $tag->{tarball_url}; 129 | push(@$files, $tag_url); 130 | } 131 | } 132 | 133 | _debug('Found ' . (scalar @$files - $files_count_before) . ' files'); 134 | return 1; 135 | } 136 | 137 | 138 | #------------------------------------------------------------------------------ 139 | # Func: _call_github_api() 140 | # Desc: Calls the github api making use of settings. 141 | # 142 | # Args: $resource - Resource to query (e.g. "/repos/project/releases") 143 | # 144 | # Retn: Parsed JSON 145 | #------------------------------------------------------------------------------ 146 | 147 | sub _call_github_api { 148 | my $resource = shift; 149 | 150 | my $url = 'https://api.github.com' . $resource; 151 | _debug("GET $url"); 152 | 153 | my $ua = LWP::UserAgent->new; 154 | $ua->agent(USER_AGENT); 155 | $ua->timeout($settings{http_timeout}); 156 | 157 | my $response = $ua->request( 158 | HTTP::Request->new( 159 | GET => $url, 160 | $settings{github_token} 161 | ? ["Authorization" => "token $settings{github_token}"] 162 | : [] 163 | ) 164 | ); 165 | if (!$response->is_success || $response->status_line !~ /^2/) { 166 | _debug('GET failed: ' . $response->status_line); 167 | return; 168 | } 169 | return decode_json($response->decoded_content); 170 | } 171 | 172 | 173 | #------------------------------------------------------------------------------ 174 | # Func: _debug() 175 | # Desc: Print a debug message. 176 | # 177 | # Args: $msg - Message. 178 | # 179 | # Retn: n/a 180 | #------------------------------------------------------------------------------ 181 | 182 | sub _debug 183 | { 184 | my ($msg) = @_; 185 | 186 | $msg = '' if (!$msg); 187 | 188 | print STDERR "(" . __PACKAGE__ . ") $msg\n" if ($settings{debug}); 189 | } 190 | 191 | 1; 192 | -------------------------------------------------------------------------------- /Portscout/SiteHandler/PyPI.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2015, Jasper Lievisse Adriaanse 3 | # 4 | # Permission to use, copy, modify, and distribute this software for any 5 | # purpose with or without fee is hereby granted, provided that the above 6 | # copyright notice and this permission notice appear in all copies. 7 | # 8 | # THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 9 | # WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 10 | # MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 11 | # ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 12 | # WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 13 | # ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 14 | # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 15 | # 16 | #------------------------------------------------------------------------------ 17 | 18 | package Portscout::SiteHandler::PyPI; 19 | 20 | use JSON qw(decode_json); 21 | use LWP::UserAgent; 22 | 23 | use Portscout::Const; 24 | use Portscout::Config; 25 | 26 | use strict; 27 | 28 | require 5.006; 29 | 30 | 31 | #------------------------------------------------------------------------------ 32 | # Globals 33 | #------------------------------------------------------------------------------ 34 | 35 | push @Portscout::SiteHandler::sitehandlers, __PACKAGE__; 36 | 37 | our %settings; 38 | 39 | 40 | #------------------------------------------------------------------------------ 41 | # Func: new() 42 | # Desc: Constructor. 43 | # 44 | # Args: n/a 45 | # 46 | # Retn: $self 47 | #------------------------------------------------------------------------------ 48 | 49 | sub new 50 | { 51 | my $self = {}; 52 | my $class = shift; 53 | 54 | $self->{name} = 'PyPI'; 55 | 56 | bless ($self, $class); 57 | return $self; 58 | } 59 | 60 | 61 | #------------------------------------------------------------------------------ 62 | # Func: CanHandle() 63 | # Desc: Ask if this handler (package) can handle the given site. 64 | # 65 | # Args: $url - URL of site. 66 | # 67 | # Retn: $res - true/false. 68 | #------------------------------------------------------------------------------ 69 | 70 | sub CanHandle 71 | { 72 | my $self = shift; 73 | 74 | my ($url) = @_; 75 | 76 | return ($url =~ /https?:\/\/pypi\.python\.org\//); 77 | } 78 | 79 | 80 | #------------------------------------------------------------------------------ 81 | # Func: GetFiles() 82 | # Desc: Extract a list of files from the given URL. Simply query the API. 83 | # 84 | # Args: $url - URL we would normally fetch from. 85 | # \%port - Port hash fetched from database. 86 | # \@files - Array to put files into. 87 | # 88 | # Retn: $success - False if file list could not be constructed; else, true. 89 | #------------------------------------------------------------------------------ 90 | 91 | sub GetFiles 92 | { 93 | my $self = shift; 94 | 95 | my ($url, $port, $files) = @_; 96 | 97 | my ($pypi, $package, $resp, $query, $ua); 98 | $pypi = 'https://pypi.python.org/pypi/'; 99 | 100 | # Strip all the digits at the end to keep the stem of the module. 101 | if ($port->{distname} =~ /(.*?)-(\d+)/) { 102 | $package = $1; 103 | } 104 | 105 | $query = $pypi . $package . '/json'; 106 | 107 | _debug("GET $query"); 108 | $ua = LWP::UserAgent->new; 109 | $ua->agent(USER_AGENT); 110 | $resp = $ua->request(HTTP::Request->new(GET => $query)); 111 | if ($resp->is_success) { 112 | _debug("GET success: " . $resp->code); 113 | my ($json, $urls); 114 | 115 | $json = decode_json($resp->decoded_content); 116 | $urls = $json->{urls}; 117 | foreach my $url (@$urls) { 118 | _debug("PyPi File: " . $url->{filename}); 119 | push(@$files, $url->{filename}); 120 | } 121 | } else { 122 | _debug("GET failed: " . $resp->code); 123 | return 0; 124 | } 125 | 126 | return 1; 127 | } 128 | 129 | 130 | #------------------------------------------------------------------------------ 131 | # Func: _debug() 132 | # Desc: Print a debug message. 133 | # 134 | # Args: $msg - Message. 135 | # 136 | # Retn: n/a 137 | #------------------------------------------------------------------------------ 138 | 139 | sub _debug 140 | { 141 | my ($msg) = @_; 142 | 143 | $msg = '' if (!$msg); 144 | 145 | print STDERR "(" . __PACKAGE__ . ") $msg\n" if ($settings{debug}); 146 | } 147 | 148 | 1; 149 | -------------------------------------------------------------------------------- /Portscout/SiteHandler/SourceForge.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2010, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: SourceForge.pm,v 1.8 2010/05/05 01:54:16 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::SiteHandler::SourceForge; 30 | 31 | use XML::XPath; 32 | use XML::XPath::XMLParser; 33 | use LWP::UserAgent; 34 | 35 | use Portscout::Const; 36 | use Portscout::Config; 37 | 38 | use strict; 39 | 40 | require 5.006; 41 | 42 | 43 | #------------------------------------------------------------------------------ 44 | # Globals 45 | #------------------------------------------------------------------------------ 46 | 47 | push @Portscout::SiteHandler::sitehandlers, __PACKAGE__; 48 | 49 | our %settings; 50 | 51 | 52 | #------------------------------------------------------------------------------ 53 | # Func: new() 54 | # Desc: Constructor. 55 | # 56 | # Args: n/a 57 | # 58 | # Retn: $self 59 | #------------------------------------------------------------------------------ 60 | 61 | sub new 62 | { 63 | my $self = {}; 64 | my $class = shift; 65 | 66 | $self->{name} = 'SourceForge'; 67 | 68 | bless ($self, $class); 69 | return $self; 70 | } 71 | 72 | 73 | #------------------------------------------------------------------------------ 74 | # Func: CanHandle() 75 | # Desc: Ask if this handler (package) can handle the given site. 76 | # 77 | # Args: $url - URL of site. 78 | # 79 | # Retn: $res - true/false. 80 | #------------------------------------------------------------------------------ 81 | 82 | sub CanHandle 83 | { 84 | my $self = shift; 85 | 86 | my ($url) = @_; 87 | 88 | return ($url =~ /^https?:\/\/[^\/]*?\.sourceforge\.net\/project\//); 89 | } 90 | 91 | 92 | #------------------------------------------------------------------------------ 93 | # Func: GetFiles() 94 | # Desc: Extract a list of files from the given URL. In the case of SourceForge, 95 | # we are actually pulling the files from an RSS feed helpfully provided 96 | # for each "project". 97 | # 98 | # Args: $url - URL we would normally fetch from. 99 | # \%port - Port hash fetched from database. 100 | # \@files - Array to put files into. 101 | # 102 | # Retn: $success - False if file list could not be constructed; else, true. 103 | #------------------------------------------------------------------------------ 104 | 105 | sub GetFiles 106 | { 107 | my $self = shift; 108 | 109 | my ($url, $port, $files) = @_; 110 | 111 | if ($url =~ /[^\/]*\/project\/([^\/]*)\//) { 112 | my ($rsspage, $projname, $ua, $response, $xpath, $items); 113 | 114 | $projname = $1; 115 | 116 | # Find the RSS feed for this project. 117 | $rsspage = 'http://sourceforge.net/api/file/index/project-name/' 118 | . $projname . '/mtime/desc/rss'; 119 | 120 | _debug("Trying RSS @ $rsspage"); 121 | 122 | $ua = LWP::UserAgent->new; 123 | 124 | $ua->agent(USER_AGENT); 125 | $ua->timeout($settings{http_timeout}); 126 | 127 | $response = $ua->get($rsspage); 128 | 129 | if (!$response->is_success || $response->status_line !~ /^2/) { 130 | _debug('RSS feed failed: ' . $response->status_line); 131 | return 0; 132 | } 133 | 134 | $xpath = XML::XPath->new(xml => $response->content); 135 | 136 | $items = $xpath->findnodes('/rss/channel/item'); 137 | 138 | foreach my $item ($items->get_nodelist) { 139 | my ($data, $tnode, $file, $lnode, $url); 140 | 141 | $data = $xpath->findnodes('./title', $item); 142 | $tnode = ($data->get_nodelist)[0]; 143 | $file = "/project/$projname" . $tnode->string_value(); 144 | 145 | # There doesn't seem to be a canonical way of 146 | # determining which entries are directories; 147 | # but directories seem to (rightly) have 148 | # trailing slashes in the full URL, in . 149 | 150 | $data = $xpath->findnodes('./link', $item); 151 | $lnode = ($data->get_nodelist)[0]; 152 | $url = $lnode->string_value(); 153 | 154 | next if ($url =~ /\/$/); 155 | 156 | # Note this file. 157 | 158 | push @$files, $file; 159 | } 160 | 161 | _debug('Found ' . scalar @$files . ' files'); 162 | } else { 163 | return 0; 164 | } 165 | 166 | return 1; 167 | } 168 | 169 | 170 | #------------------------------------------------------------------------------ 171 | # Func: _debug() 172 | # Desc: Print a debug message. 173 | # 174 | # Args: $msg - Message. 175 | # 176 | # Retn: n/a 177 | #------------------------------------------------------------------------------ 178 | 179 | sub _debug 180 | { 181 | my ($msg) = @_; 182 | 183 | $msg = '' if (!$msg); 184 | 185 | print STDERR "(SiteHandler::SourceForge) $msg\n" 186 | if ($settings{debug}); 187 | } 188 | 189 | 190 | 1; 191 | -------------------------------------------------------------------------------- /Portscout/Template.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2006-2011, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: Template.pm,v 1.5 2011/05/15 17:27:05 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::Template; 30 | 31 | use URI::Escape; 32 | 33 | use strict; 34 | 35 | require 5.006; 36 | 37 | 38 | #------------------------------------------------------------------------------ 39 | # Globals 40 | #------------------------------------------------------------------------------ 41 | 42 | my $templatedir; 43 | my $outputdir; 44 | 45 | my $clearempty = 1; 46 | 47 | 48 | #------------------------------------------------------------------------------ 49 | # Func: new() 50 | # Desc: Constructor - load template into class. 51 | # 52 | # Args: $name - Template (file)name 53 | # 54 | # Retn: $self 55 | #------------------------------------------------------------------------------ 56 | 57 | sub new 58 | { 59 | my $file; 60 | 61 | my $self = {}; 62 | my $class = shift; 63 | 64 | $self->{name} = shift; 65 | 66 | $self->{header} = []; 67 | $self->{repeat} = []; 68 | $self->{footer} = []; 69 | 70 | $self->{rows} = []; 71 | 72 | $self->{template_header} = []; 73 | $self->{template_repeat} = []; 74 | $self->{template_footer} = []; 75 | 76 | if ($templatedir) { 77 | $file = "$templatedir/$self->{name}"; 78 | } else { 79 | $file = $self->{name}; 80 | } 81 | 82 | open my $fh, "<$file" or return undef; 83 | 84 | while (<$fh>) 85 | { 86 | if (s/^%%://) { 87 | push @{$self->{template_repeat}}, $_; 88 | } else { 89 | if (@{$self->{template_repeat}}) { 90 | push @{$self->{template_footer}}, $_; 91 | } else { 92 | push @{$self->{template_header}}, $_; 93 | } 94 | } 95 | } 96 | 97 | close $fh; 98 | 99 | bless ($self, $class); 100 | return $self; 101 | } 102 | 103 | 104 | #------------------------------------------------------------------------------ 105 | # Accessor functions 106 | #------------------------------------------------------------------------------ 107 | 108 | sub templatedir 109 | { 110 | my $self = shift; 111 | 112 | if (@_) { 113 | $templatedir = shift; 114 | $templatedir =~ s/^(.+)\/$/$1/; 115 | } 116 | 117 | return $templatedir; 118 | } 119 | 120 | sub outputdir 121 | { 122 | my $self = shift; 123 | 124 | if (@_) { 125 | $outputdir = shift; 126 | $outputdir =~ s/^(.+)\/$/$1/; 127 | } 128 | 129 | return $outputdir; 130 | } 131 | 132 | sub clearempty 133 | { 134 | my $self = shift; 135 | 136 | if (@_) { 137 | my $ce = shift; 138 | $clearempty = ($ce ? 1 : 0); 139 | } 140 | 141 | return $clearempty; 142 | } 143 | 144 | 145 | #------------------------------------------------------------------------------ 146 | # Func: applyglobal() 147 | # Desc: Interpolate global data into the template. 148 | # 149 | # Args: \%data - Data to merge 150 | # 151 | # Retn: n/a 152 | #------------------------------------------------------------------------------ 153 | 154 | sub applyglobal 155 | { 156 | my $self = shift; 157 | my $data = shift; 158 | 159 | foreach my $var ('header', 'repeat', 'footer') { 160 | @{$self->{$var}} = undef; 161 | 162 | foreach (@{$self->{"template_$var"}}) { 163 | my $val = $_; 164 | $val =~ s/\%\%\((.+?)(?::(.*?))?\)/ 165 | if (exists $data->{$1}) { 166 | _format_var($data->{$1}, $2); 167 | } else { 168 | $2 ? "\%\%($1:$2)" : "\%\%($1)"; 169 | } 170 | /ge; 171 | push @{$self->{$var}}, $val; 172 | } 173 | } 174 | 175 | return 1; 176 | } 177 | 178 | 179 | #------------------------------------------------------------------------------ 180 | # Func: pushrow() 181 | # Desc: Interpolate data into the template's "repeat" section, and add the 182 | # result as a new row. 183 | # 184 | # Args: \%data - Data to merge 185 | # 186 | # Retn: n/a 187 | #------------------------------------------------------------------------------ 188 | 189 | sub pushrow 190 | { 191 | my $self = shift; 192 | my $data = shift; 193 | 194 | my $var; 195 | 196 | if (@{$self->{repeat}}) { 197 | $var = 'repeat'; 198 | } else { 199 | $var = 'template_repeat'; 200 | } 201 | 202 | foreach (@{$self->{$var}}) { 203 | my $val = $_; 204 | $val =~ s/\%\%\((.+?)(?::(.*?))?\)/ 205 | if (exists $data->{$1}) { 206 | _format_var($data->{$1}, $2); 207 | } else { 208 | $2 ? "\%\%($1:$2)" : "\%\%($1)"; 209 | } 210 | /ge; 211 | push @{$self->{rows}}, $val; 212 | } 213 | 214 | return 1; 215 | } 216 | 217 | 218 | #------------------------------------------------------------------------------ 219 | # Func: output() 220 | # Desc: Output interpolated template into $file (otherwise STDOUT). 221 | # 222 | # Args: $file - File to dump output into 223 | # 224 | # Retn: $success - true/false 225 | #------------------------------------------------------------------------------ 226 | 227 | sub output 228 | { 229 | my ($self, $file, $fh); 230 | 231 | $self = shift; 232 | $file = shift; 233 | 234 | if ($file) { 235 | $file = "$outputdir/$file" if ($outputdir); 236 | open $fh, ">$file" or return 0; 237 | } else { 238 | $fh = \*main::STDOUT; 239 | } 240 | 241 | $self->_clear_empty if ($clearempty); 242 | 243 | print $fh $_ foreach (@{$self->{header}}); 244 | 245 | foreach (@{$self->{rows}}) { 246 | print $fh $_; 247 | } 248 | 249 | print $fh $_ foreach (@{$self->{footer}}); 250 | 251 | close $fh if ($file); 252 | 253 | return 1; 254 | } 255 | 256 | 257 | #------------------------------------------------------------------------------ 258 | # Func: string() 259 | # Desc: Return the completed template stuffed into a scalar. 260 | # 261 | # Args: n/a 262 | # 263 | # Retn: $string - output 264 | #------------------------------------------------------------------------------ 265 | 266 | sub string 267 | { 268 | my ($self, $string); 269 | 270 | $self = shift; 271 | 272 | $self->_clear_empty if ($clearempty); 273 | 274 | foreach my $var ('header', 'rows', 'footer') { 275 | foreach (@{$self->{$var}}) { 276 | $string .= $_; 277 | } 278 | } 279 | 280 | return $string; 281 | } 282 | 283 | 284 | #------------------------------------------------------------------------------ 285 | # Func: reset() 286 | # Desc: Reset template to its state prior to interpolation. 287 | # 288 | # Args: n/a 289 | # 290 | # Retn: n/a 291 | #------------------------------------------------------------------------------ 292 | 293 | sub reset 294 | { 295 | my ($self); 296 | 297 | $self = shift; 298 | 299 | foreach my $var ('header', 'repeat', 'footer', 'rows') { 300 | $self->{$var} = []; 301 | } 302 | 303 | return 1; 304 | } 305 | 306 | 307 | #------------------------------------------------------------------------------ 308 | # Func: _clear_empty() 309 | # Desc: Clear any unexpanded placeholders 310 | # 311 | # Args: n/a 312 | # 313 | # Retn: n/a 314 | #------------------------------------------------------------------------------ 315 | 316 | sub _clear_empty 317 | { 318 | my ($self); 319 | 320 | $self = shift; 321 | 322 | foreach my $var ('header', 'repeat', 'footer', 'rows') { 323 | s/\%\%\(.*?\)//g foreach (@{$self->{$var}}); 324 | } 325 | 326 | return 1; 327 | } 328 | 329 | 330 | #------------------------------------------------------------------------------ 331 | # Func: _format_var() 332 | # Desc: Apply formatting (currently just padding and alignment) to the given 333 | # variable, and return it. 334 | # 335 | # Args: $string 336 | # $format 337 | # 338 | # Retn: $result 339 | #------------------------------------------------------------------------------ 340 | 341 | sub _format_var 342 | { 343 | my ($string, $format) = @_; 344 | 345 | $format or return $string; 346 | 347 | if ($format =~ /^([0-9]+)([LR])?$/i) { 348 | my $pad = ' ' x ($1 - length $string); 349 | if ($2 and lc($2) eq 'R') { 350 | $string = $pad.$string; 351 | } else { 352 | $string = $string.$pad; 353 | } 354 | } elsif ($format =~ /^X$/i) { 355 | $string = uri_escape($string); 356 | } 357 | 358 | return $string; 359 | } 360 | 361 | 362 | 1; 363 | -------------------------------------------------------------------------------- /Portscout/Util.pm: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # Copyright (C) 2011, Shaun Amott 3 | # All rights reserved. 4 | # 5 | # Redistribution and use in source and binary forms, with or without 6 | # modification, are permitted provided that the following conditions 7 | # are met: 8 | # 1. Redistributions of source code must retain the above copyright 9 | # notice, this list of conditions and the following disclaimer. 10 | # 2. Redistributions in binary form must reproduce the above copyright 11 | # notice, this list of conditions and the following disclaimer in the 12 | # documentation and/or other materials provided with the distribution. 13 | # 14 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 | # SUCH DAMAGE. 25 | # 26 | # $Id: Util.pm,v 1.12 2011/05/15 17:27:05 samott Exp $ 27 | #------------------------------------------------------------------------------ 28 | 29 | package Portscout::Util; 30 | 31 | use Portscout::Const; 32 | use Portscout::Config; 33 | 34 | require Exporter; 35 | 36 | use strict; 37 | 38 | require 5.006; 39 | 40 | our @ISA = qw(Exporter); 41 | 42 | our @EXPORT = qw( 43 | $date_regex 44 | $beta_regex 45 | $month_regex 46 | $ext_regex 47 | 48 | &strchop 49 | &emptydir 50 | &isbeta 51 | &chopbeta 52 | &verguess 53 | &vercompare 54 | &betacompare 55 | &checkevenodd 56 | &extractfilenames 57 | &extractdirectories 58 | &info 59 | &randstr 60 | &arrexists 61 | &wantport 62 | &uri_filename 63 | &uri_lastdir 64 | &getdbver 65 | &getstat 66 | &setstat 67 | &prepare_sql 68 | &finish_sql 69 | &connect_db 70 | ); 71 | 72 | 73 | #------------------------------------------------------------------------------ 74 | # Globals 75 | #------------------------------------------------------------------------------ 76 | 77 | our %settings; 78 | 79 | our (@months, $date_regex, $beta_regex, $month_regex, $ext_regex); 80 | 81 | my %beta_types; 82 | 83 | my %want_regex = ( 84 | port => restrict2regex($settings{restrict_port}), 85 | category => restrict2regex($settings{restrict_category}), 86 | maintainer => restrict2regex($settings{restrict_maintainer}) 87 | ); 88 | 89 | @months = ( 90 | qr/Jan(?:uary)?/, qr/Feb(?:ruary)?/, qr/Mar(?:ch)?/, qr/Apr(?:il)?/, 91 | qr/May/, qr/Jun(?:e)?/, qr/Jul(?:y)?/, qr/Aug(?:ust)?/, qr/Sep(?:tember)?/, 92 | qr/Oct(?:ober)?/, qr/Nov(?:ember)?/, qr/Dec(?:ember)?/ 93 | ); 94 | 95 | $month_regex = 'Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec'; 96 | $date_regex = '(? { re => 'svn|cvs|snap(?:shot)?', rank => 1 }, 100 | unstable => { re => 'unstable|dev|test', rank => 2 }, 101 | alpha => { re => 'alpha|a(?=\d+|$)', rank => 3 }, 102 | beta => { re => 'beta|b(?=\d+|$)', rank => 4 }, 103 | prerelease => { re => 'pre.*?|p(?=\d+|$)', rank => 5 }, 104 | relcand => { re => 'rc|r(?=\d+|$)', rank => 6 } 105 | ); 106 | 107 | $beta_regex = join '|', map +($beta_types{$_}->{re}), keys %beta_types; 108 | 109 | $ext_regex = '\.tar\.gz|\.tar\.bz2|\.tgz\|\.zip'; 110 | 111 | 112 | #------------------------------------------------------------------------------ 113 | # Func: strchop() 114 | # Desc: Chop or pad string to $limit characters, using ellipses to contract. 115 | # 116 | # Args: $str - String to manipulate. 117 | # $limit - Length of new string. 118 | # 119 | # Retn: $str - Modified string. 120 | #------------------------------------------------------------------------------ 121 | 122 | sub strchop 123 | { 124 | my ($str, $limit) = @_; 125 | 126 | my $slen = int ($limit / 2) - 3; 127 | my $elen = ($limit - 3) - $slen; 128 | 129 | return '' if (!$str or !$limit); 130 | 131 | if (length $str > $limit) 132 | { 133 | return $str if ($str =~ s/^(.{$slen}).*(.{$elen})$/$1...$2/); 134 | } 135 | elsif (length $str < $limit) 136 | { 137 | return $str if $str .= ' ' x ($limit - length $str); 138 | } 139 | 140 | return $str; 141 | } 142 | 143 | 144 | #------------------------------------------------------------------------------ 145 | # Func: emptydir() 146 | # Desc: Remove all files from a given directory, or create an empty directory 147 | # if it doesn't already exist. 148 | # 149 | # Args: $dir - Directory to clear 150 | # 151 | # Retn: $success - true/false 152 | #------------------------------------------------------------------------------ 153 | 154 | sub emptydir 155 | { 156 | my ($dir) = @_; 157 | 158 | return 0 if (!$dir); 159 | 160 | if (-d $dir) { 161 | opendir my $dh, "$dir"; 162 | unlink "$dir/$_" foreach readdir($dh); 163 | closedir $dh; 164 | } else { 165 | mkdir $dir; 166 | } 167 | 168 | return 1; 169 | } 170 | 171 | 172 | #------------------------------------------------------------------------------ 173 | # Func: isbeta() 174 | # Desc: Determine if a version (or filename) looks like a beta/alpha/dev't 175 | # version. 176 | # 177 | # Args: $version - Version or full filename. 178 | # 179 | # Retn: $isbeta - Looks like beta? 180 | #------------------------------------------------------------------------------ 181 | 182 | sub isbeta 183 | { 184 | my ($version) = @_; 185 | 186 | return ( 187 | $version =~ /^(.*)[-_.](?:$beta_regex).*$/gi 188 | or $version =~ /^(.*)(?<=\d)(?:$beta_regex).*$/gi 189 | ); 190 | } 191 | 192 | 193 | #------------------------------------------------------------------------------ 194 | # Func: chopbeta() 195 | # Desc: As above, but remove the beta extension from the string. 196 | # 197 | # Args: \$version - Version string. 198 | # 199 | # Retn: $isbeta - Looks like beta (and therefore, $version modified)? 200 | #------------------------------------------------------------------------------ 201 | 202 | sub chopbeta 203 | { 204 | my ($version) = @_; 205 | 206 | $version = \$version if (!ref $version); 207 | 208 | return ( 209 | $$version =~ s/^(.*)[-_.](?:$beta_regex)\d*(?:\.\d+)*(.*)$/$1$2/gi 210 | or $$version =~ s/^(.*)(?<=\d)(?:$beta_regex)\d*(?:\.\d+)*(.*)$/$1$2/gi 211 | ); 212 | } 213 | 214 | 215 | #------------------------------------------------------------------------------ 216 | # Func: verguess() 217 | # Desc: Guess possible "next version" values from given string. 218 | # For example: 1.4.2 -> (2.0.0, 1.5.0, 1.4.3) 219 | # 220 | # Args: $ver - Current version string 221 | # $evenoddpart - Incremement nth component by TWO to keep even/odd 222 | # 223 | # Retn: @ver - List of possible new versions 224 | #------------------------------------------------------------------------------ 225 | 226 | sub verguess 227 | { 228 | my ($ver, $evenoddpart) = @_; 229 | my @ver_guesses; 230 | 231 | return if (!$ver); 232 | 233 | my @vparts = split /(\D+)/, $ver; 234 | 235 | my $i = 0; 236 | for (0 .. $#vparts) { 237 | my $guess; 238 | 239 | my $v = $vparts[$i]; 240 | 241 | if ($v =~ /^\d+$/) { 242 | if (defined $evenoddpart and $evenoddpart == $i/2) { 243 | $v+=2; 244 | } else { 245 | $v++; 246 | } 247 | } else { 248 | $i++; 249 | next; 250 | } 251 | 252 | $guess .= $vparts[$_] for (0 .. ($i - 1)); 253 | $guess .= $v; 254 | 255 | for (++$i .. $#vparts) { 256 | if ($vparts[$_] =~ /^\d+$/) { 257 | $guess .= '0' x length $vparts[$_]; 258 | } elsif ($vparts[$_] =~ /^-?[A-Z]+-?$/i) { 259 | last; 260 | } else { 261 | $guess .= $vparts[$_]; 262 | } 263 | } 264 | 265 | push @ver_guesses, $guess; 266 | } 267 | 268 | return @ver_guesses; 269 | } 270 | 271 | 272 | #------------------------------------------------------------------------------ 273 | # Func: vercompare() 274 | # Desc: Compare two version strings and return true if $new is greater than 275 | # $old; otherwise return false. 276 | # 277 | # Args: $ver - New version string 278 | # $old - Old version string 279 | # 280 | # Retn: $result - Is $new greater than $old? Returns -1 for "Maybe" 281 | #------------------------------------------------------------------------------ 282 | 283 | sub vercompare 284 | { 285 | my ($new, $old) = @_; 286 | 287 | if ($settings{version_compare} eq 'pkg_version') { 288 | my $res; 289 | 290 | $new = quotemeta $new; 291 | $old = quotemeta $old; 292 | 293 | $res = qx(pkg_version -t "$new" "$old"); 294 | 295 | return (($res eq '>') ? 1 : 0); 296 | } 297 | 298 | # Attempt to stop false positives on versions that 299 | # look newer - e.g. 2.5 is newer than 2.5-prerelease3 300 | 301 | if (1) { 302 | my $_new = $new; 303 | my $_old = $old; 304 | 305 | my ($newbeta, $oldbeta, $newdots, $olddots); 306 | 307 | if (chopbeta(\$_new)) { 308 | # $new and $old equal except for beta bit 309 | # Therefore, $old (a final release) is newer 310 | return 0 if ($_new eq $old); 311 | 312 | $newbeta = 1; 313 | } 314 | 315 | if (chopbeta(\$_old)) { 316 | # $new and $old equal except for beta bit 317 | # Therefore, $new (a final release) is newer 318 | return 1 if ($_old eq $new); 319 | 320 | $oldbeta = 1; 321 | } 322 | 323 | $olddots = $_old; 324 | $olddots =~ s/[^.]//g; 325 | $olddots = length $olddots; 326 | 327 | $newdots = $_new; 328 | $newdots =~ s/[^.]//g; 329 | $newdots = length $newdots; 330 | 331 | if ($newbeta && $oldbeta && $newdots == $olddots) { 332 | # Both had beta bits; non-beta bits 333 | # have same number of components 334 | # Therefore, don't remove beta bits. 335 | 336 | # ... if just the non-beta bits 337 | # differ, compare them. 338 | return (betacompare($new, $old)) 339 | if ($_new eq $_old); 340 | } else { 341 | # Remove beta bits, as non-beta bits 342 | # differ and can be compared. 343 | $new = $_new; 344 | $old = $_old; 345 | } 346 | } 347 | 348 | # If both version strings contain a date AND other 349 | # numbers, take care to split them and compare 350 | # individually. 351 | 352 | unless ($new =~ /^$date_regex$/i && $old =~ /^$date_regex$/i) 353 | { 354 | my $date_regex = $date_regex; 355 | $date_regex =~ s/\\1/\\3/g; # Bump internal backreference (evil) 356 | 357 | if ($new =~ /^(.*?)[\-\.]?($date_regex)[\-\.]?(.*)$/i) { 358 | my ($new_1, $new_2, $new_3) = ($1, $2, $4); 359 | 360 | if ($old =~ /^(.*?)[\-\.]?($date_regex)[\-\.]?(.*)$/i) { 361 | my ($old_1, $old_2, $old_3) = ($1, $2, $4); 362 | 363 | if ($new_1 and $old_1) { 364 | return vercompare($new_1, $old_1) unless ($new_1 eq $old_1); 365 | } 366 | 367 | if ($new_2 and $old_2) { 368 | return vercompare($new_2, $old_2) unless ($new_2 eq $old_2); 369 | } 370 | 371 | if ($new_3 and $old_3) { 372 | return vercompare($new_3, $old_3) unless ($new_3 eq $old_3); 373 | } elsif ($new_3) { 374 | return 1; 375 | } else { 376 | return 0; 377 | } 378 | } 379 | } 380 | } 381 | 382 | # Give month names a numerical value 383 | 384 | if ($new =~ /$month_regex/i) { 385 | my $i = 1; 386 | foreach my $m (@months) { 387 | $new =~ s/$m/sprintf "%02d", $i/gie; 388 | $i++; 389 | } 390 | } 391 | 392 | if ($old =~ /$month_regex/i) { 393 | my $i = 1; 394 | foreach my $m (@months) { 395 | $old =~ s/$m/sprintf "%02d", $i/gie; 396 | $i++; 397 | } 398 | } 399 | 400 | my @nums_new = split /\D+/, $new; 401 | my @nums_old = split /\D+/, $old; 402 | 403 | foreach my $n (0 .. $#nums_new) { 404 | # New version component; all preceding 405 | # components are equal, so assume newer. 406 | return 1 if (!defined($nums_old[$n])); 407 | 408 | # Attempt to handle cases where version 409 | # component lengths vary. 410 | if (($n == $#nums_new) && (length $nums_new[$n] != length $nums_old[$n])) 411 | { 412 | my $lendiff_thresh; 413 | 414 | $lendiff_thresh = 415 | ($nums_new[$n] =~ /^0/ && $nums_old[$n] =~ /^0/) 416 | ? 1 417 | : 2; 418 | 419 | $nums_new[$n] = $nums_new[$n] . ('0' x length $1) if ($nums_old[$n] =~ /^(0+)/); 420 | $nums_old[$n] = $nums_old[$n] . ('0' x length $1) if ($nums_new[$n] =~ /^(0+)/); 421 | 422 | # Experimental code to catch (some) "backwards" version numbers 423 | 424 | my ($lendiff, $first_old, $first_new); 425 | 426 | $lendiff = length($nums_new[$n]) - length($nums_old[$n]); 427 | $first_new = substr($nums_new[$n], 0, 1); 428 | $first_old = substr($nums_old[$n], 0, 1); 429 | 430 | if ($lendiff >= $lendiff_thresh) { 431 | if ($first_new > $first_old) { 432 | return -1; 433 | } elsif ($first_new == $first_old) { 434 | $nums_old[$n] .= ('0' x $lendiff); 435 | return ($nums_new[$n] > $nums_old[$n]) ? -1 : 0; 436 | } else { 437 | return 0; 438 | } 439 | } elsif ($lendiff <= -$lendiff_thresh) { 440 | if ($first_new < $first_old) { 441 | return 0; 442 | } elsif ($first_new == $first_old) { 443 | $nums_new[$n] .= ('0' x abs $lendiff); 444 | return ($nums_new[$n] < $nums_old[$n]) ? 0 : -1; 445 | } else { 446 | return -1; 447 | } 448 | } 449 | } 450 | 451 | # Otherwise, compare values numerically 452 | return 1 if (0+$nums_new[$n] > 0+$nums_old[$n]); 453 | return 0 if (0+$nums_new[$n] < 0+$nums_old[$n]); 454 | } 455 | 456 | # Fall back to string compare 457 | 458 | return (($new cmp $old) == 1) ? 1 : 0; 459 | } 460 | 461 | 462 | #------------------------------------------------------------------------------ 463 | # Func: betacompare() 464 | # Desc: Compare beta bits of two versions strings and return true if $new is 465 | # greater than $old; otherwise return false. 466 | # 467 | # Result is undefined if either string doesn't contain a beta portion. 468 | # 469 | # Args: $ver - New version string 470 | # $old - Old version string 471 | # 472 | # Retn: $result - Is $new greater than $old? Returns -1 for "Maybe" 473 | #------------------------------------------------------------------------------ 474 | 475 | sub betacompare 476 | { 477 | my ($new, $old) = @_; 478 | 479 | my $newrank = 0; 480 | my $oldrank = 0; 481 | my $newnums = 0; 482 | my $oldnums = 0; 483 | 484 | foreach my $bt (keys %beta_types) { 485 | my $re = $beta_types{$bt}->{re}; 486 | my $rank = $beta_types{$bt}->{rank}; 487 | 488 | if ($new =~ /[-_.](?:$re)(\d*(?:\.\d+)*)/i 489 | or $new =~ /(?<=\d)(?:$re)(\d*(?:\.\d+)*)/i) { 490 | $newrank = $rank; 491 | $newnums = $1 if $1; 492 | } 493 | 494 | if ($old =~ /[-_.](?:$re)(\d*(?:\.\d+)*)/i 495 | or $old =~ /(?<=\d)(?:$re)(\d*(?:\.\d+)*)/i) { 496 | $oldrank = $rank; 497 | $oldnums = $1 if $1; 498 | } 499 | } 500 | 501 | if ($oldrank == $newrank) { 502 | my @nums_new = split /\D+/, $newnums; 503 | my @nums_old = split /\D+/, $oldnums; 504 | 505 | foreach my $n (0 .. $#nums_new) { 506 | # New version component; all preceding 507 | # components are equal, so assume newer. 508 | return 1 if (!defined($nums_old[$n])); 509 | 510 | return 1 if (0+$nums_new[$n] > 0+$nums_old[$n]); 511 | return 0 if (0+$nums_new[$n] < 0+$nums_old[$n]); 512 | } 513 | 514 | # All numbers equal 515 | return 0; 516 | } 517 | 518 | return ($newrank > $oldrank ? 1 : 0); 519 | } 520 | 521 | 522 | #------------------------------------------------------------------------------ 523 | # Func: checkevenodd() 524 | # Desc: Check that a version component is either even or odd. 525 | # 526 | # Args: $version - Version string to check 527 | # $evenodd - True = force even; false = force false 528 | # $component - Zero-based component number to check 529 | # 530 | # Retn: $result - true/false 531 | #------------------------------------------------------------------------------ 532 | 533 | sub checkevenodd 534 | { 535 | my ($version, $evenodd, $component) = @_; 536 | 537 | my @bits = split /\D+/, $version; 538 | 539 | return 0 if $#bits < $component; 540 | 541 | if ($bits[$component] % 2) { 542 | return !$evenodd; 543 | } else { 544 | return $evenodd; 545 | } 546 | } 547 | 548 | 549 | #------------------------------------------------------------------------------ 550 | # Func: extractfilenames() 551 | # Desc: Extract filenames (and dates, where possible) from a mastersite index 552 | # 553 | # Args: $data - Data from master site request. 554 | # $sufx - Distfile suffix (e.g. ".tar.gz") 555 | # \$files - Where to put filenames found. 556 | # \$dates - Where to put dates found. 557 | # 558 | # Retn: $success - true/false 559 | #------------------------------------------------------------------------------ 560 | 561 | sub extractfilenames 562 | { 563 | my ($data, $sufx, $files, $dates) = @_; 564 | 565 | my $got_index = 0; 566 | 567 | $sufx = quotemeta $sufx; 568 | 569 | my $date_regex = 570 | '(?]*?$sufx)\1.*?<\/a>/gi) { 579 | push @$files, $2; 580 | } 581 | 582 | $got_index = /\s*index of.*?<\/title>/i if (!$got_index); 583 | } 584 | 585 | return 1; 586 | } 587 | 588 | 589 | #------------------------------------------------------------------------------ 590 | # Func: extractdirectories() 591 | # Desc: Extract directories from a mastersite index 592 | # 593 | # Args: $data - Data from master site request. 594 | # \$dirs - Where to put directories found. 595 | # 596 | # Retn: $success - true/false 597 | #------------------------------------------------------------------------------ 598 | 599 | sub extractdirectories 600 | { 601 | my ($data, $dirs) = @_; 602 | 603 | foreach (split "\n", $data) { 604 | while (/<a href=(['"])(.*?)\/\1.*?>\2(?:\/<\/a>|<\/a>\/)(?:.*?)/gi) { 605 | push @$dirs, $2; 606 | } 607 | } 608 | 609 | return 1; 610 | } 611 | 612 | 613 | #------------------------------------------------------------------------------ 614 | # Func: info() 615 | # Desc: Format arguments into message and print. 616 | # 617 | # Args: @str - Array of message parts to chop and format. 618 | # $msg - Message to print unformatted after other parts. 619 | # 620 | # Retn: n/a 621 | #------------------------------------------------------------------------------ 622 | 623 | sub info 624 | { 625 | my @items = (@_); 626 | my ($str, $msg); 627 | 628 | return if ($settings{quiet}); 629 | 630 | $msg = pop (@items); 631 | 632 | foreach (@items) { 633 | $str .= ' ' if ($str); 634 | $str .= '[' . strchop($_, 30) . ']'; 635 | } 636 | 637 | print "$str $msg\n"; 638 | } 639 | 640 | 641 | #------------------------------------------------------------------------------ 642 | # Func: randstr() 643 | # Desc: Generate string of random characters 644 | # 645 | # Args: $len - Length of string to generate. 646 | # 647 | # Retn: $str - Random string. 648 | #------------------------------------------------------------------------------ 649 | 650 | sub randstr 651 | { 652 | my ($len) = @_; 653 | 654 | my @chars = ('a'..'z','A'..'Z','0'..'9'); 655 | 656 | my $str; 657 | $str .= $chars[rand @chars] foreach (1 .. $len); 658 | 659 | return $str; 660 | } 661 | 662 | 663 | #------------------------------------------------------------------------------ 664 | # Func: arrexists() 665 | # Desc: 'exists' for array values. 666 | # 667 | # Args: \@array - Array to search. 668 | # $value - Value to check for. 669 | # 670 | # Retn: $exists - Does the value exist? 671 | #------------------------------------------------------------------------------ 672 | 673 | sub arrexists 674 | { 675 | my ($array, $value) = @_; 676 | 677 | foreach (@{$array}) { 678 | return 1 if ($_ eq $value); 679 | } 680 | 681 | return 0; 682 | } 683 | 684 | 685 | #------------------------------------------------------------------------------ 686 | # Func: wantport() 687 | # Desc: Check the restriction lists are either empty or contain the specified 688 | # values. 689 | # 690 | # Args: $port - Port name (undef to skip) 691 | # $category - Category (undef to skip) 692 | # $maintainer - Maintainer (undef to skip) 693 | # 694 | # Retn: $result - true = all values falls within constraints 695 | #------------------------------------------------------------------------------ 696 | 697 | sub wantport 698 | { 699 | my ($port, $category, $maintainer) = @_; 700 | 701 | my ($needed, $matched); 702 | 703 | $needed = 0; 704 | $matched = 0; 705 | 706 | if ($want_regex{maintainer} && defined $maintainer) { 707 | $needed++; 708 | 709 | $maintainer =~ $want_regex{maintainer} 710 | and $matched++; 711 | 712 | return 0 if ($matched != $needed); 713 | } 714 | 715 | if ($want_regex{category} && defined $category) { 716 | $needed++; 717 | 718 | $category =~ $want_regex{category} 719 | and $matched++; 720 | 721 | return 0 if ($matched != $needed); 722 | } 723 | 724 | if ($want_regex{port} && defined $port) { 725 | $needed++; 726 | 727 | if ($port =~ $want_regex{port}) { 728 | $matched++; 729 | } elsif (defined $category 730 | and "$category/$port" =~ $want_regex{port}) { 731 | $matched++; 732 | } 733 | 734 | return 0 if ($matched != $needed); 735 | } 736 | 737 | return ($matched == $needed); 738 | } 739 | 740 | 741 | #------------------------------------------------------------------------------ 742 | # Func: uri_filename() 743 | # Desc: Given a URI object, set or return the filename component. We define 744 | # the filename to be everything after the last slash. 745 | # 746 | # Args: $uri - URI object. 747 | # $filename - New filename (optional). 748 | # 749 | # Retn: $filename - Filename component. 750 | #------------------------------------------------------------------------------ 751 | 752 | sub uri_filename 753 | { 754 | my $uri = shift; 755 | my @segs = $uri->path_segments; 756 | my $curr = $segs[$#segs]; 757 | 758 | if (scalar @_) { 759 | splice(@segs, -1, 1); 760 | $uri->path_segments(@segs, $_[0] || ''); 761 | } 762 | 763 | return $curr; 764 | } 765 | 766 | 767 | #------------------------------------------------------------------------------ 768 | # Func: uri_lastdir() 769 | # Desc: Given a URI object, set or return the last directory. We define this 770 | # to be the everything after the last slash, unless the slash is the 771 | # last character, in which case, return the previous component. 772 | # 773 | # Args: $uri - URI object. 774 | # $lastdir - New directory (optional). 775 | # 776 | # Retn: $lastdir - Last directory component. 777 | #------------------------------------------------------------------------------ 778 | 779 | sub uri_lastdir 780 | { 781 | my $uri = shift; 782 | my @segs = $uri->path_segments; 783 | 784 | my $offs = $segs[$#segs] ? 0 : 1; 785 | my $curr = $segs[$#segs-$offs]; 786 | 787 | if (scalar @_) { 788 | splice(@segs, -1-$offs, 1+$offs); 789 | if ($offs && $_[0]) { 790 | $uri->path_segments(@segs, $_[0], ''); 791 | } else { 792 | $uri->path_segments(@segs, $_[0] || ''); 793 | } 794 | } 795 | 796 | return $curr; 797 | } 798 | 799 | 800 | #------------------------------------------------------------------------------ 801 | # Func: restrict2regex() 802 | # Desc: Convert a comma-separated list of values into a restriction regex for 803 | # use by wantport(). 804 | # 805 | # Args: $csv - Comma-separated string; values may contain * and ? wildcards. 806 | # 807 | # Retn: $re - Compiled regex. 808 | #------------------------------------------------------------------------------ 809 | 810 | sub restrict2regex 811 | { 812 | my ($csv) = @_; 813 | 814 | my @items = split /,/, $csv; 815 | 816 | foreach my $item (@items) { 817 | # Clean up 818 | $item =~ s/\s+$//; 819 | $item =~ s/^\s+//; 820 | $item = lc $item; 821 | 822 | # Quote literal stuff 823 | $item =~ s/([^*?]+)/\Q$1\E/g; 824 | 825 | # Transform wildcards to regex 826 | $item =~ s/\*+/.*/g; 827 | $item =~ s/\?/./g; 828 | } 829 | 830 | if (scalar @items) { 831 | my $list = join '|', @items; 832 | return qr/^(?:$list)$/i; 833 | } else { 834 | return undef; 835 | } 836 | } 837 | 838 | 839 | #------------------------------------------------------------------------------ 840 | # Func: getdbver() 841 | # Desc: Return the current database schema version. 842 | # 843 | # Args: n/a 844 | # 845 | # Retn: $version - database version. 846 | #------------------------------------------------------------------------------ 847 | 848 | sub getdbver 849 | { 850 | my ($dbh, $sth, $ver); 851 | 852 | $dbh = connect_db(); 853 | 854 | $sth = $dbh->prepare($Portscout::SQL::sql{portscout_version}) 855 | or die DBI->errstr; 856 | $sth->execute; 857 | 858 | ($ver) = $sth->fetchrow_array; 859 | 860 | $sth->finish; 861 | 862 | return $ver; 863 | } 864 | 865 | 866 | #------------------------------------------------------------------------------ 867 | # Func: getstat() 868 | # Desc: Retrieve a value from the "stats" table. 869 | # 870 | # Args: $key - Statistic name. 871 | # $type - Datum type (default: TYPE_STRING). 872 | # 873 | # Retn: $val - Value from database. 874 | #------------------------------------------------------------------------------ 875 | 876 | sub getstat 877 | { 878 | my ($key, $type) = @_; 879 | 880 | my ($dbh, $sth, $val); 881 | 882 | $dbh = connect_db(); 883 | 884 | $sth = $dbh->prepare($Portscout::SQL::sql{portscout_getstat}) 885 | or die DBI->errstr; 886 | $sth->execute($key); 887 | 888 | ($val) = $sth->fetchrow_array; 889 | 890 | $sth->finish; 891 | 892 | if ($type == TYPE_INT || $type == TYPE_BOOL) { 893 | $val = 0 + $val; 894 | } 895 | 896 | return $val; 897 | } 898 | 899 | 900 | #------------------------------------------------------------------------------ 901 | # Func: setstat() 902 | # Desc: Set a value in the "stats" table. 903 | # 904 | # Args: $key - Statistic name. 905 | # $val - New value. 906 | # 907 | # Retn: n/a 908 | #------------------------------------------------------------------------------ 909 | 910 | sub setstat 911 | { 912 | my ($key, $val) = @_; 913 | 914 | my ($dbh, $sth); 915 | 916 | return if $settings{precious_data}; 917 | 918 | $val = '' if !defined $val; 919 | 920 | $dbh = connect_db(); 921 | 922 | $sth = $dbh->prepare($Portscout::SQL::sql{portscout_setstat}) 923 | or die DBI->errstr; 924 | $sth->execute($val, $key); 925 | 926 | $sth->finish; 927 | 928 | return; 929 | } 930 | 931 | 932 | #------------------------------------------------------------------------------ 933 | # Func: prepare_sql() 934 | # Desc: Prepare the named SQL statements. 935 | # 936 | # Args: $dbh - Database handle, already connected. 937 | # \%sths - Somewhere to put prepared statement handles 938 | # @queries - Names of queries to prepare -- from %sql hash. 939 | # 940 | # Retn: $success - true/false 941 | #------------------------------------------------------------------------------ 942 | 943 | sub prepare_sql 944 | { 945 | my ($dbh, $sths, @queries) = @_; 946 | 947 | foreach (@queries) { 948 | if (exists $Portscout::SQL::sql{$_}) { 949 | $$sths{$_} = $dbh->prepare($Portscout::SQL::sql{$_}) 950 | or die DBI->errstr . "; statement \"$_\""; 951 | } else { 952 | print STDERR "Attempted to prepare non-existent SQL query ($_).\n"; 953 | return 0; 954 | } 955 | } 956 | 957 | return 1; 958 | } 959 | 960 | 961 | #------------------------------------------------------------------------------ 962 | # Func: finish_sql() 963 | # Desc: Finish specified SQL statements. 964 | # 965 | # Args: \$dbh - Database handle, already connected. 966 | # \%sths - The hash of prepared statement handles. 967 | # 968 | # Retn: $success - true/false 969 | #------------------------------------------------------------------------------ 970 | 971 | sub finish_sql 972 | { 973 | my ($dbh, $sths) = @_; 974 | 975 | $$sths{$_}->finish 976 | foreach (keys %$sths); 977 | 978 | return 1; 979 | } 980 | 981 | 982 | #------------------------------------------------------------------------------ 983 | # Func: connect_db() 984 | # Desc: Connect to database. 985 | # 986 | # Args: $nocache - If set, force new connection. 987 | # 988 | # Retn: $dbh - Database handle. 989 | #------------------------------------------------------------------------------ 990 | 991 | my $g_dbh; 992 | 993 | sub connect_db 994 | { 995 | my ($nocache) = @_; 996 | 997 | my ($dbh); 998 | 999 | if ($nocache) { 1000 | $dbh = DBI->connect( 1001 | $settings{db_connstr}, 1002 | $settings{db_user}, 1003 | $settings{db_pass} 1004 | ) or die DBI->errstr; 1005 | } else { 1006 | $dbh = DBI->connect_cached( 1007 | $settings{db_connstr}, 1008 | $settings{db_user}, 1009 | $settings{db_pass} 1010 | ) or die DBI->errstr; 1011 | 1012 | $g_dbh = $dbh; # Keep handle alive 1013 | } 1014 | 1015 | Portscout::SQL->RegisterHacks($dbh); 1016 | 1017 | return $dbh; 1018 | } 1019 | 1020 | 1021 | 1; 1022 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Please see 'perldoc portscout' for usage instructions. 2 | 3 | Don't forget to review UPDATING if you are upgrading from a previous 4 | release. 5 | -------------------------------------------------------------------------------- /UPDATING: -------------------------------------------------------------------------------- 1 | -- Changes in 0.8.1 ----------------------------------------------------------- 2 | 3 | - The restrict_* configuration options now accept wildcards (? and *). 4 | 5 | 6 | -- Changes in 0.8 ------------------------------------------------------------- 7 | 8 | - SQLite is now supported as a database backend. However, portscout must be 9 | run in non-forking mode when using SQLite. This may or may not change in the 10 | future, but as a consequence, it is recommended that SQLite only be used for 11 | light workloads. 12 | 13 | To put portscout into non-forking mode, be sure to set 14 | 15 | num children = 0 16 | 17 | in portscout.conf. 18 | 19 | - CVSup logs are no longer required; the 'rebuild' method employed by 20 | portscout has now been replaced with the new 'mtime' option; this is cleaner 21 | and simpler, and requires no external files beyond a working ports tree. 22 | 23 | - Master site data are no longer cached, nor even written to disk. The 24 | cache_ms_data and ms_data_dir options are now deprecated. The directory used 25 | for the latter can safely be deleted. 26 | 27 | - An INDEX file is no longer required to run portscout, unless a 28 | restrict_maintainer constraint is in force. In this case, use of INDEX can 29 | be switched off using indexfile_enable, but rebuilding will be as slow as 30 | a full build. 31 | 32 | - It was previously suggested that 'build' could be used in place of 'rebuild' 33 | in case CVSup logs could not be provided to portscout. This is no longer the 34 | case. Be sure to always use 'rebuild' and not 'build', except for initial 35 | population of the database. 36 | 37 | - Static portconfig entries (as provided in initdata.sql) are now deprecated. 38 | These must be set via the PORTSCOUT variable in ports. Static entries can 39 | still be used, but will be lost if the port moves. 40 | -------------------------------------------------------------------------------- /docs/portscout-portconfig.txt: -------------------------------------------------------------------------------- 1 | Details of the PORTSCOUT variable 2 | --------------------------------- 3 | 4 | - Consists of key:value pairs, and whitespace between. 5 | - Don't bother using the variables unless you intend to maintain 6 | them, otherwise portscout's accuracy will degrade rather than improve. 7 | - Don't forget to double up $'s if you use them, to prevent make(1) from 8 | mangling regexes (if in doubt, verify the output of 'make -V PORTSCOUT') 9 | - Each of these variables (keys) can be used only once per port. 10 | - Restrictive variables should be avoided, most ports won't even 11 | need any intervention. 12 | - Ports containing embedded version numbers (e.g. tcl84) are automatically 13 | restricted. - i.e., only distfiles matching tcl 8.4.x will be allowed 14 | (unless the current distfile differs) 15 | - Any regexes or limitations below apply to just the version, not the 16 | whole distfile name. 17 | 18 | Keys 19 | ---- 20 | 21 | site: Tell portscout to look at one specific page or site for downloads, 22 | rather than looking through MASTER_SITES. 23 | 24 | Example: site:http://www.example.net/downloads.php 25 | 26 | Apache index pages or FTP directories are ideal for this. 27 | 28 | limit: Tell portscout to reject any new versions unless they match this 29 | Perl regular expression. 30 | 31 | Example: limit:.*[acd]$$ 32 | 33 | (new versions must end in a, c, or d.) - note the $$ in place 34 | of $. 35 | 36 | skipb: Skip versions that look like beta or RC. This is on (1) by 37 | default. Set to 0 to disable. If the port's version already 38 | looks like a beta release, portscout will accept betas 39 | irrespective of the state of this variable. 40 | 41 | Example: skipb:0 42 | 43 | skipv: Comma-separated list of versions to ignore. 44 | 45 | Example: skipv:1.1,1.9 46 | 47 | limitw: Limit one part of the version number to either even or odd 48 | numbers. This variable is in the form "number,[even|odd]" 49 | The (number+1)th version component will be limited. 50 | 51 | Examples: 52 | 53 | limitw:1,even # Accepted versions: 1.0.1.13.9.8 54 | # 1.2.6 55 | # 12.4.3d 56 | # Rejected versions: 2.5.2 57 | # 5.5 58 | # 8.9 59 | 60 | limitw:0,odd # Accepted versions: 1.1, 3.2 61 | # Rejected versions: 2.0, 6 62 | 63 | ignore: Set to 1 to tell portscout not to do any version checking at 64 | all. Useful if, say, a particular port is not going to be 65 | updated ever again, yet portscout still finds files that look 66 | like updates. 67 | -------------------------------------------------------------------------------- /docs/xml-datasrc-example.xml: -------------------------------------------------------------------------------- 1 | <items> 2 | <item> 3 | <category>www</category> 4 | <name>phpsysinfo</name> 5 | <desc>A PHP script for displaying system information</desc> 6 | <maintainer>me@example.net</maintainer> 7 | <version>3.0.2</version> 8 | <sites> 9 | <site>http://heanet.dl.sourceforge.net/project/%(name)/%(name)/%(version)/</site> 10 | <site>http://sunet.dl.sourceforge.net/project/%(name)/%(name)/%(version)/</site> 11 | <site>http://iweb.dl.sourceforge.net/project/%(name)/%(name)/%(version)/</site> 12 | <site>http://switch.dl.sourceforge.net/project/%(name)/%(name)/%(version)/</site> 13 | <site>http://surfnet.dl.sourceforge.net/project/%(name)/%(name)/%(version)/</site> 14 | <site>http://kent.dl.sourceforge.net/project/%(name)/%(name)/%(version)/</site> 15 | </sites> 16 | </item> 17 | <item> 18 | <category>www</category> 19 | <name>smarty</name> 20 | <desc>The PHP compiling template engine</desc> 21 | <maintainer>me@example.net</maintainer> 22 | <version>2.6.26</version> 23 | <distname>Smarty-%(version)</distname> 24 | <sites> 25 | <site>http://www.smarty.net/distributions/</site> 26 | </sites> 27 | <options> 28 | <option name="limit" value="^2\.6\." /> 29 | </options> 30 | </item> 31 | </items> 32 | -------------------------------------------------------------------------------- /portscout.conf: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | # portscout config file 3 | # 4 | # Format: 5 | # - Comments begin with '#' and extend to the end of the line 6 | # - Variables are case insensitive, and may use spaces or underscores as word 7 | # separators (i.e. ports dir == ports_dir) 8 | # - Variables are separated from their values by a single '=' 9 | # - Paths must have no trailing slash 10 | # - Use quotes if you need to retain leading/trailing whitespace 11 | # - You can reuse previously set variables, like: %(name) - these variables 12 | # must use underscores, not spaces. 13 | # 14 | # $Id: portscout.conf,v 1.16 2011/04/09 17:17:34 samott Exp $ 15 | #------------------------------------------------------------------------------ 16 | 17 | # Space saving variables (only used within this file) 18 | 19 | prefix = /usr/local 20 | tmpdir = /tmp 21 | wwwdir = %(prefix)/www/data 22 | 23 | #-- Data Provider ------------------------------------------------------------- 24 | 25 | # The DataSrc module is what portscout uses to compile information 26 | # into its internal database. In other words, it's the layer between 27 | # the repository of software and portscout itself. 28 | 29 | # Option One: FreeBSD ports (NetBSD and OpenBSD supported too) 30 | 31 | datasrc = Portscout::DataSrc::Ports 32 | #datasrc opts = type:NetBSD 33 | 34 | # Option Two: XML file 35 | 36 | #datasrc = Portscout::DataSrc::XML 37 | #datasrc opts = file:%(prefix)/etc/portscout/software.xml 38 | 39 | #-- User Privileges ----------------------------------------------------------- 40 | 41 | # If these are not empty, portscout will switch to this 42 | # user/group as soon as is practical after starting (if it 43 | # is running as root). 44 | 45 | #user = portscout 46 | #group = portscout 47 | 48 | #-- Directories --------------------------------------------------------------- 49 | 50 | ports dir = /usr/ports # Ports root directory 51 | 52 | html data dir = %(wwwdir)/portscout # Where to put generated HTML 53 | 54 | templates dir = %(prefix)/etc/portscout/templates # Where HTML templates are kept 55 | 56 | #-- Limit Processing ---------------------------------------------------------- 57 | 58 | # The following three variables are comma-separated lists of 59 | # items that portscout should process. If left empty, portscout 60 | # will not limit itself, and will process the whole ports tree. 61 | 62 | # Items in the list may contain * and ? wildcard characters. 63 | 64 | restrict maintainer = # Limit to these maintainers 65 | restrict category = # " " " categories 66 | restrict port = # " " " ports 67 | 68 | # Note that if you set restrict_maintainer, the entire ports 69 | # tree needs to be processed to ascertain which ports meet 70 | # the restriction criterion. This can be avoided if portscout 71 | # has access to an INDEX file. If you don't have an INDEX file, 72 | # and aren't impatient, you can switch off the following. 73 | # With no maintainer restriction in place, it has no effect. 74 | 75 | indexfile enable = true # Use INDEX if needed 76 | 77 | #-- Mailing Settings ---------------------------------------------------------- 78 | 79 | # These are only required if you plan to send out reminder mails 80 | # It is enabled by default because you will need to add some 81 | # addresses to the database for anything to happen anyway. 82 | 83 | # The sender address will have the local hostname attached if it 84 | # is a bare username. 85 | 86 | mail enable = true 87 | 88 | mail from = portscout # Sender address 89 | mail subject = FreeBSD ports you maintain which are out of date 90 | mail subject unmaintained = Unmaintained FreeBSD ports which are out of date 91 | mail method = sendmail # Can be 'sendmail' or 'smtp' 92 | #mail host = localhost # SMTP server, if method is 'smtp' 93 | 94 | #-- Output Settings ----------------------------------------------------------- 95 | 96 | # Timezone options. This is just eye-candy for template generation, 97 | # but setting it to anything other than 'GMT' will cause portscout 98 | # to use the local time, rather than GMT. 99 | 100 | local timezone = GMT # Use Greenwich Time 101 | 102 | # Hide results for ports with no new distfile? 103 | 104 | hide unchanged = false # Show ports with no updates. 105 | 106 | #-- Other Settings ------------------------------------------------------------ 107 | 108 | mastersite limit = 4 # Give up after this many sites 109 | 110 | oldfound enable = true # Stop if curr. distfile found 111 | 112 | precious data = false # Don't write anything to database 113 | num children = 15 # How many worker children to spawn 114 | workqueue size = 20 # How many ports per child at a time 115 | 116 | # This variable specifies what version comparison algorithm 117 | # to use. Supported values are "internal" and "pkg_version"; 118 | # the latter uses 'pkg_version -t', which is pretty straight- 119 | # forward, but makes no attempt at best-guessing backwards 120 | # looking version numbers. The former is a bit more 121 | # sophisticated. 122 | 123 | version compare = internal # Version algorithm to use 124 | 125 | # It is possible for individual ports to give us information 126 | # such as the "limit version" regex. The following variable 127 | # enables this. 128 | 129 | portconfig enable = true # Respect port config hints 130 | 131 | # If you're using portscout with a something other than the 132 | # FreeBSD ports tree, switch this off to disable rejection of 133 | # non-FreeBSD distfiles (such as 1.3.2-win32.zip). 134 | 135 | freebsdhacks enable = true 136 | 137 | # HTTP/FTP options 138 | 139 | http timeout = 120 # Timeout in seconds 140 | 141 | ftp timeout = 120 # Timeout in seconds 142 | ftp passive = true # Try to use passive FTP 143 | ftp retries = 3 # Give up after this many failures 144 | 145 | # The following tell portscout how to deal with sites which have a robots.txt 146 | # file. Possible values: 147 | # standard - Check for robots.txt but only respect portscout-specific bans. 148 | # strict - Respect all bans, including '*' wildcards. 149 | # 150 | # You can disable any robots checks with robots_enable. But think twice 151 | # before doing so: angry system admins are likely to block bots they don't 152 | # like using other methods. 153 | # 154 | # Plenty of sites have blanket robot bans, intended to stop search engine 155 | # crawlers from indexing pages, and thus 'strict' is likely to affect the 156 | # number of results we can gather. 157 | 158 | robots enable = true # Check for robots.txt files 159 | robots checking = strict # Strict robots.txt checking 160 | 161 | # Database connection details 162 | 163 | db user = portscout # Database username 164 | db name = portscout # Database name 165 | db pass = # Password 166 | 167 | # These two are only used for db_connstr, below 168 | 169 | db host = # Host 170 | db port = # Port 171 | 172 | db connstr = DBI:Pg:dbname=%(db_name) 173 | #db connstr = DBI:Pg:dbname=%(db_name);host=%(db_host);port=%(db_port) 174 | #db connstr = DBI:SQLite:dbname=/var/db/portscout.db 175 | 176 | # GitHub site handler settings 177 | # GitHub rate limits requests to its API to a very low number for unauthenticated 178 | # requests, and 5000 per hour for authenticated requests. 179 | # GitHub personal access tokens can be requested on github accounts that 180 | # have a verified email address here: https://github.com/settings/tokens 181 | # A public personal access token without any special permissions will do(!) 182 | 183 | #github token = # GitHub personal access token 184 | 185 | # ex: ts=4 sw=4 186 | -------------------------------------------------------------------------------- /portscout.pod: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | portscout - A tool to scan for new versions of FreeBSD ports. 4 | 5 | 6 | =head1 SYNOPSIS 7 | 8 | portscout build 9 | 10 | while (lazy) { 11 | portscout rebuild 12 | portscout check 13 | portscout showupdates 14 | } 15 | 16 | 17 | =head1 DESCRIPTION 18 | 19 | Portscout is an automated system designed to search for new versions of 20 | software available in the FreeBSD ports tree. It is primarily designed for use 21 | by FreeBSD port maintainers, who can avoid trailing around dozens of websites 22 | looking for updates. However, I hope that others might find it useful too. 23 | 24 | The current version of Portscout is also capable of checking OpenBSD's ports, 25 | NetBSD's pkgsrc, and also a generic list of software from an XML file. 26 | 27 | 28 | =head1 SYSTEM REQUIREMENTS 29 | 30 | The following software is required to run Portscout: 31 | 32 | - PostgreSQL or SQLite 33 | - POSIX-compatible system 34 | - The FreeBSD ports tree 35 | - Berkeley make 36 | - Perl 5.6+ 37 | 38 | Plus we need a few Perl modules: 39 | 40 | - URI 41 | - DBD::Pg or DBD::SQLite 42 | - Net::FTP 43 | - Proc::Queue 44 | - LWP::UserAgent 45 | - MIME::Lite 46 | - XML::XPath 47 | - XML::XPath::XMLParser 48 | - JSON 49 | 50 | SQLite support is currently limited to non-forking mode only. That is, if you 51 | decide to use SQLite, Portscout will only check one port at a time; this will 52 | severely limit Portscout's speed/efficiency. It is therefore suggested that 53 | SQLite only be used for relatively light workloads. 54 | 55 | 56 | =head1 INITIAL SET-UP 57 | 58 | =head2 Initialise Database 59 | 60 | The recommended database backend is PostgreSQL. 61 | 62 | =head3 Option One: PostgreSQL 63 | 64 | Create database: 65 | 66 | # createuser -U pgsql -P portscout 67 | # createdb -U pgsql portscout 68 | 69 | Execute the included F<pgsql_init.sql> script via C<psql>: 70 | 71 | # psql portscout portscout < sql/pgsql_init.sql 72 | 73 | This will create the database tables for you. 74 | 75 | =head3 Option Two: SQLite 76 | 77 | Create a database file with the included script: 78 | 79 | # sqlite3 /var/db/portscout.db < sql/sqlite_init.sql 80 | 81 | =head2 Configure Portscout 82 | 83 | Review F<portscout.conf>, and check it suits your needs. The defaults should be 84 | reasonable for most people. You can reduce C<num_children> and C<workqueue_size> 85 | if you don't want Portscout sucking up all your resources. 86 | 87 | Please note that Portscout's internal defaults differ from the defaults in 88 | F<portscout.conf> - this is because without a config file, Portscout tries to be 89 | "portable" and use its own directory for storing things under, whereas if a 90 | config file is found, it assumes it is installed and being used "system-wide". 91 | 92 | Any of the options in F<portscout.conf> can also be set on the fly on the 93 | command line. For example: 94 | 95 | $ portscout --precious_data --num_children=8 96 | 97 | =head2 Update Ports Tree (FreeBSD Only) 98 | 99 | Ensure your ports tree is up to date. 100 | 101 | =head2 Populate Database 102 | 103 | We need now to populate the database with the software we want to check. 104 | 105 | =head3 Option One: FreeBSD 106 | 107 | If you're using Portscout to check FreeBSD ports, run: 108 | 109 | $ portscout build 110 | 111 | This takes around 70 minutes for me. Basically, Portscout is extracting all 112 | the information it needs from the ports tree. Ports (by virtue of make) is 113 | slow; the database we're building is much faster. After this initial build, we 114 | will do incremental 'builds', only updating what has changed. 115 | 116 | =head3 Option Two: Other Software Repositories 117 | 118 | If you would like to check another software repository/source, Portscout 119 | has several options. 120 | 121 | Firstly, NetBSD and OpenBSD's ports trees are supported by the standard 122 | "Ports" backend. See F<portscout.conf> for details on how to configure this. 123 | Make sure you've got the correct C<make> at hand for Portscout if you're 124 | checking either of these from another operating system (e.g. FreeBSD). 125 | 126 | Caveat: neither of the above have been well-tested, and support should 127 | probably be considered experimental. 128 | 129 | Secondly, you can use the "XML" backend for a finite list of software 130 | that you want to manage by hand. See L<Portscout::DataSrc::XML|Portscout::DataSrc::XML> 131 | for more information. 132 | 133 | 134 | =head1 REGULAR OPERATION 135 | 136 | =head2 Update Ports Tree (FreeBSD Only) 137 | 138 | Ensure your ports tree is up to date. 139 | 140 | =head2 Incremental Database Update 141 | 142 | If your ports tree / data source was updated since your last build/rebuild, 143 | ensure Portscout knows about the changes: 144 | 145 | $ portscout rebuild 146 | 147 | =head2 Run Version Checks 148 | 149 | $ portscout check 150 | 151 | This will instruct Portscout to search for new distfiles for each port in the 152 | database. It will take several hours for a complete ports tree scan. 153 | 154 | =head2 View Results 155 | 156 | Now you've got some results, you can view them. 157 | 158 | =head3 Option One: HTML Reports 159 | 160 | $ portscout generate 161 | 162 | This will put HTML pages inside C<html_data_dir> - existing pages will be 163 | deleted. 164 | 165 | =head3 Option Two: E-Mail Reports 166 | 167 | $ portscout mail 168 | 169 | This will send out an e-mail message to the maintainers of ports with updates. 170 | The e-mail messages are opt-in; you will need to add addresses to the database 171 | before any e-mails are sent out. 172 | 173 | =head3 Option Three: Console Summary 174 | 175 | $ portscout showupdates 176 | 177 | This will output a summary of software with outstanding updates. It is 178 | recommended if you're checking a limited set of software/ports. 179 | 180 | 181 | =head1 ADDING E-MAIL ADDRESSES 182 | 183 | If you want to send e-mail reports to maintainers of updated of software, the 184 | e-mail addresses need to be registered with Portscout. This is a safeguard to 185 | ensure no one gets e-mails they don't want. 186 | 187 | Use the following to manage these e-mail "subscriptions": 188 | 189 | $ portscout add-mail dave@example.net 190 | 191 | $ portscout remove-mail john@localhost 192 | 193 | $ portscout show-mail 194 | 195 | 196 | =head1 UPGRADING 197 | 198 | When upgrading, check the F<sql> directory for any relevant database schema 199 | upgrade scripts. If there were multiple schema updates between the previous 200 | version of Portscout and the version to which you have upgraded, be sure to 201 | run each script in sequence to arrive at the latest database version. 202 | 203 | 204 | =head1 CHECKING ALGORITHM 205 | 206 | For anyone interested in how Portscout operates, here is a high-level summary 207 | of the checking algorithm in use: 208 | 209 | Test 1: 210 | 1) Order master sites using previous reliability data. 211 | 2) Attempt to get an FTP listing or web server index from each site. 212 | 3) Extract version from files found; compare to current version. 213 | 4) Skip other tests if new or current version is found. 214 | 215 | Test 2: 216 | 1) Increment each part of the port's version string and attempt to 217 | download file, e.g. for 1.4.2, try 2.0.0, 1.5.0 and 1.4.3 218 | 219 | The last test is not yet included in Portscout, but I may add it at some 220 | point, depending on the results of testing: 221 | 222 | Test 3: 223 | 1) Locate port's WWW page and spider site in an attempt to find a 224 | page that looks like a "download area". Scan page for possible 225 | links to new files. 226 | 227 | 228 | =head1 BUGS AND LIMITATIONS 229 | 230 | =over 231 | 232 | =item 233 | 234 | Portscout tries to make a reasonable guess when it encounters version 235 | strings in a different format to the original distname (e.g. 3.2, 236 | 3.6-pre7), but this is difficult and error-prone since vendor version 237 | schemes vary wildly. 238 | 239 | The only real problem at the moment is version strings which seem to 240 | to count backwards (e.g. 2.11 -> 2.2). 241 | 242 | =item 243 | 244 | There's some difficulty in deciding what to do with trailing zeros 245 | in version guesses. Currently, they are left intact, but this is 246 | not always going to be the right course of action. In other words, 247 | from 4.3.9, will the next major version be 4.4.0 or 4.4? 248 | 249 | =item 250 | 251 | The restrict_* variables don't affect generate/mail. 252 | 253 | =item 254 | 255 | Portscout doesn't handle ports with multiple distfiles very well. 256 | 257 | =item 258 | 259 | At least one port (archivers/zip, as of 2010-04-28) doesn't provide 260 | a version string in the vendor's format. portscout doesn't know what 261 | to do in this case, although the version could theoretically be 262 | ascertained from the distfile name. 263 | 264 | =back 265 | 266 | 267 | =head1 COPYRIGHT 268 | 269 | Copyright (C) 2005-2011, Shaun Amott E<lt>shaun@inerd.comE<gt>. 270 | All rights reserved. 271 | 272 | =cut 273 | -------------------------------------------------------------------------------- /sql/pgsql_destroy.sql: -------------------------------------------------------------------------------- 1 | /* 2 | * Drop all portscout SQL tables. 3 | * 4 | * Copyright (C) 2006-2010, Shaun Amott <shaun@inerd.com> 5 | * All rights reserved. 6 | * 7 | * $Id: pgsql_destroy.sql,v 1.5 2010/05/15 15:11:23 samott Exp $ 8 | */ 9 | 10 | DROP TABLE portdata; 11 | DROP TABLE sitedata; 12 | DROP TABLE moveddata; 13 | DROP TABLE portscout; 14 | DROP TABLE stats; 15 | DROP TABLE maildata; 16 | DROP TABLE allocators; 17 | DROP TABLE systemdata; 18 | -------------------------------------------------------------------------------- /sql/pgsql_init.sql: -------------------------------------------------------------------------------- 1 | /* 2 | * Create initial portscout SQL tables 3 | * 4 | * Copyright (C) 2006-2011, Shaun Amott <shaun@inerd.com> 5 | * All rights reserved. 6 | * 7 | * $Id: pgsql_init.sql,v 1.16 2011/05/15 17:27:05 samott Exp $ 8 | */ 9 | 10 | CREATE TABLE portdata ( 11 | id serial UNIQUE, 12 | name text, 13 | distname text, 14 | ver text, 15 | newver text, 16 | comment text, 17 | cat text, 18 | distfiles text, 19 | sufx text, 20 | mastersites text, 21 | checked timestamp, 22 | updated timestamp DEFAULT CURRENT_TIMESTAMP, 23 | discovered timestamp, 24 | maintainer text, 25 | status text, 26 | method integer, 27 | newurl text, 28 | ignore boolean DEFAULT FALSE, 29 | limitver text, 30 | masterport text, 31 | masterport_id integer DEFAULT 0, 32 | enslaved boolean DEFAULT FALSE, 33 | skipbeta boolean DEFAULT TRUE, 34 | limiteven boolean, 35 | limitwhich smallint, 36 | moved boolean DEFAULT FALSE, 37 | indexsite text, 38 | skipversions text, 39 | pcfg_static boolean DEFAULT FALSE, 40 | mailed text DEFAULT '', 41 | systemid integer 42 | ); 43 | 44 | CREATE TABLE sitedata ( 45 | id serial UNIQUE, 46 | failures integer DEFAULT 0, 47 | successes integer DEFAULT 0, 48 | liecount integer DEFAULT 0, 49 | robots integer DEFAULT 1, 50 | robots_paths text DEFAULT '', 51 | robots_nextcheck timestamp, 52 | type text, 53 | host text, 54 | ignore boolean DEFAULT FALSE 55 | ); 56 | 57 | CREATE TABLE moveddata ( 58 | id serial UNIQUE, 59 | fromport text, 60 | toport text, 61 | date text, 62 | reason text 63 | ); 64 | 65 | CREATE TABLE maildata ( 66 | id serial UNIQUE, 67 | address text 68 | ); 69 | 70 | CREATE TABLE systemdata ( 71 | id serial UNIQUE, 72 | host text 73 | ); 74 | 75 | CREATE TABLE allocators ( 76 | id serial UNIQUE, 77 | seq integer NOT NULL, 78 | systemid integer REFERENCES systemdata (id), 79 | allocator text 80 | ); 81 | 82 | CREATE TABLE portscout ( 83 | dbver integer 84 | ); 85 | 86 | CREATE TABLE stats ( 87 | key text, 88 | val text DEFAULT '' 89 | ); 90 | 91 | INSERT 92 | INTO portscout (dbver) 93 | VALUES (2011040901); 94 | 95 | INSERT 96 | INTO stats (key) 97 | VALUES ('buildtime'); 98 | 99 | CREATE 100 | INDEX portdata_index_name 101 | ON portdata (name); 102 | 103 | CREATE 104 | INDEX portdata_index_maintainer 105 | ON portdata (maintainer); 106 | 107 | CREATE 108 | INDEX portdata_index_lower_maintainer 109 | ON portdata (lower(maintainer)); 110 | 111 | CREATE 112 | INDEX portdata_index_masterport_id 113 | ON portdata (masterport_id); 114 | 115 | CREATE 116 | INDEX portdata_index_discovered 117 | ON portdata (discovered); 118 | 119 | CREATE 120 | INDEX sitedata_index_host 121 | ON sitedata (host); 122 | 123 | CREATE 124 | INDEX moveddata_index_fromport 125 | ON moveddata (fromport); 126 | -------------------------------------------------------------------------------- /sql/pgsql_upgrade_0.7.1_to_0.7.2.sql: -------------------------------------------------------------------------------- 1 | /* 2 | * Upgrade database schema. 3 | * 4 | * Copyright (C) 2006-2007, Shaun Amott <shaun@inerd.com> 5 | * All rights reserved. 6 | * 7 | * $Id: pgsql_upgrade_0.7.1_to_0.7.2.sql,v 1.1 2007/02/02 23:03:04 samott Exp $ 8 | */ 9 | 10 | DELETE 11 | FROM portscout; 12 | 13 | INSERT 14 | INTO portscout (dbver) 15 | VALUES (2007020201); 16 | 17 | CREATE 18 | INDEX portdata_index_masterport_id 19 | ON portdata (masterport_id); 20 | -------------------------------------------------------------------------------- /sql/pgsql_upgrade_0.7.3_to_0.7.4.sql: -------------------------------------------------------------------------------- 1 | /* 2 | * Upgrade database schema. 3 | * 4 | * Copyright (C) 2006-2008, Shaun Amott <shaun@inerd.com> 5 | * All rights reserved. 6 | * 7 | * $Id: pgsql_upgrade_0.7.3_to_0.7.4.sql,v 1.1 2008/01/24 04:10:35 samott Exp $ 8 | */ 9 | 10 | DELETE 11 | FROM portscout; 12 | 13 | INSERT 14 | INTO portscout (dbver) 15 | VALUES (2008012301); 16 | 17 | ALTER TABLE sitedata ADD COLUMN robots integer; 18 | ALTER TABLE sitedata ALTER COLUMN robots SET DEFAULT 1; 19 | UPDATE sitedata SET robots = 1 WHERE robots is NULL; 20 | 21 | ALTER TABLE sitedata ADD COLUMN robots_paths text; 22 | ALTER TABLE sitedata ALTER COLUMN robots_paths SET DEFAULT ''; 23 | UPDATE sitedata SET robots_paths = '' WHERE robots_paths is NULL; 24 | 25 | ALTER TABLE sitedata ADD COLUMN robots_nextcheck timestamp; 26 | -------------------------------------------------------------------------------- /sql/pgsql_upgrade_0.7.4_to_0.8.sql: -------------------------------------------------------------------------------- 1 | /* 2 | * Upgrade database schema. 3 | * 4 | * Copyright (C) 2010, Shaun Amott <shaun@inerd.com> 5 | * All rights reserved. 6 | * 7 | * $Id: pgsql_upgrade_0.7.4_to_0.8.sql,v 1.1 2010/05/24 02:35:02 samott Exp $ 8 | */ 9 | 10 | DELETE 11 | FROM portscout; 12 | 13 | INSERT 14 | INTO portscout (dbver) 15 | VALUES (2010030301); 16 | 17 | CREATE TABLE stats ( 18 | key text, 19 | val text 20 | ); 21 | 22 | CREATE 23 | INDEX sitedata_index_host 24 | ON sitedata (host); 25 | 26 | CREATE 27 | INDEX moveddata_index_fromport 28 | ON moveddata (fromport); 29 | 30 | /* 31 | * A value of zero will cause a full rebuild, but we need to 32 | * do this anyway, as there's a bug in 0.7.4 which means we 33 | * need to re-gather MASTER_SITES for certain ports. 34 | */ 35 | 36 | INSERT 37 | INTO stats (key, val) 38 | VALUES ('buildtime', 0); 39 | 40 | ALTER TABLE portdata DROP COLUMN dir; 41 | ALTER TABLE portdata DROP COLUMN home; 42 | 43 | ALTER TABLE portdata ADD COLUMN enslaved boolean; 44 | ALTER TABLE portdata ALTER COLUMN enslaved SET DEFAULT FALSE; 45 | UPDATE portdata SET enslaved = FALSE WHERE enslaved is NULL; 46 | 47 | /* 48 | * Previous values are suspect due to a bug in 0.7.4. 49 | */ 50 | 51 | UPDATE sitedata SET liecount = 0; 52 | -------------------------------------------------------------------------------- /sql/pgsql_upgrade_0.8_to_0.8.1.sql: -------------------------------------------------------------------------------- 1 | /* 2 | * Upgrade database schema. 3 | * 4 | * Copyright (C) 2011, Shaun Amott <shaun@inerd.com> 5 | * All rights reserved. 6 | * 7 | * $Id: pgsql_upgrade_0.8_to_0.8.1.sql,v 1.1 2011/05/15 17:19:39 samott Exp $ 8 | */ 9 | 10 | ALTER TABLE portdata ADD COLUMN discovered timestamp; 11 | 12 | DELETE 13 | FROM portscout; 14 | 15 | INSERT 16 | INTO portscout (dbver) 17 | VALUES (2011040901); 18 | 19 | CREATE 20 | INDEX portdata_index_discovered 21 | ON portdata (discovered); 22 | -------------------------------------------------------------------------------- /sql/sqlite_destroy.sql: -------------------------------------------------------------------------------- 1 | /* 2 | * Drop all portscout SQL tables. 3 | * 4 | * Copyright (C) 2006-2010, Shaun Amott <shaun@inerd.com> 5 | * All rights reserved. 6 | * 7 | * $Id: sqlite_destroy.sql,v 1.1 2010/05/15 15:11:57 samott Exp $ 8 | */ 9 | 10 | DROP TABLE portdata; 11 | DROP TABLE sitedata; 12 | DROP TABLE moveddata; 13 | DROP TABLE portscout; 14 | DROP TABLE stats; 15 | DROP TABLE maildata; 16 | DROP TABLE allocators; 17 | DROP TABLE systemdata; 18 | DROP TABLE results; 19 | -------------------------------------------------------------------------------- /sql/sqlite_init.sql: -------------------------------------------------------------------------------- 1 | /* 2 | * Create initial portscout SQL tables 3 | * 4 | * Copyright (C) 2006-2011, Shaun Amott <shaun@inerd.com> 5 | * All rights reserved. 6 | * 7 | * $Id: sqlite_init.sql,v 1.4 2011/05/15 17:27:05 samott Exp $ 8 | */ 9 | 10 | CREATE TABLE portdata ( 11 | `id` integer PRIMARY KEY, 12 | `name` text, 13 | `distname` text, 14 | `ver` text, 15 | `newver` text, 16 | `comment` text, 17 | `cat` text, 18 | `distfiles` text, 19 | `sufx` text, 20 | `mastersites` text, 21 | `updated` timestamp DEFAULT CURRENT_TIMESTAMP, 22 | `discovered` timestamp, 23 | `checked` timestamp, 24 | `maintainer` text COLLATE NOCASE, 25 | `status` text, 26 | `method` integer, 27 | `newurl` text, 28 | `ignore` smallint DEFAULT 0, 29 | `limitver` text, 30 | `masterport` text, 31 | `masterport_id` integer DEFAULT 0, 32 | `enslaved` integer DEFAULT 0, 33 | `skipbeta` smallint DEFAULT 1, 34 | `limiteven` smallint, 35 | `limitwhich` smallint, 36 | `moved` smallint DEFAULT 0, 37 | `indexsite` text, 38 | `skipversions` text, 39 | `pcfg_static` smallint DEFAULT 0, 40 | `mailed` text DEFAULT '', 41 | `systemid` integer 42 | ); 43 | 44 | CREATE TABLE sitedata ( 45 | `id` integer PRIMARY KEY, 46 | `failures` integer DEFAULT 0, 47 | `successes` integer DEFAULT 0, 48 | `liecount` integer DEFAULT 0, 49 | `robots` integer DEFAULT 1, 50 | `robots_paths` text DEFAULT '', 51 | `robots_nextcheck` timestamp, 52 | `type` text, 53 | `host` text, 54 | `ignore` smallint DEFAULT 0 55 | ); 56 | 57 | CREATE TABLE moveddata ( 58 | `id` integer PRIMARY KEY, 59 | `fromport` text, 60 | `toport` text, 61 | `date` text, 62 | `reason` text 63 | ); 64 | 65 | CREATE TABLE maildata ( 66 | `id` integer PRIMARY KEY, 67 | `address` text COLLATE NOCASE 68 | ); 69 | 70 | CREATE TABLE systemdata ( 71 | `id` integer PRIMARY KEY, 72 | `host` text 73 | ); 74 | 75 | CREATE TABLE allocators ( 76 | `id` integer PRIMARY KEY, 77 | `seq` integer NOT NULL, 78 | `systemid` integer REFERENCES systemdata (id), 79 | `allocator` text 80 | ); 81 | 82 | CREATE TABLE portscout ( 83 | `dbver` integer 84 | ); 85 | 86 | CREATE TABLE stats ( 87 | `key` text, 88 | `val` text 89 | ); 90 | 91 | CREATE TABLE results ( 92 | `maintainer` text, 93 | `total` integer, 94 | `withnewdistfile` integer, 95 | `percentage` float 96 | ); 97 | 98 | INSERT 99 | INTO portscout (dbver) 100 | VALUES (2011040901); 101 | 102 | INSERT 103 | INTO stats (key) 104 | VALUES ('buildtime'); 105 | 106 | CREATE 107 | INDEX portdata_index_name 108 | ON portdata (name); 109 | 110 | /* 111 | CREATE 112 | INDEX portdata_index_maintainer 113 | ON portdata (maintainer); 114 | */ 115 | 116 | CREATE 117 | INDEX portdata_index_lower_maintainer 118 | ON portdata (maintainer COLLATE NOCASE); 119 | 120 | CREATE 121 | INDEX portdata_index_masterport_id 122 | ON portdata (masterport_id); 123 | 124 | CREATE 125 | INDEX portdata_index_discovered 126 | ON portdata (discovered); 127 | 128 | CREATE 129 | INDEX sitedata_index_host 130 | ON sitedata (host); 131 | 132 | CREATE 133 | INDEX moveddata_index_fromport 134 | ON moveddata (fromport); 135 | 136 | CREATE 137 | INDEX results_index_maintainer 138 | ON results (maintainer); 139 | -------------------------------------------------------------------------------- /sql/sqlite_upgrade_0.8_to_0.8.1.sql: -------------------------------------------------------------------------------- 1 | /* 2 | * Upgrade database schema. 3 | * 4 | * Copyright (C) 2011, Shaun Amott <shaun@inerd.com> 5 | * All rights reserved. 6 | * 7 | * $Id: sqlite_upgrade_0.8_to_0.8.1.sql,v 1.1 2011/05/15 17:19:39 samott Exp $ 8 | */ 9 | 10 | ALTER TABLE portdata ADD COLUMN discovered timestamp; 11 | 12 | DELETE 13 | FROM portscout; 14 | 15 | INSERT 16 | INTO portscout (dbver) 17 | VALUES (2011040901); 18 | 19 | CREATE 20 | INDEX portdata_index_discovered 21 | ON portdata (discovered); 22 | -------------------------------------------------------------------------------- /t/00-use.t: -------------------------------------------------------------------------------- 1 | # Check that all the modules work. 2 | 3 | use Test; 4 | 5 | BEGIN { plan tests => 15; } 6 | 7 | use strict; 8 | use warnings; 9 | 10 | eval 'use Portscout::Const ();'; ok(!$@); 11 | eval 'use Portscout::API();'; ok(!$@); 12 | eval 'use Portscout::Util ();'; ok(!$@); 13 | eval 'use Portscout::Config ();'; ok(!$@); 14 | 15 | eval 'use Portscout::SiteHandler ();'; ok(!$@); 16 | eval 'use Portscout::SiteHandler::SourceForge ();'; ok(!$@); 17 | 18 | eval 'use Portscout::SQL ();'; ok(!$@); 19 | eval 'use Portscout::SQL::SQLite ();'; ok(!$@); 20 | eval 'use Portscout::SQL::Pg ();'; ok(!$@); 21 | 22 | eval 'use Portscout::Make ();'; ok(!$@); 23 | eval 'use Portscout::Template ();'; ok(!$@); 24 | 25 | eval 'use Portscout::DataSrc ();'; ok(!$@); 26 | eval 'use Portscout::DataSrc::Ports ();'; ok(!$@); 27 | eval 'use Portscout::DataSrc::XML ();'; ok(!$@); 28 | 29 | eval 'use Portscout ();'; ok(!$@); 30 | -------------------------------------------------------------------------------- /t/01-vercompare.t: -------------------------------------------------------------------------------- 1 | # Do some version comparisons 2 | 3 | use Test; 4 | 5 | BEGIN { plan tests => 18; } 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use Portscout::Const; 11 | use Portscout::Util; 12 | use Portscout::Config; 13 | 14 | $settings{version_compare} = 'internal'; 15 | 16 | ok(vercompare('1.3.2', '1.3.2'), 0); # Equal, therefore not greater 17 | ok(vercompare('1.8.2', '1.1.2'), 1); 18 | ok(vercompare('1.1.2', '1.8.2'), 0); 19 | ok(vercompare('20010301', '20010304'), 0); 20 | 21 | ok(vercompare('1.8.20', '1.8.2'), 1); 22 | ok(vercompare('1.8.1000', '1.8.20'), 0); # 1000 more likely to mean "1" 23 | 24 | ok(vercompare('2009-May-03', '2009-Jan-07'), 1); # Month names 25 | 26 | ok(vercompare('4.3.2', '4.3.2beta4'), 1); # Betas are older than releases 27 | ok(vercompare('1.2-rc3', '1.2'), 0); # 28 | ok(vercompare('1.0.3', '1.0-beta4'), 1); # Beta no. shouldn't trump the release no. 29 | ok(vercompare('1.0.1-beta8', '1.0-beta4'), 1); # 30 | 31 | ok(vercompare('2.0-alpha3', '2.0-beta'), 0); # beta > alpha 32 | ok(vercompare('3.0-pre8', '3.0pre8'), 0); # Same version, different format 33 | ok(vercompare('1.8rc2', '1.8b6'), 1); # release candidate > beta 34 | 35 | ok(vercompare('2.0-beta4', '2.0-beta3.1'), 1); # Complex beta number 36 | ok(vercompare('2.0-beta3.1.7', '2.0-beta3.1.4'), 1); # 37 | ok(vercompare('8.9-beta2.3.3', '8.9b2.3.4'), 0); # 38 | 39 | ok(vercompare('2.dog', '2.cat'), 1); # Strings should compare too 40 | -------------------------------------------------------------------------------- /t/10-postgresql.t: -------------------------------------------------------------------------------- 1 | # Check that the various SQL statements work. 2 | 3 | use Test; 4 | 5 | BEGIN { plan tests => 2; } 6 | 7 | use DBI; 8 | use File::Temp qw(tempfile tempdir); 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Portscout::Util; 14 | use Portscout::Config; 15 | use Portscout::SQL; 16 | 17 | my (%sths, $dbh, $dbuser, $dbname, $ret); 18 | 19 | $dbname = 'ps_test_' . randstr(8); 20 | $dbuser = $dbname; 21 | 22 | # Create database 23 | 24 | qx(createuser -D -A -U pgsql "$dbuser"); 25 | die if $?; 26 | qx(createdb -U pgsql -E UNICODE "$dbname"); 27 | die if $?; 28 | 29 | qx(psql $dbuser $dbname < sql/pgsql_init.sql); 30 | $ret = $?; 31 | 32 | ok(!$ret); 33 | die unless (!$ret); 34 | 35 | # Connect 36 | 37 | $settings{db_user} = $dbuser; 38 | $settings{db_pass} = ''; 39 | $settings{db_connstr} = "DBI:Pg:dbname=$dbname"; 40 | 41 | Portscout::SQL->Load('Pg'); 42 | 43 | $dbh = connect_db(); 44 | 45 | # Prepare all SQL statements 46 | 47 | eval { 48 | prepare_sql($dbh, \%sths, keys %Portscout::SQL::sql); 49 | }; 50 | 51 | ok(!$@); 52 | 53 | END { 54 | if ($dbh) { 55 | finish_sql($dbh, \%sths); 56 | $dbh->disconnect; 57 | } 58 | if ($dbname) { qx(dropdb -U pgsql "$dbname"); } 59 | if ($dbuser) { qx(dropuser -U pgsql "$dbuser"); } 60 | } 61 | -------------------------------------------------------------------------------- /t/10-sqlite.t: -------------------------------------------------------------------------------- 1 | # Check that the various SQL statements work. 2 | 3 | use Test; 4 | 5 | BEGIN { plan tests => 2; } 6 | 7 | use DBI; 8 | use File::Temp qw(tempfile tempdir); 9 | 10 | use strict; 11 | use warnings; 12 | 13 | use Portscout::Util; 14 | use Portscout::Config; 15 | use Portscout::SQL; 16 | 17 | my (%sths, $dbh, $dir, $dbfile, $ret); 18 | 19 | $dir = tempdir(CLEANUP => 1); 20 | (undef, $dbfile) = tempfile(DIR => $dir); 21 | 22 | # Create database 23 | 24 | qx(sqlite3 $dbfile < sql/sqlite_init.sql); 25 | $ret = $?; 26 | 27 | ok(!$ret); 28 | die unless (!$ret); 29 | 30 | # Connect 31 | 32 | $settings{db_connstr} = "DBI:SQLite:dbname=$dbfile"; 33 | 34 | Portscout::SQL->Load('SQLite'); 35 | 36 | $dbh = connect_db(); 37 | 38 | # Prepare all SQL statements 39 | 40 | eval { 41 | prepare_sql($dbh, \%sths, keys %Portscout::SQL::sql); 42 | }; 43 | 44 | ok(!$@); 45 | -------------------------------------------------------------------------------- /templates/index.html: -------------------------------------------------------------------------------- 1 | <html> 2 | 3 | <head> 4 | <title>portscout - new distfile scanner 5 | 22 | 23 | 83 | 84 | 85 | 86 | 87 |

portscout - New Distfile Scanner

88 | 89 |

All Maintainers

90 |
91 | 92 |

Generated on %%(date) at %%(time), by portscout v%%(appver)

93 | 94 |

Table headings are clickable for different sorting.

95 | 96 |

Restricted ports <-- Please check this!

97 | 98 | 99 | Filter Maintainer (regex): 100 | With out-of-date only 101 | 102 | 103 | 104 | 116 | 117 |

118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | %%: 128 | 129 |
MaintainerTotal PortsPorts with New Distfile(s)% Out of Date
%%(maintainer)%%(total)%%(withnewdistfile)%%(percentage)
130 | 131 | 132 | 133 | -------------------------------------------------------------------------------- /templates/maintainer.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | portscout - new distfile scanner 5 | 21 | 22 | 82 | 83 | 84 | 85 | 86 |

%%(maintainer)'s ports

87 |
88 |

89 | Notes: 90 |

    91 |
  • Port version strings are derived from DISTNAME values; they are not in "ports format"
    • 92 |
  • 93 | Updated/Checked time is when the database was updated and when a new distfile scan was 94 | done, respectively. 95 |
    • 96 |
97 |

98 | 99 |

100 | Port and New Version columns are clickable. 101 |

102 | 103 |

104 | Key for the 'M' column: 105 |

    106 |
  • G = file was found by sending incremental version guesses to server.
    • 107 |
  • L = file was found in FTP or HTTP directory index.
    • 108 |
  • X = port is ignored - new versions are not reported.
    • 109 |
110 |

111 | 112 | 113 | Filter Port (regex): 114 | With out-of-date only 115 | 116 | 117 | 118 | 130 | 131 |

132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | %%: 145 | 146 |
PortCategoryCurrentNewLast UpdatedLast CheckedM
%%(name)%%(cat)%%(ver)%%(newver)%%(updated)%%(checked)%%(method)
147 | 148 | 149 | 150 | -------------------------------------------------------------------------------- /templates/reminder-no-maintainer.mail: -------------------------------------------------------------------------------- 1 | Dear port maintainers, 2 | 3 | The portscout new distfile checker has detected that one or more 4 | unmaintained ports appears to be out of date. Please take the opportunity 5 | to check each of the ports listed below, and if possible and appropriate, 6 | submit/commit an update. Please consider also adopting this port. 7 | If any ports have already been updated, you can safely ignore the entry. 8 | 9 | An e-mail will not be sent again for any of the port/version combinations 10 | below. 11 | 12 | Full details can be found at the following URL: 13 | http://beta.inerd.com/portscout/%%(maintainer).html 14 | 15 | 16 | Port | Current version | New version 17 | ------------------------------------------------+-----------------+------------ 18 | %%:%%(cat_portname:47) | %%(ver:16)| %%(newver) 19 | %%:------------------------------------------------+-----------------+------------ 20 | 21 | 22 | If any of the above results are invalid, please check the following page 23 | for details on how to improve portscout's detection and selection of 24 | distfiles on a per-port basis: 25 | 26 | http://beta.inerd.com/portscout-portconfig.txt 27 | 28 | Thanks. 29 | -------------------------------------------------------------------------------- /templates/reminder.mail: -------------------------------------------------------------------------------- 1 | Dear port maintainer, 2 | 3 | The portscout new distfile checker has detected that one or more of your 4 | ports appears to be out of date. Please take the opportunity to check 5 | each of the ports listed below, and if possible and appropriate, 6 | submit/commit an update. If any ports have already been updated, you can 7 | safely ignore the entry. 8 | 9 | You will not be e-mailed again for any of the port/version combinations 10 | below. 11 | 12 | Full details can be found at the following URL: 13 | http://beta.inerd.com/portscout/%%(maintainer).html 14 | 15 | 16 | Port | Current version | New version 17 | ------------------------------------------------+-----------------+------------ 18 | %%:%%(cat_portname:47) | %%(ver:16)| %%(newver) 19 | %%:------------------------------------------------+-----------------+------------ 20 | 21 | 22 | If any of the above results are invalid, please check the following page 23 | for details on how to improve portscout's detection and selection of 24 | distfiles on a per-port basis: 25 | 26 | http://beta.inerd.com/portscout-portconfig.txt 27 | 28 | If wish to stop (or start!) receiving portscout reminders, please 29 | contact the operator of this installation. 30 | 31 | Thanks. 32 | -------------------------------------------------------------------------------- /templates/restricted-ports.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | portscout - new distfile scanner 5 | 19 | 20 | 21 | 22 | 23 |

Restricted Ports

24 |
25 | 26 |

27 | Notes: 28 |

    29 |
  • 30 | Limit Regex is a Perl regular expression used to limit the port's version. 31 |
    • 32 |
  • 33 | Limit Even/Odd tells portscout to limit the (n+1)th number to even or 34 | odd numbers only. 35 |
    • 36 |
  • 37 | Ports with a version number in their name are automatically dealt with. 38 |
    • 39 |
40 |

41 | 42 |

43 | Please let me know if any of these are incorrect or change. 44 |

45 | 46 |
47 | 48 | 49 | 50 | %%: 51 |
PortCategoryLimit RegexLimit Even/OddSkip Versions
%%(name)%%(cat)%%(limitver)%%(limitevenwhich)%%(skipversions)
52 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /web/rss.cgi: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | #------------------------------------------------------------------------------ 3 | # Copyright (C) 2011, Shaun Amott 4 | # All rights reserved. 5 | # 6 | # Redistribution and use in source and binary forms, with or without 7 | # modification, are permitted provided that the following conditions 8 | # are met: 9 | # 1. Redistributions of source code must retain the above copyright 10 | # notice, this list of conditions and the following disclaimer. 11 | # 2. Redistributions in binary form must reproduce the above copyright 12 | # notice, this list of conditions and the following disclaimer in the 13 | # documentation and/or other materials provided with the distribution. 14 | # 15 | # THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 16 | # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 17 | # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 18 | # ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 19 | # FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 20 | # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 21 | # OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 22 | # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 23 | # LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 24 | # OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 25 | # SUCH DAMAGE. 26 | # 27 | # $Id: rss.cgi,v 1.4 2011/05/15 17:27:05 samott Exp $ 28 | #------------------------------------------------------------------------------ 29 | 30 | #use CGI::Carp qw(fatalsToBrowser); 31 | 32 | use DBI; 33 | use CGI; 34 | use DateTime; 35 | 36 | use XML::RSS; 37 | use CGI::Cache; 38 | 39 | use Portscout::Const; 40 | use Portscout::Util; 41 | use Portscout::Config; 42 | use Portscout::SQL; 43 | 44 | use strict; 45 | 46 | require 5.006; 47 | 48 | 49 | #------------------------------------------------------------------------------ 50 | # Extra config options for this script 51 | #------------------------------------------------------------------------------ 52 | 53 | $settings{rss_url_base} ||= '/portscout/'; 54 | 55 | 56 | #------------------------------------------------------------------------------ 57 | # Begin code 58 | #------------------------------------------------------------------------------ 59 | 60 | main(); 61 | 62 | 63 | #------------------------------------------------------------------------------ 64 | # Pseudo script entry point. 65 | #------------------------------------------------------------------------------ 66 | 67 | sub main 68 | { 69 | my ($dbh, $sth, $rss, $query); 70 | my (@maintainers, @time); 71 | 72 | my $q = new CGI; 73 | 74 | my $recentonly; 75 | 76 | CGI::Cache::setup({ 77 | cache_options => { 78 | cache_root => 'cache', 79 | namespace => 'rss_cgi', 80 | directory_umask => 077, 81 | default_expires_in => '1 hour', 82 | } 83 | }); 84 | 85 | # Check for r ("range") param 86 | 87 | $recentonly = defined $q->param('r'); 88 | 89 | # Accept a comma-separated list of maintainers 90 | 91 | @maintainers = sort(split /,/, lc $q->param('m')) 92 | if ($q->param('m')); 93 | 94 | if (@maintainers) { 95 | if ($recentonly) { 96 | CGI::Cache::set_key(@maintainers, '_recentonly'); 97 | } else { 98 | CGI::Cache::set_key(@maintainers); 99 | } 100 | } else { 101 | CGI::Cache::set_key($recentonly ? '_recentonly' : '_default'); 102 | } 103 | 104 | # Return cached page if it exists 105 | 106 | CGI::Cache::start() or exit; 107 | 108 | # Database stuff 109 | 110 | if (1) { 111 | my $dbengine = $settings{db_connstr}; 112 | $dbengine =~ s/^\s*DBI:([A-Za-z0-9]+):?.*$/$1/; 113 | 114 | Portscout::SQL->Load($dbengine) 115 | or die 'Failed to load queries for DBI engine "' . $dbengine . '"'; 116 | } 117 | 118 | $dbh = connect_db(); 119 | 120 | # Construct an SQL query 121 | 122 | $query = 123 | q(SELECT name, cat, ver, newver, newurl, discovered, 124 | checked, updated, maintainer 125 | FROM portdata 126 | WHERE 1 = 1); 127 | 128 | # XXX: this is slow - need something better 129 | 130 | if (@maintainers) { 131 | $query .= ' AND ( lower(maintainer) = ? '; 132 | $query .= ' OR lower(maintainer) = ? ' x (@maintainers - 1); 133 | $query .= ' ) '; 134 | } 135 | 136 | if ($recentonly) { 137 | $query .= q( AND age(discovered) <= '7 days' ); 138 | } 139 | 140 | $query .= 141 | q( AND ver != newver 142 | AND discovered IS NOT NULL 143 | ORDER BY discovered DESC); 144 | 145 | $sth = $dbh->prepare($query); 146 | $sth->execute(@maintainers); 147 | 148 | $rss = XML::RSS->new(version => '2.0'); 149 | 150 | # Global RSS bits 151 | 152 | $rss->channel( 153 | title => 'Portscout Port Updates', 154 | description => 'New distfiles found via the portscout scanner', 155 | category => [ @maintainers ? @maintainers : '*' ], 156 | lastBuildDate => rssdate(), 157 | generator => APPNAME.' v'.APPVER.', by '.AUTHOR, 158 | link => $settings{rss_url_base} 159 | ); 160 | 161 | $rss->add_module(prefix => 'port', uri => '/dev/null'); 162 | 163 | # Construct an block for each new port update 164 | 165 | while (my $port = $sth->fetchrow_hashref) { 166 | $port->{updated} = rssdate($port->{updated}); 167 | $port->{checked} = rssdate($port->{checked}); 168 | $port->{discovered} = rssdate($port->{discovered}); 169 | 170 | $port->{$_} ||= '' foreach (keys %$port); 171 | 172 | $rss->add_item( 173 | title => "$port->{cat}/$port->{name}: $port->{ver} -> $port->{newver}", 174 | description => "Update found for port $port->{cat}/$port->{name}: version $port->{ver} to $port->{newver}", 175 | link => "$settings{rss_url_base}" . lc($port->{maintainer}) . '.html', 176 | guid => "$port->{cat}/$port->{name}/$port->{ver}/$port->{newver}", 177 | pubDate => $port->{discovered}, 178 | category => lc $port->{maintainer}, 179 | 180 | port => { 181 | freshports => "http://www.freshports.org/$port->{cat}/$port->{name}/", 182 | openprs => "http://www.freebsd.org/cgi/query-pr-summary.cgi?category=ports" 183 | . "&text=$port->{cat}%2F$port->{name}", 184 | version => $port->{ver}, 185 | newversion => $port->{newver}, 186 | newurl => $port->{newurl}, 187 | updated => $port->{updated}, 188 | checked => $port->{checked}, 189 | portname => $port->{name}, 190 | portcat => $port->{cat} 191 | } 192 | ); 193 | } 194 | 195 | print $rss->as_string; 196 | 197 | CGI::Cache::stop(); 198 | } 199 | 200 | 201 | #------------------------------------------------------------------------------ 202 | # Func: rssdate() 203 | # Desc: Format a date into RSS (RFC 2822) format. 204 | # 205 | # Args: $string - A date in database format; "now" if unset. 206 | # 207 | # Retn: $datestr - Valid date string. 208 | #------------------------------------------------------------------------------ 209 | 210 | sub rssdate 211 | { 212 | my ($string) = @_; 213 | 214 | my $dt; 215 | 216 | if ($string) { 217 | my ($year, $month, $day, $hours, $mins, $secs); 218 | 219 | if ($string =~ /^(\d\d\d\d)-(\d\d)-(\d\d) (\d\d):(\d\d):(\d\d)/) { 220 | $year = $1; $month = $2; $day = $3; 221 | $hours = $4; $mins = $5; $secs = $6; 222 | } 223 | 224 | $dt = DateTime->new( 225 | year => $year, month => $month, day => $day, 226 | hour => $hours, minute => $mins, second => $secs 227 | ); 228 | } else { 229 | $dt = DateTime->now; 230 | } 231 | 232 | return DateTime::Format::Mail->format_datetime($dt); 233 | } 234 | --------------------------------------------------------------------------------