#!/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 cosmetic though
###	however there is no creating or deleting of extensions: 
###	I think this might be a bug in  the TieRegistry.pm because it doesn'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 creating) a single association
#and listing more than one extension, also a foil to bail when it tries to be executed in a 
#non win32 enviroment
#since: 0.3 bugfixes, code cleanup (/F switch now applies to all output) applied deletion and creation
#code according to TieRegistry documentation, doesn't seem to work though

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 and boring
use Win32::TieRegistry (Delimiter => ":"); 
#note: for my foil to work I actually need to wrap 'use Win32::TieRegistry' 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 associations 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 variables
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 variables
	
#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_vals[1]);
				report($conversion_vals[0], $conversion_vals[1]);
			}
		}
		else{
			my $ARGmask = [@ARGV, "end"]; #because otherwise it'll complain 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 found 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 be 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 pinpointing 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 paste
# possibly find a solution for the issue of the windows shell not updating 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 shell functions, wildcard use