diff options
Diffstat (limited to 'scripts/namecheck.pl')
| -rwxr-xr-x | scripts/namecheck.pl | 233 |
1 files changed, 233 insertions, 0 deletions
diff --git a/scripts/namecheck.pl b/scripts/namecheck.pl new file mode 100755 index 0000000..2c04e93 --- /dev/null +++ b/scripts/namecheck.pl @@ -0,0 +1,233 @@ +#!/usr/bin/perl + +=head1 NAME + +namecheck - Check project names are not already taken. + +=head1 ABOUT + +This is a simple tool to automate the testing of project names at the most +common Open Source / Free Software hosting environments. + +Each new project requires a name, and those names are ideally unique. To come +up with names is hard, and testing to ensure they're not already in use is +time-consuming - unless you have a tool such as this one. + +=head1 CUSTOMIZATION + +The script, as is, contains a list of sites, and patterns, to test against. + +If those patterns aren't sufficient then you may create your own additions and +add them to the script. If you wish to have your own version of the patterns +you may save them into the file ~/.namecheckrc + +=head1 AUTHOR + +Steve +-- +http://www.steve.org.uk/ + +=head1 LICENSE + +Copyright (c) 2008 by Steve Kemp. All rights reserved. + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +# +# Good practise. +# +use strict; +use warnings; + +# +# A module for fetching webpages. +# +use LWP::UserAgent; + +# +# A module for finding the user home dir. +# +use File::HomeDir; + +# +# Get the name from the command line. +# +my $name = shift; +if (!defined($name)) { + print <<EOF; +Usage: $0 name +EOF + exit; +} + +# +# Get the patterns we're going to use for testing. +# +my @lines = loadPatterns(); + +# +# Assuming we have patterns use them. +# +testSites(@lines); + +# +# NOT REACHED. +# +exit; + +# +# Load the list of sites, and patterns, to test. +# +# By default these will come from the end of the script +# itself. A user may create the file ~/.namecheckrc with +# their own patterns if they prefer. +# + +sub loadPatterns { + my $file = File::HomeDir->my_home . "/.namecheckrc"; + my @lines = (); + + if (-e $file) { + open(FILE, "<", $file) + or die "Failed to open $file - $!"; + while (<FILE>) { + push(@lines, $_); + } + close(FILE); + } else { + while (<DATA>) { + push(@lines, $_); + } + } + + return (@lines); +} + +# +# Test the given name against the patterns we've loaded from our +# own script, or the users configuration file. +# + +sub testSites { + my (@patterns) = (@_); + + # + # Create and setup an agent for the downloading. + # + my $ua = LWP::UserAgent->new(); + $ua->agent('Mozilla/5.0'); + $ua->timeout(10); + $ua->env_proxy(); + + my $headers = HTTP::Headers->new(); + $headers->header('Accept' => '*/*'); + + foreach my $entry (@patterns) { + + # + # Skip blank lines, and comments. + # + chomp($entry); + next if ((!$entry) || (!length($entry))); + next if ($entry =~ /^#/); + + # + # Each line is an URL + a pattern, separated by a pipe. + # + my ($url, $pattern) = split(/\|/, $entry); + + # + # Strip leading/trailing spaces. + # + $pattern =~ s/^\s+//; + $pattern =~ s/\s+$//; + + # + # Interpolate the proposed project name in the string. + # + $url =~ s/\%s/$name/g if ($url =~ /\%s/); + + # + # Find the hostname we're downloading; just to show the user + # something is happening. + # + my $urlname = $url; + if ($urlname =~ /:\/\/([^\/]+)\//) { + $urlname = $1; + } + print sprintf "Testing %20s", $urlname; + + # + # Get the URL + # + my $request = HTTP::Request->new('GET', $url, $headers); + my $response = $ua->request($request); + + # + # If success we look at the returned text. + # + if ($response->is_success()) { + + # + # Get the page content - collapsing linefeeds. + # + my $c = $response->content(); + $c =~ s/[\r\n]//g; + + # + # Does the page have the pattern? + # + if ($c !~ /\Q$pattern\E/i) { + print " - In use\n"; + print "Aborting - name '$name' is currently used.\n"; + exit 0; + } else { + print " - Available\n"; + } + } else { + + # + # Otherwise we'll assume that 404 means that the + # project isn't taken. + # + my $c = $response->status_line(); + if ($c =~ /404/) { + print " - Available\n"; + } else { + + # + # Other errors we can't handle. + # + print "ERROR fetching $url - $c\n"; + } + } + + } + + # + # If we got here the name is free. + # + print "\n\nThe name '$name' doesn't appear to be in use.\n"; + exit 1; +} + +__DATA__ + +# +# The default patterns. +# +# If you want to customise them either do so here, or create the +# file ~/.namecheckrc with your own contents in the same format. +# +http://%s.tuxfamily.org/ | Not Found +http://alioth.debian.org/projects/%s | Software Map +http://freshmeat.net/projects/%s | We encounted an error +http://launchpad.net/%s | no page with this address +http://savannah.gnu.org/projects/%s | Invalid Group +http://sourceforge.net/projects/%s | Invalid Project +http://www.ohloh.net/projects/%s | Sorry, the page you are trying to view is not here +https://gna.org/projects/%s | Invalid Group +http://projects.apache.org/projects/%s.html | Not Found |