scripts/namecheck.pl

   1 #!/usr/bin/perl -w
   2
   3 =head1 NAME
   4
   5 namecheck - Check project names are not already taken.
   6
   7 =head1 ABOUT
   8
   9 This is a simple tool to automate the testing of project names at the most
  10 common Open Source / Free Software hosting environments.
  11
  12 Each new project requires a name, and those names are ideally unique.  To come
  13 up with names is hard, and testing to ensure they're not already in use is
  14 time-consuming - unless you have a tool such as this one.
  15
  16 =head1 CUSTOMIZATION
  17
  18 The script, as-is, contains a list of sites, and patterns, to test against.
  19
  20 If those patterns aren't sufficient then you may create your own additions and
  21 add them to the script.  If you wish to have your own version of the patterns
  22 you may save them into the file ~/.namecheckrc
  23
  24 =head1 HOMEPAGE
  25
  26 The most recent version of this script may be found here:
  27
  28 http://mybin.repository.steve.org.uk/?raw-file/tip/namecheck
  29
  30 =head1 AUTHOR
  31
  32 Steve
  33 --
  34 http://www.steve.org.uk/
  35
  36 =head1 LICENSE
  37
  38 Copyright (c) 2008 by Steve Kemp.  All rights reserved.
  39
  40 This module is free software; you can redistribute it and/or modify it under
  41 the same terms as Perl itself.
  42
  43 =cut
  44
  45
  46
  47 #
  48 #  Good practise.
  49 #
  50 use strict;
  51 use warnings;
  52
  53
  54 #
  55 #  A module for fetching webpages.
  56 #
  57 use LWP::UserAgent;
  58
  59
  60
  61 #
  62 #  Get the name from the command line.
  63 #
  64 my $name = shift;
  65 if ( !defined($name) )
  66 {
  67     print <<EOF;
  68 Usage: $0 name
  69 EOF
  70     exit;
  71 }
  72
  73
  74
  75 #
  76 #  Get the patterns we're going to use for testing.
  77 #
  78 my @lines = loadPatterns();
  79
  80
  81 #
  82 #  Assuming we have patterns use them.
  83 #
  84 testSites(@lines);
  85
  86
  87 #
  88 #  NOT REACHED.
  89 #
  90 exit;
  91
  92
  93
  94 #
  95 #  Load the list of sites, and patterns, to test.
  96 #
  97 #  By default these will come from the end of the script
  98 # itself.  A user may create the file ~/.namecheckrc with
  99 # their own patterns if they prefer.
 100 #
 101
 102 sub loadPatterns
 103 {
 104     my $file  = $ENV{ 'HOME' } . "/.namecheckrc";
 105     my @lines = ();
 106
 107     if ( -e $file )
 108     {
 109         open( FILE, "<", $file )
 110           or die "Failed to open $file - $!";
 111         while (<FILE>)
 112         {
 113             push( @lines, $_ );
 114         }
 115         close(FILE);
 116     }
 117     else
 118     {
 119         while (<DATA>)
 120         {
 121             push( @lines, $_ );
 122         }
 123     }
 124
 125     return (@lines);
 126 }
 127
 128 #
 129 #  Test the given name against the patterns we've loaded from our
 130 # own script, or the users configuration file.
 131 #
 132
 133 sub testSites
 134 {
 135     my (@patterns) = (@_);
 136
 137     #
 138     # Create and setup an agent for the downloading.
 139     #
 140     my $ua = LWP::UserAgent->new();
 141     $ua->agent('Mozilla/5.0');
 142     $ua->timeout(10);
 143     $ua->env_proxy();
 144
 145
 146     foreach my $entry (@patterns)
 147     {
 148
 149         #
 150         #  Skip blank lines, and comments.
 151         #
 152         chomp($entry);
 153         next if ( ( !$entry ) || ( !length($entry) ) );
 154         next if ( $entry =~ /^#/ );
 155
 156
 157         #
 158         #  Each line is an URL + a pattern, separated by a pipe.
 159         #
 160         my ( $url, $pattern ) = split( /\|/, $entry );
 161
 162         #
 163         #  Strip leading/trailing spaces.
 164         #
 165         $pattern =~ s/^\s+//;
 166         $pattern =~ s/\s+$//;
 167
 168
 169         #
 170         #  Interpolate the proposed project name in the string.
 171         #
 172         $url =~ s/\%s/$name/g if ( $url =~ /\%s/ );
 173
 174         #
 175         #  Find the hostname we're downloading; just to show the user
 176         # something is happening.
 177         #
 178         my $urlname = $url;
 179         if ( $urlname =~ /:\/\/([^\/]+)\// )
 180         {
 181             $urlname = $1;
 182         }
 183         print sprintf "Testing %20s", $urlname;
 184
 185
 186         #
 187         #  Get the URL
 188         #
 189         my $response = $ua->get($url);
 190
 191         #
 192         #  If success we look at the returned text.
 193         #
 194         if ( $response->is_success() )
 195         {
 196
 197             #
 198             #  Get the page content - collapsing linefeeds.
 199             #
 200             my $c = $response->content();
 201             $c =~ s/[\r\n]//g;
 202
 203             #
 204             #  Does the page have the pattern?
 205             #
 206             if ( $c !~ /\Q$pattern\E/i )
 207             {
 208                 print " - In use\n";
 209                 print "Aborting - name '$name' is currently used.\n";
 210                 exit 0;
 211             }
 212             else
 213             {
 214                 print " - Available\n";
 215             }
 216         }
 217         else
 218         {
 219
 220             #
 221             #  Otherwise we'll assume that 404 means that the
 222             # project isn't taken.
 223             #
 224             my $c = $response->status_line();
 225             if ( $c =~ /404/ )
 226             {
 227                 print " - Available\n";
 228             }
 229             else
 230             {
 231
 232                 #
 233                 #  Other errors we can't handle.
 234                 #
 235                 print "ERROR fetching $url - $c\n";
 236             }
 237         }
 238
 239     }
 240
 241
 242     #
 243     #  If we got here the name is free.
 244     #
 245     print "\n\nThe name '$name' doesn't appear to be in use.\n";
 246     exit 1;
 247 }
 248
 249
 250 __DATA__
 251
 252 #
 253 #  The default patterns.
 254 #
 255 #  If you want to customise them either do so here, or create the
 256 # file ~/.namecheckrc with your own contents in the same format.
 257 #
 258 http://%s.tuxfamily.org/             | Not Found
 259 http://alioth.debian.org/projects/%s | Invalid Project
 260 http://developer.berlios.de/projects/%s | Invalid Project
 261 http://freshmeat.net/projects/%s     | We encounted an error
 262 http://launchpad.net/%s              | no page with this address
 263 http://savannah.gnu.org/projects/%s  | Invalid Group
 264 http://sourceforge.net/projects/%s   | Invalid Project
 265 http://www.ohloh.net/projects/%s     | Sorry, the page you are trying to view is not here
 266 https://gna.org/projects/%s          | Invalid Group
 267 http://code.google.com/p/%s          | Not Found