#!/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
-
Are you posting in the right place? Check out Where do I post X? to know for sure.
-
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big>
<blockquote> <br /> <dd>
<dl> <dt> <em> <font>
<h1> <h2> <h3> <h4>
<h5> <h6> <hr /> <i>
<li> <nbsp> <ol> <p>
<small> <strike> <strong>
<sub> <sup> <table>
<td> <th> <tr> <tt>
<u> <ul>
-
Snippets of code should be wrapped in
<code> tags not
<pre> tags. In fact, <pre>
tags should generally be avoided. If they must
be used, extreme care should be
taken to ensure that their contents do not
have long lines (<70 chars), in order to prevent
horizontal scrolling (and possible janitor
intervention).
-
Want more info? How to link
or How to display code and escape characters
are good places to start.