Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Initial commit (SVN history has not been carried over)

  • Loading branch information...
commit 6d2616324b069289af8bde9e4d452283e0cfdf39 0 parents
@sanko authored
2  .gitignore
@@ -0,0 +1,2 @@
+Makefile.win
+perl/*
39 CHANGES.txt
@@ -0,0 +1,39 @@
+Version 0.9.600 (29 Nov 2008)
+http://sankorobinson.com/
+
+ Internal changes:
+ - (undocumented) perl4mIRC.pm is now external for hacking, easy updates
+ - (undocumented) perl4mIRC.dll retains basic functionality (perl eval, etc.) without Win32::API (print to mIRC window, mIRC exec, eval, etc.)
+ - (undocumented) Building should be a little easier
+
+Version 0.9.501 (29 Jan 2008)
+http://sankorobinson.com/
+
+ Internal changes:
+ - Fix magic object in eval_embed
+ - Fix line directives in eval_embed and eval_string
+ - Fix chopped evaluate and execute commands
+ - Makeshift fix for strange race condition in eval and exec commands that
+ would lead to crash
+
+Version 0.9.500 (29 Jan 2008)
+http://sankorobinson.com/
+
+ General/Interface changes:
+ - FIX: New message and auto-unload (rather than mysterious death) when
+ Win32::API is not installed.
+
+ Internal changes:
+ - Catches missing Win32::API requirement w/o ruining the interpreter
+ by running an eval_sv.
+
+Version 0.9.008 (23 Nov 2007)
+http://sankorobinson.com/?p=1195847788.76563
+
+ General/Interface changes:
+ - First public release
+
+ Internal changes:
+ - dropped custom XS module in favor of Win32::API with DLL calls.
+
+$Id: CHANGES.txt 4 2008-12-05 05:12:08Z sanko@cpan.org $
202 LICENSE.txt
@@ -0,0 +1,202 @@
+ The Artistic License 2.0
+
+ Copyright (c) 2000-2006, The Perl Foundation.
+
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+Preamble
+
+This license establishes the terms under which a given free software
+Package may be copied, modified, distributed, and/or redistributed.
+The intent is that the Copyright Holder maintains some artistic
+control over the development of that Package while still keeping the
+Package available as open source and free software.
+
+You are always permitted to make arrangements wholly outside of this
+license directly with the Copyright Holder of a given Package. If the
+terms of this license do not permit the full use that you propose to
+make of the Package, you should contact the Copyright Holder and seek
+a different licensing arrangement.
+
+Definitions
+
+ "Copyright Holder" means the individual(s) or organization(s)
+ named in the copyright notice for the entire Package.
+
+ "Contributor" means any party that has contributed code or other
+ material to the Package, in accordance with the Copyright Holder's
+ procedures.
+
+ "You" and "your" means any person who would like to copy,
+ distribute, or modify the Package.
+
+ "Package" means the collection of files distributed by the
+ Copyright Holder, and derivatives of that collection and/or of
+ those files. A given Package may consist of either the Standard
+ Version, or a Modified Version.
+
+ "Distribute" means providing a copy of the Package or making it
+ accessible to anyone else, or in the case of a company or
+ organization, to others outside of your company or organization.
+
+ "Distributor Fee" means any fee that you charge for Distributing
+ this Package or providing support for this Package to another
+ party. It does not mean licensing fees.
+
+ "Standard Version" refers to the Package if it has not been
+ modified, or has been modified only in ways explicitly requested
+ by the Copyright Holder.
+
+ "Modified Version" means the Package, if it has been changed, and
+ such changes were not explicitly requested by the Copyright
+ Holder.
+
+ "Original License" means this Artistic License as Distributed with
+ the Standard Version of the Package, in its current version or as
+ it may be modified by The Perl Foundation in the future.
+
+ "Source" form means the source code, documentation source, and
+ configuration files for the Package.
+
+ "Compiled" form means the compiled bytecode, object code, binary,
+ or any other form resulting from mechanical transformation or
+ translation of the Source form.
+
+
+Permission for Use and Modification Without Distribution
+
+(1) You are permitted to use the Standard Version and create and use
+Modified Versions for any purpose without restriction, provided that
+you do not Distribute the Modified Version.
+
+
+Permissions for Redistribution of the Standard Version
+
+(2) You may Distribute verbatim copies of the Source form of the
+Standard Version of this Package in any medium without restriction,
+either gratis or for a Distributor Fee, provided that you duplicate
+all of the original copyright notices and associated disclaimers. At
+your discretion, such verbatim copies may or may not include a
+Compiled form of the Package.
+
+(3) You may apply any bug fixes, portability changes, and other
+modifications made available from the Copyright Holder. The resulting
+Package will still be considered the Standard Version, and as such
+will be subject to the Original License.
+
+
+Distribution of Modified Versions of the Package as Source
+
+(4) You may Distribute your Modified Version as Source (either gratis
+or for a Distributor Fee, and with or without a Compiled form of the
+Modified Version) provided that you clearly document how it differs
+from the Standard Version, including, but not limited to, documenting
+any non-standard features, executables, or modules, and provided that
+you do at least ONE of the following:
+
+ (a) make the Modified Version available to the Copyright Holder
+ of the Standard Version, under the Original License, so that the
+ Copyright Holder may include your modifications in the Standard
+ Version.
+
+ (b) ensure that installation of your Modified Version does not
+ prevent the user installing or running the Standard Version. In
+ addition, the Modified Version must bear a name that is different
+ from the name of the Standard Version.
+
+ (c) allow anyone who receives a copy of the Modified Version to
+ make the Source form of the Modified Version available to others
+ under
+
+ (i) the Original License or
+
+ (ii) a license that permits the licensee to freely copy,
+ modify and redistribute the Modified Version using the same
+ licensing terms that apply to the copy that the licensee
+ received, and requires that the Source form of the Modified
+ Version, and of any works derived from it, be made freely
+ available in that license fees are prohibited but Distributor
+ Fees are allowed.
+
+
+Distribution of Compiled Forms of the Standard Version
+or Modified Versions without the Source
+
+(5) You may Distribute Compiled forms of the Standard Version without
+the Source, provided that you include complete instructions on how to
+get the Source of the Standard Version. Such instructions must be
+valid at the time of your distribution. If these instructions, at any
+time while you are carrying out such distribution, become invalid, you
+must provide new instructions on demand or cease further distribution.
+If you provide valid instructions or cease distribution within thirty
+days after you become aware that the instructions are invalid, then
+you do not forfeit any of your rights under this license.
+
+(6) You may Distribute a Modified Version in Compiled form without
+the Source, provided that you comply with Section 4 with respect to
+the Source of the Modified Version.
+
+
+Aggregating or Linking the Package
+
+(7) You may aggregate the Package (either the Standard Version or
+Modified Version) with other packages and Distribute the resulting
+aggregation provided that you do not charge a licensing fee for the
+Package. Distributor Fees are permitted, and licensing fees for other
+components in the aggregation are permitted. The terms of this license
+apply to the use and Distribution of the Standard or Modified Versions
+as included in the aggregation.
+
+(8) You are permitted to link Modified and Standard Versions with
+other works, to embed the Package in a larger work of your own, or to
+build stand-alone binary or bytecode versions of applications that
+include the Package, and Distribute the result without restriction,
+provided the result does not expose a direct interface to the Package.
+
+
+Items That are Not Considered Part of a Modified Version
+
+(9) Works (including, but not limited to, modules and scripts) that
+merely extend or make use of the Package, do not, by themselves, cause
+the Package to be a Modified Version. In addition, such works are not
+considered parts of the Package itself, and are not subject to the
+terms of this license.
+
+
+General Provisions
+
+(10) Any use, modification, and distribution of the Standard or
+Modified Versions is governed by this Artistic License. By using,
+modifying or distributing the Package, you accept this license. Do not
+use, modify, or distribute the Package, if you do not accept this
+license.
+
+(11) If your Modified Version has been derived from a Modified
+Version made by someone other than you, you are nevertheless required
+to ensure that your Modified Version complies with the requirements of
+this license.
+
+(12) This license does not grant you the right to use any trademark,
+service mark, tradename, or logo of the Copyright Holder.
+
+(13) This license includes the non-exclusive, worldwide,
+free-of-charge patent license to make, have made, use, offer to sell,
+sell, import and otherwise transfer the Package with respect to any
+patent claims licensable by the Copyright Holder that are necessarily
+infringed by the Package. If you institute patent litigation
+(including a cross-claim or counterclaim) against any party alleging
+that the Package constitutes direct or contributory patent
+infringement, then this Artistic License to you shall terminate on the
+date that such litigation is filed.
+
+(14) Disclaimer of Warranty:
+THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS
+IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED
+WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR
+NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL
+LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL
+BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
125 README.txt
@@ -0,0 +1,125 @@
+AUTHOR & WEBSITE
+
+ The software provided was written by Sanko Robinson.
+
+ Please visit http://sanko.googlecode.com/ for updates.
+
+DESCRIPTION
+
+ Inspired by the TCL4mIRC[1] and Python4mIRC[2] projects, Perl4mIRC is
+ a DLL for the mIRC chat client[3] that allows a scripter to execute Perl
+ programs from mIRC's edit box and in mIRC's msl script files.
+
+REQUIREMENTS
+
+ any version of mIRC (built on v6.21)
+ Perl (built on v5.10.0)
+ Win32::API
+
+INSTALLATION
+
+ To install this script and DLL, it is recommended (but not necessary)
+ to copy the files in this package into a directory within mIRC's
+ installation directory. At that point you can type
+
+ /load -rs C:\path\to\perl.mrc
+
+ To load the script file. This will run /perl_hello_world to test the
+ installation. You should see "Hello world" if the test ran successfully.
+
+ If you receive an error about Win32::API, type the following at the
+ command line:
+
+ ppm install http://www.bribes.org/perl/ppm/Win32-API.ppd
+
+USAGE & EXAMPLES
+
+ Use /perl <perl syntax> to execute Perl code.
+
+ Several examples are in perl.mrc, I'll explain the nifty bits...
+
+ Midway through perl.mirc, you come upon the following alias...
+
+ ; Shows how to pass data to and from Perl
+ alias perl_strlen {
+ set %data $1-
+ perl mIRC(q[//echo len:] . length(mIRC->{'data'}));
+ unset %data
+ }
+
+ We use the pseudo-hash mIRC to get and set variables inside mIRC and the
+ coderef mIRC executes msl inline. You could toss down a banana peel with:
+
+ /perl use strict; mIRC->{here} = q[TEST];
+
+ No, it won't die, but it breaks my little fake hash/coderef thing. So,
+ don't.
+
+ Yes, this is very very misleading in code and a very very bad idea in
+ general practice but until I find a solution as fast and light as this,
+ I'll make use of it. See perldoc perlref to investigate on your own.
+ ...or contact me and I'll do my best to fill you in.
+
+ Near the bottom of perl.mrc, you'll find this...
+
+ ; REAL inline C :D
+ ; You asked for it, so here it is...
+ ; Requires you to install this script without spaces in the path
+ alias inlinec {
+ if $($has_perl,2) {
+ use Inline C => q[
+ void greet() {
+ printf("Hello, world\n");
+ }
+ ];
+ greet;
+ }
+ }
+
+ Yep, C. Inside mIRC. This is made possible with the very crafty
+ Inline::C[4] module available on CPAN[5], you'll find several Inline
+ modules that evaluate assembler[6], Java[7], Lua[8], Python[9], Ruby[10],
+ Tcl[11], and several other[12] languages. Please note, several of these
+ Inline:: modules (Inline::C for sure) require you to install the script
+ to a path WITHOUT spaces. And PLEASE read the docs for these before
+ jumping into it... You'll save yourself some time and effort.
+
+RELEASE INFORMATION
+
+ See CHANGES.txt
+
+ For future updates, check http://sanko.googlecode.com/
+
+LICENSES
+
+ Perl4mIRC is released under the Perl/Artistic license. See LICENSE.txt
+ for a very legalese definition of what I'm talking about. To understand
+ what rights I claim to this code and how to handle derivative work, see
+ the Artistic 2.0 Notes[13].
+
+ All textual content is provided under the Creative Commons Attribution-
+ Share Alike 3.0 United States License[14] as all documentation should
+ be.
+
+ Now that you're completely confused, you can ask me any time to clarify
+ my licensing choices.
+
+TRADEMARK NOTICES
+
+ mIRC is a registered trademark of mIRC Co. Ltd.[3]
+
+LINKS
+ [ 1] http://kthx.net/clb/tcl4mirc/
+ [ 2] http://www.mircscripts.org/comments.php?cid=3864
+ [ 3] http://www.mirc.co.uk/
+ [ 4] http://search.cpan.org/perldoc?Inline::C
+ [ 5] http://search.cpan.org/
+ [ 6] http://search.cpan.org/dist/Inline-ASM/
+ [ 7] http://search.cpan.org/dist/Inline-Java/
+ [ 8] http://search.cpan.org/dist/Inline-Lua/
+ [ 9] http://search.cpan.org/dist/Inline-Python/
+ [10] http://search.cpan.org/dist/Inline-Ruby/
+ [11] http://search.cpan.org/dist/Inline-Tcl/
+ [12] http://search.cpan.org/search?m=dist&q=Inline::
+ [13] http://www.perlfoundation.org/artistic_2_0_notes
+ [14] http://creativecommons.org/licenses/by-sa/3.0/us/
7 TODO.txt
@@ -0,0 +1,7 @@
+
+- Cache packages according to perlembed
+- bugfixes?
+- See inline TODO comments in perl4mirc.c
+- change output to signals (let user decide what to do with the text) rather
+ than echo calls?
+- handle $ identifiers
125 perl.mrc
@@ -0,0 +1,125 @@
+; perl4mIRC support script for version 0.9.600
+;
+; Written by Sanko Robinson <sanko@cpan.org>
+;
+; This file is not needed to use perl4mirc.dll but
+; provides a simplified interface to access it.
+;
+; See README.txt for information on how to use
+; the commands defined here, or look at the
+; Examples below.
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of The Artistic License 2.0. See the F<LICENSE>
+; file included with this distribution or
+; http://www.perlfoundation.org/artistic_license_2_0. For
+; clarification, see http://www.perlfoundation.org/artistic_2_0_notes.
+
+; Convenience methods
+alias perl_dll { return " $+ $scriptdirperl4mIRC.dll $+ " }
+alias perl_unload { dll -u $perl_dll }
+alias perl_str { return $qt($replace($1,\,/,$,\$)) }
+alias perl { if ($isid) return $dll($perl_dll,perl_eval_string,$1-) | dll $perl_dll perl_eval_string $1- }
+
+; Perl interpeter bridge methods for embedded scripts
+alias perl_embed { perl eval_embed( $perl_str($1) $+ , $2-) | return $false }
+alias has_perl { return $!perl_embed($script,$scriptline) }
+
+; Initialization callback
+on *:SIGNAL:PERL_ONLOAD: {
+ perl mIRC->{'PerlVer'} = qq[$^V]
+ perl mIRC->{'version'} = qq[$VERSION]
+ echo $color(info2) -ae * Loaded perl4mIRC %version (using Perl %PerlVer $+ ). Edit line $scriptline of $qt($remove($script,$mircdir)) to change this message.
+ perl delete mIRC->{'PerlVer'}
+ perl delete mIRC->{'version'}
+}
+
+on *:SIGNAL:PERL_UNLOAD: {
+ echo $color(info2) -ae * Unloaded perl4mIRC
+}
+
+on *:LOAD: { echo $color(info2) -ae * Running /perl_test to see if Perl works: | perl_test }
+
+; Examples
+
+; One-liners
+
+; Classic hello world
+alias perl_hello_world { perl print q[Hello world] }
+
+; Version
+alias perl_hello_world { perl version }
+alias perl_version { if ($isid) return $dll($perl_dll,version,$1-) | dll $perl_dll version $1- }
+
+; Perl timer-delays (needs multithreaded Perl)
+; Use threads only at your own risk!
+alias perl_threads { perl use threads; async{sleep 10; print q[Done]}; print q[Go!]; }
+
+; Download a file from a website and print the first line (LWP::Simple is needed)
+alias perl_get_versions_file {
+ perl use LWP::Simple qw[get];my@l=split(m[\n],get(q[http://www.mirc.co.uk/versions.txt]));print$l[0];
+}
+
+; Shows how to pass data to and from Perl when certain identifiers
+; are not accessible such as $1-
+alias perl_strlen {
+ set %data $1-
+ perl mIRC(q[//echo len:] . length(mIRC->{'data'}));
+ unset %data
+}
+
+; Embedded Perl
+
+; Test method
+alias perl_test {
+ if $($has_perl,2) {
+ mIRC("/linesep -a");
+ my @array = qw[3 5 1 2 4 9 7 6];
+ printf qq[Testing Perl.\n\tOriginal array: %s\n\tSorted array : %s],
+ join(q{, },@array),
+ join(q[, ], sort @array);
+ }
+}
+; Lists the modules currently loaded in Perl
+alias perl_list_modules {
+ if $($has_perl,2) {
+ my @modules;
+ for my $module(keys %INC) {
+ if ($module =~ m[\.pm$]) {
+ $module =~ s|/|::|g;
+ $module =~ s|.pm$||;
+ }
+ push @modules, $module;
+ }
+ # Bring information back to mIRC in a var rather
+ # than using the mirc proc to /echo the results
+ mIRC->{modules} = join(q[, ], sort {lc $a cmp lc $b} @modules);
+ }
+ echo -a Perl Modules: %modules
+ unset %modules
+}
+
+; REAL inline C :D
+; You asked for it, so here it is...
+; Requires you to install this script without spaces in the path
+alias inlinec {
+ if $($has_perl,2) {
+ use Inline C => q[
+ void greet() {
+ printf("Hello, world\n");
+ }
+ ];
+ greet;
+ }
+}
+
+; Here is an example using event specific identifiers from Perl
+; It's not perfect, but I'll work on it...
+on *:TEXT:*hello*:#perl-moo-moo: {
+ %nick = $nick
+ %chan = $chan
+ if $($has_perl,2) {
+ printf q[%s just said hi on %s],mIRC->{nick}, mIRC->{chan};
+ mIRC("/msg ". mIRC->{nick} . " Yo");
+ }
+}
233 perl4mIRC.pm
@@ -0,0 +1,233 @@
+package perl4mIRC;
+use strict;
+use warnings;
+use Carp qw[carp];
+use Text::Balanced qw[extract_codeblock];
+use Symbol qw[delete_package];
+use Tie::Hash;
+use base q[Tie::ExtraHash];
+use Win32::API; # Not in CORE
+*mIRC = *mIRC = *execute; # is _this_ your card?
+use constant BUFFER_SIZE => 4096;
+use constant WM_USER => 0x400;
+use constant WM_MCOMMAND => (WM_USER + 200);
+use constant WM_MEVALUATE => (WM_USER + 201);
+use constant NULL => 0;
+use constant PAGE_READWRITE => 4;
+use constant FILE_MAP_ALL_ACCESS => 0x000f001f;
+our $VERSION = 0.95;
+my ($hFileMap, $mData, $mWnd, %mIRC);
+my $NAMESPACE = q[mIRC];
+my $gap = chr(160) x 2;
+my $tab = $gap x 2;
+AUTOLOAD {
+ no strict q[vars];
+ (my $function = $AUTOLOAD) =~ s|.*::||;
+ return if $function eq q[DESTROY] or $function eq q[AUTOLOAD];
+ $function = shift if $function =~ m[^mIRC$]i;
+ return execute(sprintf q[//%s %s], lc($function), join(q[ ], @_));
+}
+$|++;
+Win32::API->Import(q[user32],
+ q[int SendMessage(int hWnd, int Msg, int wParam, int lParam)])
+ or die $!;
+Win32::API->Import(
+ q[kernel32],
+ q[INT CreateFileMapping(int hFile,int lAttr,int fProt,int dMaxHi,int dMaxLo,char* pName)]
+) or die $^E;
+Win32::API->Import(
+ q[Kernel32],
+ q[INT MapViewOfFile(int hFMapObj,int dAcs, int dFOffHi,int dFOffLo,int dNumOBytes)]
+) or die $^E;
+Win32::API->Import(q[kernel32], q[BOOL UnmapViewOfFile(char* lBAddr)])
+ or die $^E;
+Win32::API->Import(q[kernel32], q[BOOL CloseHandle(char* hObject)])
+ or die $^E;
+Win32::API->Import(q[kernel32],
+ q[VOID RtlMoveMemory(int hDst, char* pSrc, int lLen)])
+ or die $^E;
+my $RTLMoveMemory_R = # above to write, this to read
+ Win32::API->new(q[kernel32], q[RtlMoveMemory], [qw[P I I]], q[V])
+ or die $^E;
+
+sub init {
+ ($mWnd) = @_;
+ $hFileMap =
+ CreateFileMapping(0xFFFFFFFF, NULL, PAGE_READWRITE, 0, BUFFER_SIZE,
+ $NAMESPACE);
+ return 0 if !$hFileMap;
+ $mData = MapViewOfFile($hFileMap, FILE_MAP_ALL_ACCESS, 0, 0, 16);
+ tie *STDOUT, q[perl4mIRC]; # redirect STDOUT
+ tie *STDERR, q[perl4mIRC], 1; # redirect STDERR
+ tie %mIRC, q[perl4mIRC]; # deceitful mess
+ execute(q[/.signal PERL_ONLOAD]);
+ return 1;
+}
+
+sub deinit {
+ execute(q[/.signal PERL_UNLOAD]);
+ UnmapViewOfFile($mData);
+ CloseHandle($hFileMap);
+ return 1;
+}
+
+sub eval_string {
+ my ($code, $package) = @_;
+ my $return = eval sprintf <<'EVAL', $package, $code;
+package %s;
+no strict;
+*mIRC = *perl4mIRC::mIRC;
+*eval_embed = *perl4mIRC::eval_embed;
+#line 1 mIRC
+%s
+EVAL
+ warn($@) if $@;
+ delete_package($package);
+ return $return;
+}
+
+sub eval_embed {
+ my ($file, $line) = @_;
+ open(my ($FH), q[<], $file) || carp sprintf q[Could not open '%s': %s],
+ $file, $^E
+ and return;
+ sysread($FH, my ($CODE), -s $FH) == -s $file
+ || carp sprintf q[Could not read '%s': %s], $file, $^E
+ and return;
+ close($FH);
+ $line--; # ??? eh?
+ $CODE =~ s|(.*\n){$line}||;
+ my $package = q[Perl4mIRC::Eval::] . int(rand(time));
+ my (undef, $bad) = extract_codeblock $CODE, q[({}], q[[^(}]*];
+ my $strCode = extract_codeblock $bad, q[({}];
+ my $return = eval sprintf <<'EVAL', $package, $line, $file, $strCode;
+package %s;
+*mIRC = *perl4mIRC::mIRC;
+*eval_embed = *perl4mIRC::eval_embed;
+#line %d "%s"
+%s
+EVAL
+ warn($@) if $@;
+ delete_package($package);
+ return $return;
+}
+
+sub evaluate {
+ my ($command) = @_;
+ RtlMoveMemory($mData, chr(0) x BUFFER_SIZE, BUFFER_SIZE);
+ RtlMoveMemory($mData, $command, length($command) + 15);
+ my $return = SendMessage($mWnd, WM_MEVALUATE, 0, 0);
+ $command = chr(0) x BUFFER_SIZE;
+ $RTLMoveMemory_R->Call($command, $mData, BUFFER_SIZE);
+ ($command, undef) = split(qq[\0], $command, 2);
+ return $command;
+}
+
+sub execute {
+ my ($command) = @_;
+ RtlMoveMemory($mData, chr(0) x BUFFER_SIZE, BUFFER_SIZE);
+ RtlMoveMemory($mData, $command, length($command) + 15);
+ my $return = SendMessage($mWnd, WM_MCOMMAND, 1 | 4, 0);
+ $command = chr(0) x BUFFER_SIZE;
+ $RTLMoveMemory_R->Call($command, $mData, BUFFER_SIZE);
+ ($command, undef) = split(chr(0), $command, 2);
+ return $command;
+}
+sub TIEHANDLE { $_[1] ||= 0; return bless \pop, pop; }
+
+sub PRINT {
+ my $handle = shift;
+ for my $l (@_) {
+ for my $p (split m[\n], $l) {
+ $p =~ s[\t][$tab]g;
+ $p =~ s[ ][$gap]g;
+ $p =~ s[^(\W)][chr(0xFEFF) . $1]eg;
+ perl4mIRC::execute(sprintf q[//echo %s %s],
+ ($$handle
+ ? q[$color(ctcp) * ]
+ : q[$color(normal)]
+ ),
+ $p
+ );
+ }
+ }
+ return 1;
+}
+sub PRINTF { (shift)->PRINT(sprintf shift, @_); }
+
+sub TIEHASH {
+ my $class = shift;
+ my $storage = bless [{}, @_], $class;
+ return $storage;
+}
+
+sub DELETE {
+ my ($self, $key) = @_;
+ return perl4mIRC::execute(sprintf(q[/unset %%%s], $key));
+}
+
+sub STORE {
+ my ($self, $key, $value) = @_;
+ return perl4mIRC::execute(sprintf(q[/set %%%s %s], $key, $value));
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+ return perl4mIRC::evaluate(sprintf(q[%%%s], $key));
+}
+1;
+
+=pod
+
+=head1 NAME
+
+perl4mIRC.pm
+
+=head1 Synopsis
+
+=head1 Description
+
+Without this module, perl4mIRC provides basic functionality.
+
+=head1 Notes
+
+=head2 The mIRC pseudo object
+
+To make perl4mIRC as nifty as possible, a little magic is involved.
+
+=head2 Requirements
+
+This module requires L<Win32::API> be installed.
+
+=head2 Installation
+
+=head1 See Also
+
+Project page - http://sanko.googlecode.com/
+
+mIRC - http://mirc.co.uk/
+
+=head1 Author
+
+Sanko Robinson <sanko@cpan.org> - http://sankorobinson.com/
+
+CPAN ID: SANKO
+
+=head1 License and Legal
+
+Copyright (C) 2008 by Sanko Robinson E<lt>sanko@cpan.orgE<gt>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of The Artistic License 2.0. See the F<LICENSE>
+file included with this distribution or
+http://www.perlfoundation.org/artistic_license_2_0. For
+clarification, see http://www.perlfoundation.org/artistic_2_0_notes.
+
+When separated from the distribution, all POD documentation is covered
+by the Creative Commons Attribution-Share Alike 3.0 License. See
+http://creativecommons.org/licenses/by-sa/3.0/us/legalcode. For
+clarification, see http://creativecommons.org/licenses/by-sa/3.0/us/.
+
+=for svn $Id: perl4mIRC.pm 6 2009-02-13 06:11:02Z sanko@cpan.org $
+
+=cut
261 perl4mirc.c
@@ -0,0 +1,261 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "patchlevel.h" /* for local_patches */
+
+char* VERSION = "0.9_600";
+
+typedef struct {
+ short major;
+ short minor;
+} MVERSION;
+
+typedef struct {
+ MVERSION mVersion;
+ HWND mHwnd;
+ BOOL mKeep;
+} LOADINFO;
+
+static PerlInterpreter *my_perl = NULL;
+
+HWND mWnd;
+BOOL loaded;
+
+EXTERN_C void xs_init ( pTHX );
+EXTERN_C void boot_DynaLoader ( pTHX_ CV* cv );
+EXTERN_C void boot_Win32CORE ( pTHX_ CV* cv );
+
+EXTERN_C void xs_init( pTHX ) {
+ PERL_UNUSED_CONTEXT;
+ char *file = __FILE__;
+ dXSUB_SYS;
+ /* DynaLoader is a special case; Win32 is a special m[h?ea?d] case */
+ newXS( "DynaLoader::boot_DynaLoader", boot_DynaLoader, file );
+ newXS( "Win32CORE::bootstrap", boot_Win32CORE, file );
+}
+
+// Get everything going...
+int __declspec( dllexport ) __stdcall LoadDll( LOADINFO *mIRC ) {
+ if ( my_perl == NULL ) {
+ mWnd = mIRC->mHwnd;
+ mIRC->mKeep = TRUE; // TODO: Set to FALSE if the inline perl fails
+ char *atmp[3] = { NULL, NULL, NULL };
+ char sWnd[20];
+ sprintf( sWnd, "%i", mWnd );
+ atmp[0] = sWnd;
+ if ( my_perl == NULL ) {
+ char *perl_args[] = { "", "-e", "", "0", "", "-w" };
+ PERL_SYS_INIT3( NULL, NULL, NULL );
+ if ( ( my_perl = perl_alloc() ) == NULL ) {
+ MessageBox( 0, "No memory!", "Cannot load DLL!" , MB_ICONSTOP );
+ mIRC->mKeep = FALSE;
+ return 0;
+ }
+ perl_construct( my_perl );
+ perl_parse( my_perl, xs_init, 6, perl_args, NULL );
+ PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
+ perl_run( my_perl );
+ if ( require_win32api() == 1 ) {
+ SV* result = eval_pv( "*perl4mIRC::eval_string = sub {eval shift};require perl4mIRC;", FALSE );
+ }
+ else {
+ SV* result = eval_pv( "*perl4mIRC::eval_string = sub {eval shift};", FALSE );
+ }
+ if ( SvTRUE( ERRSV ) )
+ loaded = FALSE;
+ else
+ loaded = TRUE;
+ PERL_SET_CONTEXT( my_perl );
+ perl_run( my_perl );
+ }
+ PERL_SET_CONTEXT( my_perl );
+ char data[1024]; // waste...
+ execute_perl( "perl4mIRC::init", atmp, data );
+ }
+ return 0;
+}
+int __declspec( dllexport ) __stdcall UnloadDll( int mTimeout ) {
+ if ( mTimeout == 0 ) { /* user called /dll -u*/ }
+ if ( my_perl == NULL )
+ return 0;
+ PL_perl_destruct_level = 1;
+ PERL_SET_CONTEXT( my_perl );
+ SV* result = eval_pv(
+ "foreach my $lib (@DynaLoader::dl_modules) {"
+ " if ($lib =~ m[^perl4mIRC::]) {"
+ " $lib .= q[::deinit();];"
+ " eval $lib;"
+ " }"
+ "}"
+ "perl4mIRC::deinit();",
+ FALSE );
+ PL_perl_destruct_level = 1;
+ PERL_SET_CONTEXT( my_perl );
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+ my_perl = NULL;
+ return 0;
+}
+
+int __declspec( dllexport ) __stdcall version (
+ HWND mWnd, HWND aWnd,
+ char *data, char *parms,
+ BOOL print, BOOL nopause
+) {
+ sprintf( data, "perl4mIRC v%s by Sanko Robinson <sanko@cpan.org>", VERSION );
+ return 3;
+}
+
+int __declspec( dllexport ) __stdcall perl_eval_string (
+ HWND mWnd, HWND aWnd,
+ char *data, char *parms,
+ BOOL print, BOOL nopause
+) { /* ...what is this junk? Oh, it's...
+ * mWnd - the handle to the main mIRC window.
+ * aWnd - the handle of the window in which the command is being issued,
+ * this might not be the currently active window if the command
+ * is being called by a remote script.
+ * data - the information that you wish to send to the DLL. On return,
+ * the DLL can fill this variable with the command it wants
+ * mIRC to perform if any.
+ * parms - filled by the DLL on return with parameters that it wants mIRC
+ * to use when performing the command that it returns in the
+ * data variable.
+ * Note: The data and parms variables can each hold 900 chars
+ * maximum.
+ * show - FALSE if the . prefix was specified to make the command quiet,
+ * or TRUE otherwise.
+ * nopause - TRUE if mIRC is in a critical routine and the DLL must not do
+ * anything that pauses processing in mIRC, eg. the DLL should
+ * not pop up a dialog.
+ *
+ * We basically ignore the majority of these which is just simply wrong.
+ * This WILL change in the future.
+ */
+ if ( my_perl == NULL ) {
+ return 0;
+ }
+ char *package;
+ sprintf( package, "perl4mIRC::Eval::%d", rand() ); // TODO - generate in perl4mIRC?
+ char *atmp[3] = { data, package, NULL };
+ PERL_SET_CONTEXT( my_perl );
+ execute_perl( "perl4mIRC::eval_string", atmp, data );
+ return 3;
+ /* We can return an integer to indicate what we want mIRC to do:
+ * 0 means that mIRC should /halt processing
+ * 1 means that mIRC should continue processing
+ * 2 means that we have filled the data variable with a command which mIRC
+ * should perform and we filled parms with the parameters to use, if any,
+ * when performing the command.
+ * 3 means that the DLL has filled the data variable with the result that
+ * $dll() as an identifier should return.
+ *
+ * For now, we always return 3. This may change in future.
+ */
+}
+
+int execute_perl( const char *function, char **args, char *data ) {
+ int count = 0, i, ret_value = 1;
+ STRLEN na;
+ SV *sv_args[0];
+ dSP;
+ PERL_SET_CONTEXT( my_perl );
+ /*
+ * Set up the perl environment, push arguments onto the
+ * perl stack, then call the given function
+ */
+ SPAGAIN;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK( sp );
+ for ( i = 0; i < sizeof( args ) - 1; i++ ) {
+ if ( args[i] != NULL ) {
+ sv_args[i] = sv_2mortal( newSVpv( args[i], 0 ) );
+ XPUSHs( sv_args[i] );
+ }
+ }
+ PUTBACK;
+ PERL_SET_CONTEXT( my_perl );
+ count = call_pv( function, G_EVAL | G_SCALAR );
+ SPAGAIN;
+ /*
+ * Check for "die," make sure we have 1 argument, and set our
+ * return value.
+ */
+ if ( SvTRUE( ERRSV ) ) {
+ sprintf( data, "%sPerl function (%s) exited abnormally: %s", ( loaded ? "ERR " : "" ), function, SvPV( ERRSV, na ) );
+ ( void )POPs;
+ }
+ else if ( count != 1 ) {
+ /*
+ * This should NEVER happen. G_SCALAR ensures that we WILL
+ * have 1 parameter.
+ */
+ sprintf( data, "%sPerl error executing '%s': expected 1 return value; received %s", ( loaded ? "ERR " : "" ), function, count );
+ }
+ else {
+ sprintf( data, "%s%s", ( loaded ? "OK " : "" ), POPpx );
+ }
+ /* Check for changed arguments */
+ for ( i = 0; i < sizeof( args ) - 1; i++ ) {
+ if ( args[i] && strcmp( args[i], SvPVX( sv_args[i] ) ) ) {
+ args[i] = strdup( SvPV( sv_args[i], na ) );
+ }
+ }
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return ret_value;
+}
+
+int require_win32api () { // make sure W::A is actually installed
+ SV* result = eval_pv( "require Win32::API;", FALSE );
+ if ( SvTRUE( ERRSV ) )
+ return 0;
+ else
+ return 1;
+ return 0;
+}
+
+/*
+
+=pod
+
+=head1 NAME
+
+perl4mIRC
+
+=head1 Synopsis
+
+ ; From mIRC
+ //echo $perl(5.6 + 456)
+
+=head 1 Description
+
+Use Perl from mIRC
+
+=head 1 Author
+
+Sanko Robinson <sanko@cpan.org> - http://sankorobinson.com/
+
+CPAN ID: SANKO
+
+=head1 License and Legal
+
+Copyright (C) 2008 by Sanko Robinson E<lt>sanko@cpan.orgE<gt>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of The Artistic License 2.0. See the F<LICENSE>
+file included with this distribution or
+http://www.perlfoundation.org/artistic_license_2_0. For
+clarification, see http://www.perlfoundation.org/artistic_2_0_notes.
+
+When separated from the distribution, all POD documentation is covered
+by the Creative Commons Attribution-Share Alike 3.0 License. See
+http://creativecommons.org/licenses/by-sa/3.0/us/legalcode. For
+clarification, see http://creativecommons.org/licenses/by-sa/3.0/us/.
+
+=for svn $Id: perl4mirc.c 4 2008-12-05 05:12:08Z sanko@cpan.org $
+
+=cut
+
+*/
Please sign in to comment.
Something went wrong with that request. Please try again.