Win32::SearchPDIC

そういうフィルタを書こうと思って、下準備につくったもの。Win32でPDIC（と、実質英辞郎）が入っている人限定という、きわめてユーザの限られたブツですが、それはそれ。現状 Win32::DDE::Client が二度目の会話をうまくこなしてくれないようなので、事前にPDICを最小化の状態で起動しておくのが吉。Win32::GUIなりWin32::APIなりを使えばDDEで会話を始める前に最小化の状態でアプリを起動することもできるんですが……二度目以降の実行でウインドウを戻さず最小化のままにしておくのって、どうするんでしたっけ？(汗

追記：Win32::DDE(::Client)は現在CPANに入っていません。http://www.bribes.org/perl/ppmdir.html あたりからppmインストするのが吉です。

package Win32::SearchPDIC;
{
  use strict;
  use warnings;
  use Carp;

  our $VERSION = '0.01';

  use Win32::DDE::Client;

  sub connect {
    my ($class, $args) = @_;

    my $server = $args->{server} || 'PDICW';
    my $wait   = $args->{wait}   || 1;

    my ($process, $window);
    if ($args->{force}) {
#     $process = _create_process();
      $window  = _create_window();
      sleep $wait;
    }

    # XXX: currently PDICW must be ready before DDE conversation.
    # Tried several approaches but failed to prepare PDIC on the fly.
    # (Some failed to stay minimized; others failed to talk properly.)

    my $pdic = Win32::DDE::Client->new($server, 'Dictionary');

    croak 'failed to connect PDIC' if !$pdic || $pdic->Error;

    bless {
      pdic => $pdic,
      process => $process,
      window => $window
    }, $class;
  }

  sub open_dict {
    my $self = shift;

    my $pdic = $self->{pdic};

    # XXX: Win32::DDE::Callback complains on the second DDE try.
    # XXX: should accept Open options?

    eval { $pdic->Poke('Open', ''); };
    $self->disconnect("failed to open dictionary: $@") if $@;

    eval { $pdic->Poke('Config', 't3'); };
    $self->disconnect("failed to configure dictionary: $@") if $@;

    eval { $pdic->Poke('Format', '$w ($l)\n$j'); };
    $self->disconnect("failed to configure dictionary: $@") if $@;

    $self->{opened} = 1;
  }

  sub find {
    my ($self, $word) = @_;

    my $pdic = $self->{pdic} or croak 'not available';

    if ( $pdic->Poke('Find', $word) ) {
      my $value = $pdic->Request('Find');

      # XXX: needs some filtering (e.g. for 'level' param)?

      return $value;
    }
    return;
  }

  sub _find_pdic {
    my $path;

    eval {
      use Win32API::Registry qw( :ALL );

      my $hKey;
      RegOpenKeyEx( HKEY_LOCAL_MACHINE, "SOFTWARE\\ReliefOffice\\CurrentVersion\\App Paths\\PDICW32.EXE", 0, KEY_READ, $hKey )
        or croak "failed to locate PDICW32.exe".regLastError();

      my $type;
      RegQueryValueEx( $hKey, "", [], $type, $path, [] )
        or confess "failed to read PDICW32.exe info".regLastError();

      RegCloseKey( $hKey )
        or confess "failed to close Registry".regLastError();

    };
    croak $@ if $@;
    return $path;
  }

  sub _create_process {
    my $process;

    my $pdic_path = _find_pdic();

    eval {
      use Win32::Process;
      use Win32;
      Win32::Process::Create(
        $process, $pdic_path, '', 0, CREATE_NO_WINDOW, '.'
      ) or croak Win32::FormatMessage( Win32::GetLastError() );
    };

    $process;
  }

  sub _create_window {
    my $pdic_path = _find_pdic();

    eval {
      use Win32::FileOp qw(ShellExecute SW_HIDE SW_MINIMIZE SW_SHOWMINIMIZED);
      use Win32;

      ShellExecute 'open' => $pdic_path, { show => SW_SHOWMINIMIZED };
      croak Win32::FormatMessage(Win32::GetLastError()) if $^E;
    };
    croak $@ if $@;

    return 1;
  }

  sub _create_window0 {
    my $window;

    my $pdic_path = _find_pdic();

    eval {
      use Win32::GUI;

      $window = Win32::GUI::Window->new;
      my $SW_MINIMIZE = 6;
      my $r = $window->ShellExecute('open', $pdic_path, '', '.', $SW_MINIMIZE);
      croak "failed to open window: $r" unless $r > 32;
    };
    croak $@ if $@;

    $window;
  }

  sub _kill_process {
    my $process = shift;
    eval {
      my $exitcode;
      $process->GetExitCode($exitcode);
      $process->Kill($exitcode);
    };
    croak $@ if $@;
  }

  sub disconnect {
    my ($self, $error) = @_;

    warn $error if $error;

    if ($self->{pdic}) {
      $self->{pdic}->Poke('Close', '') if $self->{opened};
      $self->{pdic}->Disconnect;
    }
    _kill_process($self->{process})    if $self->{process};
  }

  sub DESTROY { $_[0]->disconnect; }
}

1;
__END__

=head1 NAME

Win32::SearchPDIC - Search PDIC via DDE

=head1 SYNOPSIS

  use Win32::SearchPDIC;

  my $pdic = Win32::SearchPDIC->connect({ force => 1 });
  $pdic->open_dict;

  my $meanings = $pdic->find("test");

  $pdic->disconnect;

=head1 SEE ALSO

L<http://homepage3.nifty.com/TaN/> for PDIC (Personal Dictionary).

L<Win32::DDE::Client>

=head1 AUTHOR

Kenichi Ishigaki

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2006 by Kenichi Ishigaki

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut