Beefy Boxes and Bandwidth Generously Provided by pair Networks
Welcome to the Monastery
 
PerlMonks  

perl-assoc 0.4

by Maze (Sexton)
on Aug 16, 2006 at 22:17 UTC ( #567770=sourcecode: print w/replies, xml ) Need Help??
Category: Win32 stuff
Author/Contact Info Chris Monahan aka Maze
ForeverWatcher@googlemail.com
Description: 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
#!/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
Replies are listed 'Best First'.
Re: perl-assoc 0.2
by GrandFather (Sage) on Aug 16, 2006 at 22:46 UTC

    With no command line parameters I get:

    Use of uninitialized value in string eq at perl-assoc.pl line 64.

    three times interspersed with the expected output. All the ARGV tests should be wrapped in a if (@ARGV) {...} block. The current default case else then belongs to the new outer if block (do the else if there are no command line args).

    Your example uses /f, but /F is required for formatting.

    It would be worth running your code through perltidy - the indentation is rather arbitary in places.

    unless($warnalert = 1) is an error. It should probably be unless($warnalert)

    chop $ext; is an error. It is not required at all. There can be no line ends in command line arguments in Windows.

    print "$ext=$class \n" would be better as print "$ext = $class\n".


    DWIM is Perl's answer to Gödel
Re: perl-assoc 0.3
by Maze (Sexton) on Aug 19, 2006 at 22:57 UTC

    there seems to be some strange error which is present in both the assoc 0.3 and the 0.4 which i'm working on

    when invoked with extensions as an argument it says that the variable $extcnt is undefined, and says:

    Use of uninitialized value in substr at E:\Workspaces\Perl\asocx 0.3.p +l line 146

    when all that happens there is '$extcnt++' in the scope of the while loop...

    needless to say worse things happen when I try to run the 0.4 version, I don't understand how .htm can equal a SH File when SH file can't be found anywhere near .htm in the registry.

    Update
    solved the problem with the undefined variables, by adding = 0 but I still get the strange substr error
Re: perl-assoc 0.4
by Maze (Sexton) on Sep 30, 2006 at 17:10 UTC

    this 0.4 has been on sourceforge for quite a while, I haven't edited asocx for quite a while - mainly becuase I've got my linux box working and the problems my mum was having with win ME *shudder* are no longer relevent

    the main thing that's on my mind is adding this functionality to a Module, now that I know how to do it, although I think I am to understand that there already is a Win32 filetype module, no?

    maybe it would be worth creating a arbritary registry editing tool for the command line, that would be useful for recovering from wine virual desktop missizing - assuming that it works in wine
Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://567770]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others scrutinizing the Monastery: (6)
As of 2020-09-21 08:28 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    If at first I donít succeed, I Ö










    Results (125 votes). Check out past polls.

    Notices?