#!/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
In reply to perl-assoc 0.4 by Maze
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |