package Win32::FileType;
$Win32::FileType::VERSION='0.02';
#######################################################################
#Perl Module for dealing with the file types
# This module creates an object oriented interface
# to updating and retrieving data about the file type
# mapping and file extensions associations.
#
# made by Jan Krynicky <Jenda@Krynicky.cz>
# uses Win32::Registry.pm patch !!!
#
#######################################################################

require Exporter;       #to export the constants to the main:: space
require DynaLoader;     # to dynalode the module.
@ISA= qw( Exporter DynaLoader );
@EXPORT_OK = qw(assoc unassoc);

use Win32::Registry;

$root=$HKCR;

sub assoc {
    my ($extension,$class) = @_;
    die "Ussage: assoc($extension,$classname) or assoc($extension,$class_object)\n"
    unless $extension && $class;
    if (ref $class eq 'Win32::FileType') {
        $class = $class->Name;
    }
    if ($extension !~ /^\./) { $extension = '.'.$extension; }
    my $key;
    $key = $root->Create($extension)
    and
    $key->SetValue('',&REG_SZ,$class);
}

sub Assoc {
    my $self=shift;
    die "Ussage: Assoc($extension)\n" unless $_[0];
    foreach (@_) {
        Win32::FileType::assoc($_,$self->Name)
    }
}

sub unassoc {
    my ($extension) = @_;
    die "Ussage: unassoc($extension)\n"
    unless $extension;
    if ($extension !~ /^\./) { $extension = '.'.$extension; }
    $root->DeleteKey($extension);
}

sub Open {
    my ($name,$machine) = @_;
    die "Ussage: Win32::FileType::Open($name [, \$computer])\n" unless $name;
    my $reg;
    my $root = $Win32::FileType::root;
    if ($machine) {
        $root = $HKCR->Connect($machine)
        or
        return undef;
    }
    if ($name =~ /^\./) {
        $reg=$root->Open($name)
        or
        return undef;

        my $tmp = $name;
        $name = $reg->GetValue('')
        or
        $name = $tmp;
    }
    $reg = $root->Open($name);
    return undef unless $reg;
    my $self={};
    bless $self;
    $self->{'reg'} = $reg;
    return $self;
}

sub new #('Name','Title');
{
    my ($class,$name,$title) = @_;
    die "Ussage: new Win32::FileType('name' [, 'title'] )\n" unless $name;
    my $reg=$root->Create($name);
    unless ($reg) {
        $Win32::FileType::Error="Cannot create registry key HKEY_CLASSES_ROOT\\$name\n";
        return undef;
    }
    if ($title or (! $title and ! $reg->GetValue('') and $title=$name)) {
        $reg->SetValue('',&REG_SZ,$title);
    }
    my $self={};
    bless $self,$class;
    $self->{'reg'}=$reg;
    return $self;
}

sub Name {
    my $name=$_[0]->{'reg'}->{'path'};
    $name =~ s/^.*\\//;
    return $name;
}

# this implements all other options
sub AUTOLOAD {
    my($name);
    ($name = $AUTOLOAD) =~ s/.*:://;
    $!=0;
    my ($self,$value) = @_;
#    die "Undefined subroutine &Win32::FileType::$name \n" ;
    my $reg=$self->{'reg'};
    if ($#_ == 1) {
        my $oldvalue;
        if (defined $value) {
            $reg=$reg->Create($name) or return undef;
            $oldvalue = $reg->GetValue('');
            $reg->SetValue('',&REG_SZ,$value);
        } else {
            my $reg2=$reg->Open($name);
            $oldvalue = $reg2->GetValue('');
            $reg->DeleteKey($name);
        }
        return wantarray ? ($oldvalue,$value) : 1;
    } else {
        $reg=$reg->Open($name);
        return $reg->GetValue('');
    }
}

sub Close {
    undef $_[0];
}

sub DESTROY {
}

sub Delete {
    my ($self,$i);
    foreach $self (@_) {
        if (ref $self eq 'Win32::FileType') {
            $root->DeleteKey($self->Name)
            and ++$i
            and undef $self;
        } else {
            $root->DeleteKey($self)
            and ++$i;
        }
    }
    return $i;
}

sub Icon {
    &DefaultIcon;
}

sub Action {
    my ($self,$name,$commandline,$title) = @_;
    die "Win32::FileType error - method Action\nUssage: Action( \$name [, \$commandline [,\$title] ] )\n"
    unless (defined $name);
    my $reg=$self->{'reg'};
    if (defined $commandline) {
     $reg=$reg->Create('Shell')
     and $reg=$reg->Create($name)
      or ($Win32::FileType::Error="Cannot create registry key HKCR\\".$self->Name."\\Shell\\$name",return(undef));
     $title=$name unless $title;
     $reg->SetValue('',&REG_SZ,$title);
     $reg=$reg->Create('Command')
      or ($Win32::FileType::Error="Cannot create registry key HKCR\\".$self->Name."\\Shell\\$name\\Command",return(undef));
     return ($reg->SetValue('',&REG_SZ,$commandline) ? 1 : undef);
    } else {
        my ($cmdreg,$title,$command);
        eval {$name=$reg->Open('Shell')->GetValue('')} unless $name;
        $name = 'Open' unless $name;
        (
         $cmdreg = $reg->Open("Shell\\$name")
         or
         $name = FindByName($reg->Open('Shell'),$name)
         and
         $cmdreg = $reg->Open("Shell\\$name")
        )
        and
        $title=$cmdreg->GetValue('')
        and
        $cmdreg=$cmdreg->Open('Command')
        and
        $command = $cmdreg->GetValue('')
        or return undef;
        return wantarray ? ($command,$title) : $command;
    }
}

sub DefaultAction {
    my $self = shift;
    if ($_[0]) {
        $self->{'reg'}->Open('shell')->SetValue('',&REG_SZ,$_[0]);
    } else {
        $self->{'reg'}->Open('shell')->GetValue('');
    }
}

sub FindByName {
    my ($reg, $name) = @_;
    return undef unless ref $reg;
    my $key;
    my @keys = $reg->GetKeys();
    my @vals;
    foreach $key (@keys) {
        push @vals, lc $reg->Open($key)->GetValue('');
    }
    my $i;
    $name = lc $name;
    for ($i=0;$i<=$#vals;$i++) {
        $vals[$i] eq $name and return $keys[$i];
    }
    $name =~ tr/&//d;
    for ($i=0;$i<=$#vals;$i++) {
        $vals[$i] =~ tr/&//d;
        $vals[$i] eq $name and return $keys[$i];
    }
    for ($i=0;$i<=$#vals;$i++) {
        $vals[$i] =~ /$name/ and return $keys[$i];
    }
    return undef;
}

sub Property {
    my ($self) = shift;
    if ($#_ == 0) {
        $self->{'reg'}->GetValue($_[0]);
    } elsif ($#_ == 1) {
        $self->{'reg'}->SetValue($_[0],&REG_SZ,$_[1]);
    } elsif ($#_ >= 2) {
        $self->{'reg'}->SetValue(@_);
    } else {
        die "Ussage: \$obj->Property( \$name [[, \$type], \$value])\n";
    }
}

sub Title {
    if ($_[1]) {
        Property($_[0],'',$_[1])
    } else {
        Property($_[0],'')
    }
}

sub ShellEx {
    my $self = shift;
    return $self->{'reg'}->Create('shellex');
}

sub DDEAction {
    my $self = shift;
    my ($name,$action,$title) = @_;
    die "Ussage: \$obj->DDEAction( \$name [, \\\%action [, \$title]])\n"
    unless (defined $name and (! $action or ref $action eq 'HASH'));
    my $reg=$self->{'reg'};
    if ($action) {
        die "Win32::FileType::DDEAction: the \\\%action must be in form
(
 '' => the DDE command,
 'Application' => the name of application that should process the command,
 'ifexec' => the executable to run if Application is not runing,
 'topic' => the topic (see the docs of DDE for the application)
)
"
        unless ($action->{''} and $action->{'Application'} and $action->{'ifexec'} and $action->{'topic'});
        $reg=$reg->Create("Shell\\$name") or goto error;
        $reg->SetValue('',&REG_SZ,$title) if $title;
        $reg=$reg->Create('ddeexec') or goto error;
        $reg->SetValue('',&REG_SZ,$action->{''}) or goto error;
        $reg->Create('Application')->SetValue('',&REG_SZ,$action->{'Application'}) or goto error;
        $reg->Create('ifexec')->SetValue('',&REG_SZ,$action->{'ifexec'}) or goto error;
        $reg->Create('topic')->SetValue('',&REG_SZ,$action->{'topic'}) or goto error;
        return 1;
    } else {
        eval {$name=$reg->Open('Shell')->GetValue('')} unless $name;
        $name = 'Open' unless $name;
        my $actreg=$reg;
        (
         $actreg=$reg->Open("Shell\\$name")
         or
         $name = FindByName($reg->Open('Shell'),$name)
         and
         $actreg = $reg->Open("Shell\\$name")
        )
        or goto error;
        $reg = $actreg;
        $reg=$reg->Open('ddeexec') or goto error;
        my %action;
        $action{''} = $reg->GetValue('') or goto error;
        eval {$action{'Application'} = $reg->Open('Application')->GetValue('')} or goto error;
        eval {$action{'ifexec'} = $reg->Open('ifexec')->GetValue('')};
        eval {$action{'topic'} = $reg->Open('topic')->GetValue('')} or goto error;
        return wantarray ? (\%action,$actreg->GetValue('')) : \%action;
    }
error:{
      return undef;
      }
}

sub Extensions {
    my $self = shift;
    my $name=lc($self->Name);
    my $reg;
    my @ext;
    foreach $key ($root->GetKeys()) {
        next unless $key =~ /^\./;
        $reg = $root->Open($key) or return undef;
        push @ext,$key if lc($reg->GetValue('')) eq $name
    }
    if ($#_ > -1) {$_[0] = \@ext}
    return wantarray ? @ext : $#ext+1;
}

sub Connect {
    if ( ref($_[0]) eq 'Win32::FileType') {
        my $self = $_[0];
        my $reg;
        if (lc ($_[1]) eq 'local') {
            $reg = $HKCR->Open($self->Name);# or return undef;
        } else {
            $reg = $self->{'reg'}->Connect($_[1]) or return undef;
        }
        return (bless {'reg' => $reg}, 'Win32::FileType');
    } elsif ($_[0] =~ /^local$/) {
        $root = $HKCR;
    } else {
        my $reg;
        $reg = $HKCR->Connect($_[0]) or return undef;
        $root = $reg;
    }
    return 1;
}

die "This module needs the Win32::Registry patch from http://Jenda.Krynicky.cz !!!\n"
 unless $Win32::Registry2::VERSION;
1;

__END__

=head1 NAME

 Win32::FileType - 0.02

This is a tiny module for modifying the file types and extension association.
Uses Win32::Registry patch ( http://Jenda.Krynicky.cz/ )!

!!! Be VERY carefull before you try any of the examples. I tried
to make them as harmless as posible, but still they may screw up your
computer. Generaly spoken, do NOT use this module unless you
realy know what are you doing. !!!


C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=head2 Non OO functions

=over 2

=item assoc

 assoc($extension, $type_name)
 assoc($extension, $Win32_FileType_object)

Associates an extension with a file type. The second argument may be either
a file type name or a Win32::FileType object.

The file type name is NOT the name you see
in the explorer under View\Details, but rather the name of the key specifying
the file type. That is you have to use assoc('.rtf','Word.RTF') instead of
assoc('.rtf','Rich Text Format').

The extension may, but doesn't have to start with a dot.

 Ex.
  use Win32::FileType qw(assoc);
  assoc('.htm','NetscapeMarkup');
  assoc('.html',Win32::FileType::Open('.htm'));

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item unassoc

 unassoc($extension)

Deletes the association of an extension with a file type.

=item Connect

 Win32::FileType::Connect($computer_name)
 Win32::FileType::Connect('local')

Connect to a remote registry. All newly created objects
will point to the remote machine. Returns 1 if successfull, undef otherwise.
The previously created objects remain connected to the machine they were.

You may call this function also as a method, in that case it reconnects only the object
and doesn't change the machine new objects will be pointing to.

 Ex.
  use Win32::FileType;
  $txt = Win32::FileType::Open('.txt');
  print "The type of .TXT files on your computer is \"",$txt->Title,"\".\n";

  $server= 'server_name';
  if (Win32::FileType::Connect($server)) {
    $rtxt = Win32::FileType::Open('.txt');
    print "The type of .TXT files on $server is \"",$rtxt->Title,"\".\n";
    $txt->Title($rtxt->Title);
    print "Now they are the same.\n"
  } else {
    print "Cannot connect to ${server}'s registry !\n"
  }

See also C<Connect_method>

=back

=head2 Methods and Constructors

C<Open>,
C<Connect_method>,
C<Close>,
C<Delete>,
C<Name>,
C<Title>

C<Assoc>,
C<Action>,
C<DDEAction>,
C<DefaultAction>,
C<Icon> or DefaultIcon,
C<Property>,
C<Extensions>

C<ShellEx>,
C<Anything>

=over 2

=item new

 new Win32::FileType( $file_type_name [ , $title ])

Create a new file type. The $file_type_name is the name of key that will
contain the file type specification and will be used in "assoc".
The $title is the text that will be displayed in the Explorer.

If you do not specify the $title, $file_type_name will be used as the title.

If the file type already exists it will be opened. In that case if you do not specify
the $title, it will not get changed.

 Ex.
  use Win32::FileType;
  $obj = new Win32::FileType('Perl_module', 'Perl module');
  $obj->Action('open','E:\Soft\PFE\PFE32.EXE "%1"','&Open')

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Open

 Win32::FileType::Open( $file_type_name [, $computer)
 Win32::FileType::Open( $extension [, $computer)

Opens a preexisting file type. You may specify either the file type name or
an extension (begining with a dot!).

If you specify a computer name, the function tries to connect the remote registry
on that computer.

 Ex.
  use Win32::FileType;
  $doc=Win32::FileType::Open('.doc');
  $perl=Win32::FileType::Open('Perl');

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Action

 $obj->Action( $action_name, $action [, $title])
 $command = $obj->Action($action_name)
 ($command,$title) = $obj->Action($action_name)

Sets or retrives the command and title of an action of a file type.
If you do not specify the title, the name of the action is used instead.

 $action_name = the name of the action, say 'open'
 $title = the text that will be displayed in the local menu for the file type,
          you may use & to specify the hot key, say '&Open'
 $action = the command line that has to be executed for the file type,
           use "%1" to specify where to place the name of the document
           to be opened. say "$ENV{windir}\\notepad.exe \"%1\""

If you use this method to get the info, you may use either
the action subkey name or the action title (the text in local menu) or
a regular expression matching the action title. If the $action_name
is an empty string, you will get info for the default action.

 Ex.
  use Win32::FileType;
  $txt = Win32::FileType::Open('.txt');
  $pm = new Win32::FileType('Perl_module','Perl module');
  $pm->Action('open',$txt->Action('open'));
  $pm->Assoc('.pm');
   #sets the open action for perl modules to the same as opening .txt files

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Assoc

 $obj->Assoc($extension)
 $obj->Assoc(@extensions)

Associate the extension(s) with this file type. The extension doesn't have to begin
with a dot.

 Ex.
  use Win32::FileType;
  $pm=Win32::FileType::Open('C_source');
  $pm->Assoc('.c','h','cpp','hpp','inc');

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Close

 $obj->Close

Closes the Win32::FileType object and releases the handle to registry.
It does exactly the same as "undef $obj;".

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Connect_method

 $remote_obj = $obj->Connect($computer_name)
 $remote_obj = $obj->Connect('local')

Connect to the same file type in on a remote computer.
Returns a new Win32::FileType object if successfull, undef otherwise.

This method doesn't change the machine new objects will be pointing to.

 Ex.
  use Win32::FileType;
  $txt = Win32::FileType::Open('.txt');
  print "The type of .TXT files on your computer is \"",$txt->Title,"\".\n";

  $server= 'server_name';
  if ($rtxt=$txt->Connect($server)) {
    print "The type of .TXT files on $server is \"",$rtxt->Title,"\".\n";
    $txt->Title($rtxt->Title);
    print "Now they are the same.\n"
  } else {
    print "Cannot connect to ${server}'s registry !\n"
  }

See also C<Connect>

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>


=item DDEAction

 $obj->DDEAction( $name ,\%action [, $title])
 $action = DDEAction( $name);
 ($action, $title) = DDEAction( $name);

Sets or retrieves the DDE command and title of an action of a file type.
If you do not specify the title, the name of the action is used instead.

If an application supports DDE, it's a very good idea to set up the
DDEAction (Shell\action\ddeexec subkey of the file type). This way
if you start a document when it's application is already running,
the computer doesn't have to launch a new instance of the program,
but rather may just tell the existing instance to open a document.

See the docs of the application to see if this is posible, and how should
the DDE command look like.

The \%action is a hash (associative array) of form

 (
  '' => the DDE command,
  'Application' => the name of application that should process the command,
  'ifexec' => the executable to run if Application is not runing,
  'topic' => the topic (see the docs of DDE for the application)
 )

 Ex.
  use Win32::FileType;
  $pfe_path='c:\Program files\PFE\PFE32.EXE';
  $txt = Win32::FileType::Open('.txt');
  $txt->Action('open',qq{"$pfe_path" "%1"}, '&Open');
  $txt->DDEAction('open',
   {'' => '[FileOpen("%1")]',
    'Application' => 'PFE32',
    'ifexec' => '"'.$pfe_path.'"',
    'topic' => 'Editor'
   }
  );

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Delete

 $obj->Delete
 Win32::FileType::Delete($obj1,$obj2,$obj3,...)

Deletes the file type from the registry (completely). You may delete several
types at once.

Returns the number of successfully deleted types.

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item DefaultAction

 $obj->DefaultAction('Run');
 $action = $obj->DefaultAction();

Retrieves or sets the name of the default action for the file type.


C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Extensions

 @extensions = $obj->Extensions();
 $obj->Extensions(\@extensions);

Searches for all extensions that are mapped to this file type.
May take some time to execute.

If evaluated in array context returns an array of the extensions.
If evaluated in scalar context returns the number of extensions found.
If the first argument is present it will be set to a reference to an array
containing the extensions.

 Ex.
  use Win32::FileType;
  $txt=Win32::FileType::Open('.txt');
  print $txt->Title,' (',$txt->Name,")\n (";
  print join(', ',$txt->Extensions);
  print ")\n";

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Icon or DefaultIcon

 $obj->Icon($path_to_the icon)
 $obj->Icon("$path_to_an_EXE,$index")
 $icon = $obj->Icon();

Sets or retrives the default icon for this file type. The path may point either
to an .ICO file or to an .EXE or .DLL file. In the later case you should provide
an index because an .EXE may contain several icons.

 Ex.
  use Win32::FileType;
  $doc = Win32::FileType::Open('.doc');
  print 'Current icon for ',$doc->Title,' (.DOC) files is ',$doc->Icon,"\n";
  ($exe,$idx) = split(/,/,$doc->Icon());
  $doc->Icon($exe .','. ($idx+1));  # use the next icon in the file
  print 'Current icon for ',$doc->Title,' (.DOC) files is ',$doc->Icon,"\n";

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Name

 $obj->Name

Returns the name of the file type. Since I do not know of an easy way
to rename a registry key and didn't write a Rename function in Win32::Registry2,
this property is read only. I will add Rename and Copy methods later.

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Property

 $obj->Property($name,$value)
 $obj->Property($name,$type,$value)
 $value = $obj->Property($name)

Retrieves or sets a value in the main key of the file type.
The $type is the registry value type as exported by Win32::Registry2.pm.
Default is REG_SZ. If you want to delete a property, specify undef as the value.

 Known properties:
  EditFlags : REG_DWORD : If you know what does that mean, tell me please
  IsShortcut : REG_SZ : Should it be displayed as a shortcut?
   The value is unimportant.
  NeverShowExt : REG_SZ : If the property is present, the explorer will never
   show the extension. The value is unimportant.
  AlwaysShowExt : REG_SZ : Oposit to NeverShowExt.
  Insertable : REG_SZ : ???
  URL Protocol : REG_EZ : ???
  Source Filter : REG_SZ : ???

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item Title

 $obj->Title($title);
 $title=$obj->Title;

Retrieves or sets the title of the file type.

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=item ShellEx

 $reg=$obj->ShellEx

Gives back a registry object opened to a ShellEx subkey of the file type.
See Win32::Registry for available functions. Since it is not so widely used
I was too lazy to provide any wrapper over this rarely used area.

=item Anything

 $obj->Anything($class_id);
 $value = $obj->Anything();

All other functions retrieve or set the default value of the subkey name_of_the_function
of the file type key. You may use it to set the CLSID, CurVer and other values.

C<Win32::FileType> | C<Non OO functions> |  C<Methods and Constructors>

=back

=head2 AUTHOR

Jan Krynicky <Jenda@McCann.cz>

=head2 COPYRIGHT

Copyright (c) 1997 Jan Krynicky <Jenda@McCann.cz>. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut