#!/usr/bin/perl
#perl-assoc 0.4
#by Christopher Monahan + help from perl monks
#
#This is free software, you can distribute it under the same
#terms as perl itself
#
###    a simple listing script for associations on a win32 system
###    like assoc for win 2000/XP - there is now some limited support 
###    for changing extensions but it's buggy, due to the way windows 
+behaves
###    to third party changing of the associations - that's purely cos
+metic though
###    however there is no creating or deleting of extensions: 
###    I think this might be a bug in  the TieRegistry.pm because it d
+oesn't 
###    seem to be able to create or delete key 'default' values
###
###could be used on win 9.x or others without assoc
#since 0.1 added options and help and rewrote to make clearer (thanks 
+ikegami)
#but for some reason looking up a specific extension has been broken..
+. at a loss here...
#since: 0.2 fixed bugs - albiet a little sloppily turns out looking up
+ specific extension
#was just me using = instead of ==, *slaps forhead*
#since: 0.25 added functionality for changing (not deleting or creatin
+g) a single association
#and listing more than one extension, also a foil to bail when it trie
+s to be executed in a 
#non win32 enviroment
#since: 0.3 bugfixes, code cleanup (/F switch now applies to all outpu
+t) applied deletion and creation
#code according to TieRegistry documentation, doesn't seem to work tho
+ugh

use warnings;
use strict;

unless ($^O =~ /Win32/){
die "This program requires a full Win32 enviroment" #note this doesn't
+ actually work
}
else{## not using indents for the master block because it's so huge an
+d boring
use Win32::TieRegistry (Delimiter => ":"); 
#note: for my foil to work I actually need to wrap 'use Win32::TieRegi
+stry' in some test for whether it exists or not

#declare my variables
my $ext;
my $RegHash;
my $class;
my $extcnt = 0;
my $warnalert;
my @conversion_vals;

#define subroutines --

sub scan { #for scanning arrays in general
    my $hunt = $_[0];
    my @founda = 0;
#    if (defined($hunt)){
        @founda = grep {/$hunt/} @_;
#    }
#    else{
#        $founda[$#_] = 1;
#    }
return $#founda;
}

sub help { # output help
    print<<EOF;
        perl-assoc 0.2
Displays file extension associations

-to see particular extensions:
     ASSOC .ext1 .ext2 .ext3... [options]
  .ext  Specifies the file extension to display
  
-to see all file extensions:
     ASSOC [options]
    will show a list of all known file associations
    
-to change a single extension association (creating/destroying associa
+tions not yet supported):
    ASSOC .ext=filetype
    filetype specifies what identifier this extension will use in the 
+registry and the interface 

available options are:     (case sensitive) 
     /W - warn about extensions not assigned with a filetype
     /F - format output with padding

eg: assoc .htm .pl /F
might give you:
.htm \t = \t FireFoxHTML
.pl \t = \t Perl
 
EOF
}

sub mainlist {#simple abstraction for problem with calling with no var
+iables
foreach my $ext (keys %{ $Registry->{"Classes:"} }) {
  next unless substr($ext, 0, 1) eq '.';

  my $RegHash = $Registry->{"Classes:$ext"};

  if (not exists $RegHash->{':'}) {
    print "\t --No filetype associated with $ext\n" if scan("/W", @_);
    next;
  }
  my $class = $RegHash->{":"};
  chop $ext;
  report ($ext, $class);
        } 
    }

sub report {# worksaving sub for reporting the findings
    if (scan ("/F", @ARGV)){
        print "$_[0] \t = \t $_[1] \n";
    }
    else {
        print "$_[0]=$_[1] \n";
    }
}

sub regattack {# sub for interacting with the registry
     if (substr ($_[1] ,0,1) eq '.'){
         $ext = $_[1];
        }
    if (defined $_[2]){
        $class = $_[2];
    }
    $RegHash = $Registry->{"Classes:$ext"};
    if ($_[0] eq "read"){
        return $RegHash->{":"}
    }
    elsif ($_[0] eq "write"){
        $RegHash->{":"} = $class;
    }
    elsif ($_[0] eq "delete"){
        delete $RegHash->{":"};#for some reason deleting or creating a
+ keys default value silently fails
    }
    else {return 0}
}

if(@ARGV){#-beginning of silly solution for calling it with no variabl
+es
    
#finding pleas for help
    if ($ARGV[0] =~ /\/\?|[Hh][Ee][Ll][Pp]/) { 
        help();
    }
#



#what to do when called with extension's (plural)
    elsif (substr ($ARGV[0] ,0,1) eq '.'){
        if ($ARGV[0] =~ /=$/){
            $ext = chop ($ARGV[0]);
            regattack("delete", $ext);#see regattack
        }
        elsif ($ARGV[0] =~ /=/){
            @conversion_vals = split (/=/, $ARGV[0]);
            if (@conversion_vals == 2){
                regattack ("write", $conversion_vals[0], $conversion_v
+als[1]);
                report($conversion_vals[0], $conversion_vals[1]);
            }
        }
        else{
            my $ARGmask = [@ARGV, "end"]; #because otherwise it'll com
+plain when it reaches the end
            while (substr ($ARGmask->[$extcnt] ,0,1) eq '.'){
                $ext = $ARGmask->[$extcnt];
                $RegHash = $Registry->{"Classes:$ext"};
                $warnalert = 0;

                 if (not exists $RegHash->{':'}) {
                   if (scan("/W", @ARGV)) {print "\t  --No filetype fo
+und associated with $ext\n"} 
                   else {
                       report ($ext, "?");
                       $warnalert = 1;
                     }
                 $warnalert = 1;
                 }
             unless($warnalert){
                 my $class = regattack ("read", $ext);
                 report($ext, $class)
            }
        $extcnt++
        }
    }
}



#

#and finally when all else fails just list 
    else {
        mainlist(@ARGV);
    }
}
else {#-end of silly solution for calling it with no varibles
    mainlist();
}


}
#end of master block

#to-do#
#
#my foil for executing outside of a Win32 enviroment doesn't seem to b
+e working, find out some way of getting that to work
#need to find out why I can't seem to create a default value when one 
+doesn't already exist
#since it'll have to be renamed to work on NT, add a sub for pinpointi
+ng the name used to run it for use in the help sub
#abstract common functions as it gets larger, can't rely on copy and p
+aste
# possibly find a solution for the issue of the windows shell not upda
+ting to reflect changes to registry

##in future possibly extending it to advanced functions for extensions
+ (why settle for what MS has given you?)
##eg: loading and saving sets of extension modification, advanced shel
+l functions, wildcard use