#!/usr/bin/perl -w

=head1 NAME

namecheck - Check project names are not already taken.

=cut

=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.

=cut

=head1 HOMEPAGE

  The most recent version of this script may be found here:

    http://mybin.repository.steve.org.uk/?raw-file/tip/namecheck

=cut

=head1 AUTHOR

 Steve
 --
 http://www.steve.org.uk/

=cut

=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.
The LICENSE file contains the full text of the license.

=cut



#
#  Good practise.
#
use strict;
use warnings;


#
#  A module for fetching webpages.
#
use LWP::UserAgent;



#
#  Get the name from the command line.
#
my $name = shift;
if ( !defined($name) )
{
    print <<EOF;
Usage: $0 name
EOF
    exit;
}



#
# Create and setup an agent for the downloading.
#
my $ua = LWP::UserAgent->new();
$ua->agent('Mozilla/5.0');
$ua->timeout(10);
$ua->env_proxy();



#
#  Now test each pattern we know about
#
while (<DATA>)
{

    #
    #  Skip blank lines, and comments.
    #
    chomp;
    next if ( ( !$_ ) || ( !length($_) ) );
    next if ( $_ =~ /^#/ );


    #
    #  Each line is an URL + a pattern, separated by a pipe.
    #
    my ( $url, $pattern ) = split(/\|/);

    #
    #  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 $name = $url;
    if ( $name =~ /:\/\/([^\/]+)\// )
    {
        $name = $1;
    }
    print sprintf "Testing %20s", $name;


    #
    #  Get the URL
    #
    my $response = $ua->get($url);

    #
    #  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 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\n$name is currently not claimed\n";
exit 1;



__DATA__

#
#  The patterns
#
http://%s.tuxfamily.org/             | Not Found
http://alioth.debian.org/projects/%s | Invalid Project
http://code.google.com/p/%s          | Not Found
http://developer.berlios.de/projects/%s | Invalid Project
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 Groupx