New and reorganized perl sources. Autotools patched accordingly. Win build must be fixed.
Originally committed to SVN as r1827.
This commit is contained in:
shb
parent
260c2b5cb2
commit
b2518f9ca1
13 changed files with 1007 additions and 499 deletions
|
|
@ -47,6 +47,11 @@ if WITH_AUTO4_RUBY
|
|||
AUTOMATION += auto4_ruby_assfile.cpp auto4_ruby.cpp auto4_ruby_dialog.cpp
|
||||
AM_CPPFLAGS += $(shell ruby -r rbconfig -e "p '-I' + Config::CONFIG['rubylibdir'] + '/' + Config::CONFIG['arch'] ") $(AM_CPPFLAGST)
|
||||
endif
|
||||
if WITH_AUTO4_PERL
|
||||
AUTOMATION += auto4_perl.cpp auto4_perl_script.cpp auto4_perl_dialogs.cpp auto4_perl_ass.cpp auto4_perl_console.cpp
|
||||
AM_CPPFLAGS += $(shell perl -MExtUtils::Embed -eccflags -eperl_inc)
|
||||
aegisub_LDFLAGS += $(shell perl -MExtUtils::Embed -eldopts)
|
||||
endif
|
||||
|
||||
if HAVE_HUNSPELL
|
||||
HUNSPELL=spellchecker_hunspell.cpp
|
||||
|
|
|
|||
|
|
@ -38,6 +38,16 @@
|
|||
|
||||
|
||||
#include "auto4_perl.h"
|
||||
#include "auto4_perl_console.h"
|
||||
#include "options.h"
|
||||
#include "ass_style.h"
|
||||
|
||||
|
||||
#define COLLECT_PV(buf, s, e) \
|
||||
buf = wxString(SvPV_nolen(ST(s)), pl2wx);\
|
||||
for(int ARG_i = s+1; ARG_i <= e; ARG_i++) {\
|
||||
buf << _T(" ") << wxString(SvPV_nolen(ST(ARG_i)), pl2wx);\
|
||||
}
|
||||
|
||||
|
||||
namespace Automation4 {
|
||||
|
|
@ -46,9 +56,264 @@ namespace Automation4 {
|
|||
///////////////////////////////////
|
||||
// Perl -> C++ interface (XSUBS)
|
||||
//
|
||||
|
||||
/* Aegisub */
|
||||
XS(perl_log) // Aegisub::log()
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::log);
|
||||
dXSARGS;
|
||||
IV level = 6;
|
||||
|
||||
int start = 0;
|
||||
if(items >= 2 && SvIOK(ST(0))) {
|
||||
level = SvIV(ST(0));
|
||||
start = 1;
|
||||
}
|
||||
wxString msg;
|
||||
COLLECT_PV(msg, start, items-1);
|
||||
PerlLog(level, msg);
|
||||
}
|
||||
|
||||
XS(perl_warning) // Aegisub::warn()
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::warn);
|
||||
dXSARGS;
|
||||
|
||||
if(items >= 1) {
|
||||
wxString buf;
|
||||
COLLECT_PV(buf, 0, items-1);
|
||||
PerlLogWarning(buf);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
XS(perl_text_extents) // Aegisub::text_extents
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::text_extents);
|
||||
dXSARGS;
|
||||
|
||||
// Read the parameters
|
||||
SV *style; wxString text;
|
||||
if(items >= 2) {
|
||||
// Enough of them
|
||||
style = sv_mortalcopy(ST(0));
|
||||
text = wxString(SvPV_nolen(ST(1)), pl2wx);
|
||||
}
|
||||
else {
|
||||
/* TODO maybe: emit warning */
|
||||
// We needed 2 parameters at least!
|
||||
XSRETURN_UNDEF;
|
||||
}
|
||||
|
||||
// Get the AssStyle
|
||||
AssStyle *s;
|
||||
if(SvROK(style)) {
|
||||
// Create one from the hassh
|
||||
s = PerlAss::MakeAssStyle((HV*)SvRV(style));
|
||||
}
|
||||
else {
|
||||
// It's the name of the style
|
||||
wxString sn(SvPV_nolen(style), pl2wx);
|
||||
// We get it from the AssFile::top
|
||||
s = AssFile::top->GetStyle(sn);
|
||||
/* TODO maybe: make it dig from the current hassh's styles */
|
||||
if(!s)
|
||||
XSRETURN_UNDEF;
|
||||
}
|
||||
|
||||
// The return parameters
|
||||
double width, height, descent, extlead;
|
||||
// The actual calculation
|
||||
if(!CalculateTextExtents(s, text, width, height, descent, extlead)) {
|
||||
/* TODO: diagnose error */
|
||||
XSRETURN_EMPTY;
|
||||
}
|
||||
|
||||
// Returns
|
||||
switch(GIMME_V) {
|
||||
case G_SCALAR:
|
||||
// Scalar context
|
||||
XSRETURN_NV(width);
|
||||
break;
|
||||
default:
|
||||
case G_ARRAY:
|
||||
// List context
|
||||
EXTEND(SP, 4);
|
||||
XST_mNV(0, width);
|
||||
XST_mNV(1, height);
|
||||
XST_mNV(2, descent);
|
||||
XST_mNV(3, extlead);
|
||||
XSRETURN(4);
|
||||
}
|
||||
}
|
||||
|
||||
/* Aegisub::Script */
|
||||
XS(perl_script_set_info)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::Script::set_info);
|
||||
dXSARGS;
|
||||
|
||||
PerlScript *active = PerlScript::GetScript();
|
||||
if(active) {
|
||||
// Update the object's vars
|
||||
active->ReadVars();
|
||||
|
||||
// We want at most 4 parameters :P
|
||||
if(items > 4) items = 4;
|
||||
// Set script info vars
|
||||
switch (items) {
|
||||
case 4:
|
||||
active->SetVersion(wxString(SvPV_nolen(ST(3)), pl2wx));
|
||||
case 3:
|
||||
active->SetAuthor(wxString(SvPV_nolen(ST(2)), pl2wx));
|
||||
case 2:
|
||||
active->SetDescription(wxString(SvPV_nolen(ST(1)), pl2wx));
|
||||
case 1:
|
||||
active->SetName(wxString(SvPV_nolen(ST(0)), pl2wx));
|
||||
}
|
||||
|
||||
// Update the package's vars
|
||||
active->WriteVars();
|
||||
}
|
||||
}
|
||||
|
||||
XS(perl_script_register_macro)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::Script::register_macro);
|
||||
dXSARGS;
|
||||
|
||||
PerlScript *active = PerlScript::GetScript();
|
||||
if(active && items >= 3) {
|
||||
wxString name, description;
|
||||
SV *proc_sub = NULL, *val_sub = NULL;
|
||||
|
||||
if(items > 4) items = 4;
|
||||
switch (items) {
|
||||
case 4:
|
||||
val_sub = sv_mortalcopy(ST(3));
|
||||
case 3:
|
||||
proc_sub = sv_mortalcopy(ST(2));
|
||||
description = wxString(SvPV_nolen(ST(1)), pl2wx);
|
||||
name = wxString(SvPV_nolen(ST(0)), pl2wx);
|
||||
}
|
||||
if(proc_sub) {
|
||||
active->AddFeature(new PerlFeatureMacro(name, description, active, proc_sub, val_sub));
|
||||
XSRETURN_YES;
|
||||
}
|
||||
}
|
||||
XSRETURN_UNDEF;
|
||||
}
|
||||
|
||||
/* Aegisub::Progress */
|
||||
XS(perl_progress_set)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::Progress::set_progress);
|
||||
dXSARGS;
|
||||
|
||||
PerlProgressSink *ps = PerlProgressSink::GetProgressSink();
|
||||
if(ps && items >= 1) {
|
||||
NV pc = SvNV(ST(0));
|
||||
if(pc <= 1) pc *= 100;
|
||||
if(pc > 100) pc = 100;
|
||||
ps->SetProgress(pc);
|
||||
wxWakeUpIdle();
|
||||
}
|
||||
}
|
||||
|
||||
XS(perl_progress_task)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::Progress::set_task);
|
||||
dXSARGS;
|
||||
|
||||
PerlProgressSink *ps = PerlProgressSink::GetProgressSink();
|
||||
if(ps && items >= 1) {
|
||||
wxString task;
|
||||
COLLECT_PV(task, 0, items-1);
|
||||
ps->SetTask(task);
|
||||
wxWakeUpIdle();
|
||||
}
|
||||
}
|
||||
|
||||
XS(perl_progress_title)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::Progress::set_title);
|
||||
dXSARGS;
|
||||
|
||||
PerlProgressSink *ps = PerlProgressSink::GetProgressSink();
|
||||
if(ps && items >= 1) {
|
||||
wxString title;
|
||||
COLLECT_PV(title, 0, items-1);
|
||||
ps->SetTitle(title);
|
||||
wxWakeUpIdle();
|
||||
}
|
||||
}
|
||||
|
||||
XS(perl_progress_cancelled)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::Progress::is_cancelled);
|
||||
dXSARGS;
|
||||
|
||||
if(PerlProgressSink *ps = PerlProgressSink::GetProgressSink()) {
|
||||
if(ps->IsCancelled()) XSRETURN_YES;
|
||||
else XSRETURN_NO;
|
||||
}
|
||||
else {
|
||||
XSRETURN_UNDEF;
|
||||
}
|
||||
}
|
||||
|
||||
/* Aegisub::PerlConsole */
|
||||
XS(perl_console_register)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::PerlConsole::register_console);
|
||||
dXSARGS;
|
||||
|
||||
PerlScript *script = PerlScript::GetScript();
|
||||
if(script) {
|
||||
wxString name = _T("Perl console");
|
||||
wxString desc = _T("Show the Perl console");
|
||||
switch (items) {
|
||||
case 2:
|
||||
desc = wxString(SvPV_nolen(ST(1)), pl2wx);
|
||||
case 1:
|
||||
name = wxString(SvPV_nolen(ST(0)), pl2wx);
|
||||
}
|
||||
|
||||
if(!PerlConsole::GetConsole())
|
||||
// If there's no registered console
|
||||
script->AddFeature(new PerlConsole(name, desc, script));
|
||||
}
|
||||
}
|
||||
|
||||
XS(perl_console_echo)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::PerlConsole::echo);
|
||||
dXSARGS;
|
||||
|
||||
// We should get some parameters
|
||||
if(items == 0) return;
|
||||
|
||||
// Join the params in a unique string :S
|
||||
wxString buffer = wxString(SvPV_nolen(ST(0)), pl2wx);
|
||||
for(int i = 1; i < items; i++) {
|
||||
buffer << _T(" ") << wxString(SvPV_nolen(ST(i)), pl2wx);
|
||||
}
|
||||
|
||||
if(PerlConsole::GetConsole()) {
|
||||
// If there's a console echo to it
|
||||
PerlConsole::Echo(buffer);
|
||||
}
|
||||
else {
|
||||
// Otherwise print on stdout
|
||||
PerlIO_printf(PerlIO_stdout(), "%s\n", buffer.mb_str(wxConvLocal).data());
|
||||
// (through perl io system)
|
||||
}
|
||||
}
|
||||
|
||||
/* Universal loader */
|
||||
EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
|
||||
|
||||
// Copypasted from somewhere
|
||||
/* XS registration */
|
||||
EXTERN_C void xs_perl_main(pTHX)
|
||||
{
|
||||
dXSUB_SYS;
|
||||
|
|
@ -57,9 +322,172 @@ namespace Automation4 {
|
|||
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
|
||||
|
||||
// My XSUBS ^^
|
||||
xs_perl_script(aTHX);
|
||||
xs_perl_misc(aTHX);
|
||||
xs_perl_console(aTHX);
|
||||
newXS("Aegisub::log", perl_log, __FILE__);
|
||||
newXS("Aegisub::warn", perl_warning, __FILE__);
|
||||
newXS("Aegisub::text_extents", perl_text_extents, __FILE__);
|
||||
newXS("Aegisub::Script::set_info", perl_script_set_info, __FILE__);
|
||||
newXS("Aegisub::Script::register_macro", perl_script_register_macro, __FILE__);
|
||||
newXS("Aegisub::Progress::set_progress", perl_progress_set, __FILE__);
|
||||
newXS("Aegisub::Progress::set_task", perl_progress_task, __FILE__);
|
||||
newXS("Aegisub::Progress::set_title", perl_progress_title, __FILE__);
|
||||
newXS("Aegisub::Progress::is_cancelled", perl_progress_cancelled, __FILE__);
|
||||
newXS("Aegisub::PerlConsole::echo", perl_console_echo, __FILE__);
|
||||
newXS("Aegisub::PerlConsole::register_console", perl_console_register, __FILE__);
|
||||
}
|
||||
|
||||
|
||||
/////////////
|
||||
// PerlLog
|
||||
//
|
||||
void PerlLog(unsigned int level, const wxString &msg)
|
||||
{
|
||||
PerlProgressSink *ps = PerlProgressSink::GetProgressSink();
|
||||
if(!(level & 0x8) && ps) {
|
||||
wxString _msg;
|
||||
// Prepend a description of the log line
|
||||
switch(level) {
|
||||
case 0: _msg = _("Fatal error: ");
|
||||
break;
|
||||
case 1: _msg = _("Error: ");
|
||||
break;
|
||||
case 2: _msg = _("Warning: ");
|
||||
break;
|
||||
case 3: _msg = _("Hint: ");
|
||||
break;
|
||||
case 4: _msg = _("Debug: ");
|
||||
break;
|
||||
case 5: _msg = _("Trace: ");
|
||||
}
|
||||
// Print onto the progress window
|
||||
ps->Log(level >= 6 ? -1 : level, _msg+msg+_T("\n"));
|
||||
}
|
||||
else {
|
||||
level &= 0x7;
|
||||
// Use the wx log functions
|
||||
switch(level) {
|
||||
case 0: wxLogFatalError(msg);
|
||||
break;
|
||||
case 1: wxLogError(msg);
|
||||
break;
|
||||
case 2: wxLogWarning(msg);
|
||||
break;
|
||||
case 3: wxLogVerbose(msg);
|
||||
break;
|
||||
case 4: wxLogDebug(msg);
|
||||
break;
|
||||
case 5: wxLogTrace(wxTRACE_AutoPerl, msg);
|
||||
break;
|
||||
default:
|
||||
case 6: wxLogMessage(msg);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
////////////////
|
||||
// PerlThread
|
||||
//
|
||||
|
||||
PerlThread::PerlThread():
|
||||
wxThread(wxTHREAD_JOINABLE)
|
||||
{
|
||||
pv = NULL; sv = NULL;
|
||||
}
|
||||
|
||||
PerlThread::PerlThread(const char *sub_name, I32 flags, bool type):
|
||||
wxThread(wxTHREAD_JOINABLE)
|
||||
{
|
||||
wxTRACE_METH(PerlThread);
|
||||
if(type == CALL) Call(sub_name, flags);
|
||||
if(type == EVAL) Eval(sub_name, flags);
|
||||
}
|
||||
|
||||
PerlThread::PerlThread(SV *sv, I32 flags, bool type):
|
||||
wxThread(wxTHREAD_JOINABLE)
|
||||
{
|
||||
wxTRACE_METH(PerlThread);
|
||||
if(type == CALL) Call(sv, flags);
|
||||
if(type == EVAL) Eval(sv, flags);
|
||||
}
|
||||
|
||||
wxThreadError PerlThread::launch()
|
||||
{
|
||||
wxThreadError e = Create();
|
||||
if(e != wxTHREAD_NO_ERROR) return e;
|
||||
|
||||
switch(Options.AsInt(_T("Automation Thread Priority"))) {
|
||||
case 2: SetPriority(10);
|
||||
break;
|
||||
case 1: SetPriority(30);
|
||||
break;
|
||||
default:
|
||||
case 0: SetPriority(50); // fallback normal
|
||||
}
|
||||
|
||||
wxTRACE_RET(PerlThread);
|
||||
return Run();
|
||||
}
|
||||
|
||||
wxThreadError PerlThread::Call(const char *sub_name, I32 _flags)
|
||||
{
|
||||
type = CALL; pv = sub_name; flags = _flags;
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("type = CALL, pv = '%s', flags = %u"), wxString(pv, pl2wx).c_str(), flags);
|
||||
return launch();
|
||||
}
|
||||
wxThreadError PerlThread::Call(SV *_sv, I32 _flags)
|
||||
{
|
||||
type = CALL; sv = _sv; flags = _flags;
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("type = CALL, sv = %p, flags = %u"), sv, flags);
|
||||
return launch();
|
||||
}
|
||||
|
||||
wxThreadError PerlThread::Eval(const char* p, I32 croak_on_error)
|
||||
{
|
||||
type = EVAL; pv = p; flags = croak_on_error;
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("type = EVAL, pv = '%s', flags = %u"), wxString(pv, pl2wx).c_str(), flags);
|
||||
return launch();
|
||||
}
|
||||
wxThreadError PerlThread::Eval(SV* _sv, I32 _flags)
|
||||
{
|
||||
type = EVAL; sv = _sv; flags = _flags;
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("type = EVAL, sv = %p, flags = %u"), sv, flags);
|
||||
return launch();
|
||||
}
|
||||
|
||||
wxThread::ExitCode PerlThread::Entry()
|
||||
{
|
||||
wxTRACE_METH(Entry);
|
||||
|
||||
PerlProgressSink *ps;
|
||||
if(ps = PerlProgressSink::GetProgressSink()) {
|
||||
// If there's a progress sink...
|
||||
while(!ps->has_inited);
|
||||
// ...wait for it to have inited
|
||||
}
|
||||
|
||||
ExitCode ec = NULL;
|
||||
switch(type) {
|
||||
case CALL:
|
||||
if(sv) ec = (ExitCode)call_sv(sv, flags);
|
||||
else if(pv) ec = (ExitCode)call_pv(pv, flags);
|
||||
break;
|
||||
case EVAL:
|
||||
if(sv) ec = (ExitCode)eval_sv(sv, flags);
|
||||
else if(pv) ec = (ExitCode)eval_pv(pv, flags);
|
||||
}
|
||||
|
||||
if(SvTRUE(ERRSV)) {
|
||||
// Log $@ in case of error
|
||||
PerlLogError(wxString(SvPV_nolen(ERRSV), pl2wx));
|
||||
}
|
||||
|
||||
if(ps) {
|
||||
ps->script_finished = true;
|
||||
wxWakeUpIdle();
|
||||
}
|
||||
|
||||
wxTRACE_RET(Entry);
|
||||
return ec;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -73,7 +501,12 @@ namespace Automation4 {
|
|||
|
||||
public:
|
||||
PerlScriptFactory()
|
||||
{
|
||||
{
|
||||
#ifdef WXTRACE_AUTOPERL
|
||||
// Add tracing of perl engine operations
|
||||
wxLog::AddTraceMask(wxTRACE_AutoPerl);
|
||||
#endif
|
||||
|
||||
// Script engine properties
|
||||
loaded = false;
|
||||
engine_name = _T("Perl");
|
||||
|
|
@ -88,13 +521,11 @@ namespace Automation4 {
|
|||
#endif
|
||||
|
||||
// Perl interpreter initialization (ONE FOR ALL THE SCRIPTS)
|
||||
char** env = NULL;
|
||||
int argc = 3;
|
||||
char *argv[3] = { "aegisub", "-e", "0" };
|
||||
#ifdef __VISUALC__
|
||||
char **argv2 = (char**) argv;
|
||||
char** env = NULL;
|
||||
char **argv2 = (char**) argv; // VC++ wants this °_°
|
||||
PERL_SYS_INIT3(&argc,&argv2,&env);
|
||||
#endif
|
||||
parser = perl_alloc();
|
||||
perl_construct(parser);
|
||||
perl_parse(parser, xs_perl_main,
|
||||
|
|
@ -114,9 +545,7 @@ namespace Automation4 {
|
|||
if (loaded) {
|
||||
perl_destruct(parser);
|
||||
perl_free(parser);
|
||||
#ifdef __VISUALC__
|
||||
PERL_SYS_TERM();
|
||||
#endif
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -33,6 +33,7 @@
|
|||
// Contact: mailto:jiifurusu@gmail.com
|
||||
//
|
||||
|
||||
|
||||
#pragma once
|
||||
#ifndef _AUTO4_PERL_H
|
||||
#define _AUTO4_PERL_H
|
||||
|
|
@ -43,17 +44,16 @@
|
|||
#include <wx/string.h>
|
||||
|
||||
#include "ass_file.h"
|
||||
//#include "ass_dialogue.h"
|
||||
|
||||
#undef _
|
||||
#include <EXTERN.h>
|
||||
#include <perl.h>
|
||||
#include <XSUB.h>
|
||||
|
||||
#include "auto4_perldata.inc" // Parl variables manipulation macros
|
||||
#include "auto4_perldata.inc" // Perl variables manipulation macros
|
||||
#undef bool
|
||||
|
||||
// the fucking perl.h redefines _() -.- please disregard warnings during compilation
|
||||
// the fucking perl.h redefines _() -.-
|
||||
#undef _
|
||||
#define _(s) wxGetTranslation(_T(s))
|
||||
|
||||
|
|
@ -66,20 +66,82 @@
|
|||
#define PERL_SCRIPT_EXTENSION ".pl" /* TODO maybe: make it multi-extension */
|
||||
|
||||
|
||||
// Debug support
|
||||
/* define the following to activate tracing for the perl engine */
|
||||
//#define WXTRACE_AUTOPERL
|
||||
#define wxTRACE_AutoPerl _T("auto4_perl")
|
||||
|
||||
#define wxTRACE_METH(name) \
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("\t=== %p::%s() ==="), this, _T(#name))
|
||||
|
||||
#define wxTRACE_FUNC(name) \
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("\t=== %s() ==="), _T(#name))
|
||||
|
||||
#define wxTRACE_RET(name) \
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("\t___ %s() returned ___"), _T(#name))
|
||||
|
||||
|
||||
namespace Automation4 {
|
||||
|
||||
///////////
|
||||
// XSUBS
|
||||
|
||||
/////////////
|
||||
// PerlLog
|
||||
//
|
||||
void xs_perl_script(pTHX);
|
||||
void xs_perl_misc(pTHX);
|
||||
void xs_perl_console(pTHX);
|
||||
#define LOG_FATAL 0
|
||||
#define LOG_ERROR 1
|
||||
#define LOG_WARNING 2
|
||||
#define LOG_HINT 3
|
||||
#define LOG_DEBUG 4
|
||||
#define LOG_TRACE 5
|
||||
#define LOG_MESSAGE 6
|
||||
|
||||
#define LOG_WX 8
|
||||
|
||||
#define PerlLogFatal(str) PerlLog(LOG_FATAL, str)
|
||||
#define PerlLogFatalError(str) PerlLog(LOG_FATAL, str)
|
||||
#define PerlLogError(str) PerlLog(LOG_ERROR, str)
|
||||
#define PerlLogWarning(str) PerlLog(LOG_WARNING, str)
|
||||
#define PerlLogHint(str) PerlLog(LOG_HINT, str)
|
||||
#define PerlLogVerbose(str) PerlLog(LOG_HINT, str)
|
||||
#define PerlLogDebug(str) PerlLog(LOG_DEBUG, str)
|
||||
#define PerlLogTrace(str) PerlLog(LOG_TRACE, str)
|
||||
#define PerlLogMessage(str) PerlLog(LOG_MESSAGE, str)
|
||||
|
||||
void PerlLog(unsigned int level, const wxString &msg);
|
||||
|
||||
|
||||
////////////////
|
||||
// PerlThread
|
||||
//
|
||||
class PerlThread : public wxThread {
|
||||
private:
|
||||
const char *pv;
|
||||
SV *sv;
|
||||
I32 flags;
|
||||
|
||||
bool type;
|
||||
|
||||
wxThreadError launch();
|
||||
|
||||
public:
|
||||
enum { EVAL = 0, CALL = 1 };
|
||||
|
||||
PerlThread();
|
||||
PerlThread(const char *sub_name, I32 flags, bool type = CALL);
|
||||
PerlThread(SV *sv, I32 flags, bool type = CALL);
|
||||
|
||||
wxThreadError Call(const char *sub_name, I32 flags);
|
||||
wxThreadError Call(SV *sv, I32 flags);
|
||||
wxThreadError Eval(const char* p, I32 croak_on_error);
|
||||
wxThreadError Eval(SV* sv, I32 flags);
|
||||
|
||||
virtual ExitCode Entry();
|
||||
};
|
||||
|
||||
|
||||
///////////////////
|
||||
// Script object
|
||||
//
|
||||
class PerlFeatureMacro;
|
||||
class PerlScript : public Script {
|
||||
private:
|
||||
static PerlScript *active; // The active script (at any given time)
|
||||
|
|
@ -93,40 +155,33 @@ namespace Automation4 {
|
|||
void load(); // It doas all the script initialization
|
||||
void unload(); // It does all the script disposing
|
||||
|
||||
static void activate(PerlScript *script); // Set the active script /* TODO: add @INC hacking */
|
||||
static void activate(PerlScript *script); // Set the active script
|
||||
static void deactivate(); // Unset the active script
|
||||
|
||||
public:
|
||||
PerlScript(const wxString &filename);
|
||||
virtual ~PerlScript();
|
||||
static PerlScript *GetScript() { return active; } // Query the value of the active script
|
||||
|
||||
virtual void Reload(); // Reloading of a loaded script
|
||||
|
||||
void Activate() { activate(this); } // Set the script as active
|
||||
void Deactivate() const { deactivate(); } // Unset the active script
|
||||
|
||||
const wxString& GetPackage() const { return package; } // The perl package containing script code
|
||||
static PerlScript *GetScript() { return active; } // Query the value of the active script
|
||||
|
||||
/* TODO maybe: change these into tying of scalars */
|
||||
/* TODO maybe: move to tied scalars */
|
||||
void ReadVars(); // Sync the script's vars from perl package to script object
|
||||
void WriteVars() const; // Sync the script's vars from script object to perl package
|
||||
|
||||
/* TODO: add c++ equivalents */
|
||||
void AddFeature(Feature *feature);
|
||||
void DeleteFeature(Feature *feature);
|
||||
static PerlScript *GetActive() { return active; }
|
||||
|
||||
const wxString& GetPackage() const { return package; } // The perl package containing script code
|
||||
void SetName(const wxString &str) { name = str; }
|
||||
void SetDescription(const wxString &str) { description = str; }
|
||||
void SetAuthor(const wxString &str) { author = str; }
|
||||
void SetVersion(const wxString &str) { version = str; }
|
||||
};
|
||||
|
||||
XS(set_info); // Aegisub::Script::set_info()
|
||||
XS(register_macro); // Aegisub::Script::register_macro()
|
||||
XS(register_console); // Aegisub::Script::register_console() /* TODO: move this into PerlConsole class */
|
||||
|
||||
|
||||
//////////////////
|
||||
// Macro object
|
||||
|
|
@ -148,6 +203,22 @@ namespace Automation4 {
|
|||
};
|
||||
|
||||
|
||||
//////////////////////
|
||||
// PerlProgressSink
|
||||
//
|
||||
class PerlProgressSink : public ProgressSink {
|
||||
private:
|
||||
static PerlProgressSink *sink;
|
||||
public:
|
||||
PerlProgressSink(wxWindow *parent, const wxString &title = _T("..."));
|
||||
~PerlProgressSink();
|
||||
static PerlProgressSink *GetProgressSink() { return sink; }
|
||||
|
||||
bool IsCancelled() const { return cancelled; }
|
||||
void Log(int level, const wxString &message) { if(level <= trace_level) AddDebugOutput(message); }
|
||||
};
|
||||
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
// Conversion between aegisub data and perl data
|
||||
//
|
||||
|
|
@ -169,17 +240,6 @@ namespace Automation4 {
|
|||
};
|
||||
|
||||
|
||||
/////////////////////////
|
||||
// Misc utility functions
|
||||
//
|
||||
class PerlLog {
|
||||
public:
|
||||
};
|
||||
|
||||
XS(log_warning); // Aegisub::warn()
|
||||
XS(text_extents); // Aegisub::text_extents()
|
||||
|
||||
|
||||
};
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -75,24 +75,24 @@ namespace Automation4 {
|
|||
|
||||
wxString PerlAss::GetEntryClass(AssEntry *entry)
|
||||
{
|
||||
wxString data = entry->GetEntryData();
|
||||
|
||||
if(entry->GetType() == ENTRY_DIALOGUE) return _T("dialogue");
|
||||
|
||||
if(entry->GetType() == ENTRY_STYLE) {
|
||||
switch(entry->GetType()) {
|
||||
case ENTRY_DIALOGUE: return _T("dialogue");
|
||||
case ENTRY_STYLE:
|
||||
return _T("style");
|
||||
/* TODO: add stylex recognition */
|
||||
}
|
||||
|
||||
if(entry->GetType() == ENTRY_BASE) {
|
||||
break;
|
||||
case ENTRY_ATTACHMENT: return _T("attachment");
|
||||
default:
|
||||
case ENTRY_BASE:
|
||||
wxString data(entry->GetEntryData());
|
||||
if(entry->group == _T("[Script Info]") && data.Matches(_T("*:*"))) return _T("info");
|
||||
|
||||
|
||||
if(data == entry->group) return _T("head");
|
||||
|
||||
|
||||
if(data.StartsWith(_T("Format:"))) return _T("format");
|
||||
|
||||
|
||||
if(data.IsEmpty()) return _T("clear");
|
||||
|
||||
|
||||
if(data.Trim(left).StartsWith(_T(";"))) return _T("comment");
|
||||
}
|
||||
|
||||
|
|
@ -103,13 +103,15 @@ namespace Automation4 {
|
|||
|
||||
HV *PerlAss::MakeHasshEntry(AssEntry *e)
|
||||
{
|
||||
switch((int)e->GetType()) {
|
||||
switch(e->GetType()) {
|
||||
case ENTRY_DIALOGUE:
|
||||
return MakeHasshDialogue(AssEntry::GetAsDialogue(e));
|
||||
|
||||
case ENTRY_STYLE:
|
||||
return MakeHasshStyle(AssEntry::GetAsStyle(e));
|
||||
|
||||
case ENTRY_ATTACHMENT:
|
||||
|
||||
default:
|
||||
case ENTRY_BASE:
|
||||
dHV;
|
||||
|
|
@ -296,12 +298,16 @@ namespace Automation4 {
|
|||
// It seems to be a style, let's call the specialized function
|
||||
return MakeAssStyle(entry);
|
||||
}
|
||||
else if(cl == _T("attachment")) {
|
||||
/* TODO */
|
||||
return NULL;
|
||||
}
|
||||
else {
|
||||
// A base entry
|
||||
AssEntry *e = new AssEntry();
|
||||
|
||||
ASS_BASIC_INIT(entry, e);
|
||||
|
||||
// A base entry
|
||||
if(cl == _T("info")) {
|
||||
wxString key, value;
|
||||
HV_FETCH(entry, "key", 3) {
|
||||
|
|
|
|||
|
|
@ -47,13 +47,6 @@
|
|||
namespace Automation4 {
|
||||
|
||||
|
||||
void xs_perl_console(pTHX)
|
||||
{
|
||||
newXS("Aegisub::PerlConsole::echo", echo, __FILE__);
|
||||
newXS("Aegisub::PerlConsole::register_console", register_console, __FILE__);
|
||||
}
|
||||
|
||||
|
||||
////////////////////////////////////
|
||||
// PerlConsole::Dialog
|
||||
//
|
||||
|
|
@ -114,12 +107,6 @@ namespace Automation4 {
|
|||
}
|
||||
}
|
||||
|
||||
inline void PerlConsole::Dialog::Echo(const wxString &str)
|
||||
{
|
||||
if(txt_out) *txt_out << str << _T("\n");
|
||||
else PerlIO_printf(PerlIO_stdout(), "%s\n", str.mb_str(wxConvLocal).data());
|
||||
}
|
||||
|
||||
|
||||
//////////////////////
|
||||
// PerlConsole
|
||||
|
|
@ -134,8 +121,10 @@ namespace Automation4 {
|
|||
parent_window = NULL;
|
||||
dialog = new Dialog();
|
||||
|
||||
// Fuck off any previously registered console °_°
|
||||
if(registered) delete registered;
|
||||
// Remove any previously registered console °_°
|
||||
if(registered) {
|
||||
registered->script->DeleteFeature(registered);
|
||||
}
|
||||
registered = this;
|
||||
}
|
||||
|
||||
|
|
@ -146,7 +135,7 @@ namespace Automation4 {
|
|||
/* TODO: Free something? */
|
||||
|
||||
// Delete the registered console
|
||||
PerlConsole::registered = NULL;
|
||||
registered = NULL;
|
||||
}
|
||||
|
||||
void PerlConsole::Process(AssFile *subs, std::vector<int> &selected, int active, wxWindow * const progress_parent)
|
||||
|
|
@ -197,6 +186,9 @@ namespace Automation4 {
|
|||
code << str;
|
||||
// Evaluate the code
|
||||
SV *e = eval_pv(code.mb_str(wx2pl), 0);
|
||||
/* TODO: use threaded calls */
|
||||
/*PerlThread eval(code.mb_str(wx2pl), 1, PerlThread::EVAL);
|
||||
e = (SV*)eval.Wait();*/
|
||||
/* TODO: check for errors */
|
||||
script->ReadVars();
|
||||
|
||||
|
|
@ -220,52 +212,28 @@ namespace Automation4 {
|
|||
return wxString(SvPV_nolen(e), pl2wx);
|
||||
}
|
||||
|
||||
XS(register_console)
|
||||
wxString PerlConsole::Evaluate(const wxString &str)
|
||||
{
|
||||
dXSARGS;
|
||||
PerlScript *script = PerlScript::GetScript();
|
||||
if(script) {
|
||||
wxString name = _T("Perl console");
|
||||
wxString desc = _T("Show the Perl console");
|
||||
switch (items) {
|
||||
case 2:
|
||||
desc = wxString(SvPV_nolen(ST(1)), pl2wx);
|
||||
case 1:
|
||||
name = wxString(SvPV_nolen(ST(0)), pl2wx);
|
||||
}
|
||||
|
||||
if(!PerlConsole::GetConsole())
|
||||
// If there's no registered console
|
||||
script->AddFeature(new PerlConsole(name, desc, script));
|
||||
}
|
||||
}
|
||||
|
||||
XS(echo)
|
||||
{
|
||||
dXSARGS;
|
||||
|
||||
// We should get some parameters
|
||||
if(items == 0) XSRETURN_EMPTY;
|
||||
|
||||
// Join the params in a unique string :S
|
||||
wxString buffer = wxString(SvPV_nolen(ST(0)), pl2wx);
|
||||
for(int i = 1; i < items; i++) {
|
||||
buffer << _T(" ") << wxString(SvPV_nolen(ST(i)), pl2wx);
|
||||
}
|
||||
|
||||
if(PerlConsole::GetConsole()) {
|
||||
// If there's a console echo to it
|
||||
PerlConsole::GetConsole()->GetDialog()->Echo(buffer);
|
||||
if(registered) {
|
||||
return registered->evaluate(str);
|
||||
}
|
||||
else {
|
||||
// Otherwise print on stdout
|
||||
PerlIO_printf(PerlIO_stdout(), "%s\n", buffer.mb_str(wxConvLocal).data());
|
||||
// (through perl io system)
|
||||
/* TODO: print error */
|
||||
return _T("");
|
||||
}
|
||||
|
||||
XSRETURN_EMPTY;
|
||||
}
|
||||
|
||||
void PerlConsole::Echo(const wxString &str)
|
||||
{
|
||||
if(registered && registered->dialog->txt_out) {
|
||||
*(registered->dialog->txt_out) << str << _T("\n");
|
||||
}
|
||||
else {
|
||||
PerlIO_printf(PerlIO_stdout(), "%s\n", str.c_str());
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
};
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -45,6 +45,10 @@
|
|||
|
||||
namespace Automation4 {
|
||||
|
||||
|
||||
/////////////////
|
||||
// PerlConsole
|
||||
//
|
||||
class PerlConsole : public PerlFeatureMacro {
|
||||
private:
|
||||
static PerlConsole *registered;
|
||||
|
|
@ -52,6 +56,7 @@ namespace Automation4 {
|
|||
// Nested classes are messy, therefore we use them :)
|
||||
class Dialog : public wxDialog {
|
||||
private:
|
||||
friend class PerlConsole;
|
||||
wxTextCtrl *txt_out, *txt_hist, *txt_in;
|
||||
|
||||
public:
|
||||
|
|
@ -62,13 +67,11 @@ namespace Automation4 {
|
|||
long style = wxDEFAULT_DIALOG_STYLE, const wxString& name = _T("console_dialog"));
|
||||
|
||||
void InputEnter(wxCommandEvent& evt);
|
||||
void Echo(const wxString &str);
|
||||
};
|
||||
|
||||
Dialog *dialog;
|
||||
wxWindow *parent_window;
|
||||
|
||||
SV *cout;
|
||||
wxString evaluate(const wxString &str);
|
||||
|
||||
public:
|
||||
|
|
@ -76,16 +79,15 @@ namespace Automation4 {
|
|||
virtual ~PerlConsole();
|
||||
|
||||
static PerlConsole *GetConsole() { return registered; }
|
||||
Dialog *GetDialog() { return dialog; }
|
||||
|
||||
virtual bool Validate(AssFile *subs, const std::vector<int> &selected, int active) { return true; }
|
||||
virtual void Process(AssFile *subs, std::vector<int> &selected, int active, wxWindow * const progress_parent);
|
||||
|
||||
static wxString Evaluate(const wxString &str) { if(registered) return registered->evaluate(str); else return _T(""); }
|
||||
static wxString Evaluate(const wxString &str);
|
||||
static void Echo(const wxString &str);
|
||||
};
|
||||
|
||||
XS(register_console);
|
||||
XS(echo);
|
||||
|
||||
};
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -43,92 +43,27 @@
|
|||
namespace Automation4 {
|
||||
|
||||
|
||||
void xs_perl_misc(pTHX)
|
||||
{
|
||||
newXS("Aegisub::warn", log_warning, __FILE__);
|
||||
newXS("Aegisub::text_extents", text_extents, __FILE__);
|
||||
}
|
||||
|
||||
|
||||
/////////////
|
||||
// PerlLog
|
||||
//////////////////////
|
||||
// PerlProgressSink
|
||||
//
|
||||
PerlProgressSink *PerlProgressSink::sink;
|
||||
|
||||
XS(log_warning)
|
||||
PerlProgressSink::PerlProgressSink(wxWindow* parent, const wxString &title):
|
||||
ProgressSink(parent)
|
||||
{
|
||||
dXSARGS;
|
||||
wxString buffer;
|
||||
if(items >= 1) {
|
||||
buffer = wxString(SvPV_nolen(ST(0)), wx2pl);
|
||||
for(I32 i = 1; i < items; i++) {
|
||||
buffer << _T(" ") << wxString(SvPV_nolen(ST(i)), wx2pl);
|
||||
}
|
||||
if(sink) {
|
||||
sink->Destroy();
|
||||
}
|
||||
wxLogWarning(buffer);
|
||||
sink = this;
|
||||
SetTitle(_("Executing ") + title);
|
||||
}
|
||||
|
||||
PerlProgressSink::~PerlProgressSink()
|
||||
{
|
||||
sink = NULL;
|
||||
}
|
||||
|
||||
|
||||
////////////
|
||||
// Others
|
||||
//
|
||||
|
||||
XS(text_extents)
|
||||
{
|
||||
/* TODO badly: rewrite this shit */
|
||||
dXSARGS;
|
||||
|
||||
// Read the parameters
|
||||
SV *style; wxString text;
|
||||
if(items >= 2) {
|
||||
// Enough of them
|
||||
style = sv_mortalcopy(ST(0));
|
||||
text = wxString(SvPV_nolen(ST(1)), pl2wx);
|
||||
}
|
||||
else {
|
||||
// We needed 2 parameters at least!
|
||||
XSRETURN_UNDEF;
|
||||
}
|
||||
|
||||
// Get the AssStyle
|
||||
AssStyle *s;
|
||||
if(SvROK(style)) {
|
||||
// Create one from the hassh
|
||||
s = PerlAss::MakeAssStyle((HV*)SvRV(style));
|
||||
}
|
||||
else {
|
||||
// It's the name of the style
|
||||
wxString sn(SvPV_nolen(style), pl2wx);
|
||||
// We get it from the AssFile::top
|
||||
s = AssFile::top->GetStyle(sn);
|
||||
/* TODO: make it dig from the current hassh's styles */
|
||||
}
|
||||
|
||||
// The return parameters
|
||||
double width, height, descent, extlead;
|
||||
// The actual calculation
|
||||
if(!CalculateTextExtents(s, text, width, height, descent, extlead)) {
|
||||
/* TODO: diagnose error */
|
||||
XSRETURN_EMPTY;
|
||||
}
|
||||
|
||||
// Returns
|
||||
switch(GIMME_V) {
|
||||
case G_ARRAY:
|
||||
// List context
|
||||
EXTEND(SP, 4);
|
||||
XST_mNV(0, width);
|
||||
XST_mNV(1, height);
|
||||
XST_mNV(2, descent);
|
||||
XST_mNV(3, extlead);
|
||||
XSRETURN(4);
|
||||
break;
|
||||
case G_SCALAR:
|
||||
// Scalar context
|
||||
XSRETURN_NV(width);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
};
|
||||
|
||||
|
||||
|
|
@ -1,192 +0,0 @@
|
|||
// Copyright (c) 2008, Simone Cociancich
|
||||
// All rights reserved.
|
||||
//
|
||||
// Redistribution and use in source and binary forms, with or without
|
||||
// modification, are permitted provided that the following conditions are met:
|
||||
//
|
||||
// * Redistributions of source code must retain the above copyright notice,
|
||||
// this list of conditions and the following disclaimer.
|
||||
// * Redistributions in binary form must reproduce the above copyright notice,
|
||||
// this list of conditions and the following disclaimer in the documentation
|
||||
// and/or other materials provided with the distribution.
|
||||
// * Neither the name of the Aegisub Group nor the names of its contributors
|
||||
// may be used to endorse or promote products derived from this software
|
||||
// without specific prior written permission.
|
||||
//
|
||||
// THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
||||
// AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
||||
// IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
||||
// ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
||||
// LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
||||
// CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
||||
// SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
||||
// INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
||||
// CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
||||
// ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
// POSSIBILITY OF SUCH DAMAGE.
|
||||
//
|
||||
// -----------------------------------------------------------------------------
|
||||
//
|
||||
// AEGISUB
|
||||
//
|
||||
// Website: http://aegisub.cellosoft.com
|
||||
// Contact: mailto:jiifurusu@gmail.com
|
||||
//
|
||||
|
||||
|
||||
#ifdef WITH_PERL
|
||||
|
||||
|
||||
#include "auto4_perl.h"
|
||||
#include "ass_file.h"
|
||||
|
||||
|
||||
#ifdef __VISUALC__
|
||||
#pragma warning(disable: 4800)
|
||||
#endif
|
||||
|
||||
|
||||
namespace Automation4 {
|
||||
|
||||
|
||||
//////////////////////
|
||||
// PerlFeatureMacro
|
||||
//
|
||||
|
||||
PerlFeatureMacro::PerlFeatureMacro(const wxString &name, const wxString &description, PerlScript *own_script, SV *proc_sub, SV *val_sub):
|
||||
Feature(SCRIPTFEATURE_MACRO, name),
|
||||
FeatureMacro(name, description)
|
||||
{
|
||||
// We know what script we belong to ^_^
|
||||
script = own_script;
|
||||
|
||||
// And not surprisingly we have some callbacks too
|
||||
processing_sub = newSVsv(proc_sub);
|
||||
validation_sub = newSVsv(val_sub);
|
||||
}
|
||||
|
||||
PerlFeatureMacro::~PerlFeatureMacro() {
|
||||
// The macro subroutines get undefined
|
||||
/* This is crappy and creepy at the same time */
|
||||
/* TODO: thoroughly recheck the code */
|
||||
CV *cv = Nullcv;
|
||||
HV *hv = NULL;
|
||||
GV *gv = NULL;
|
||||
if(processing_sub) {
|
||||
cv = sv_2cv(processing_sub, &hv, &gv, 1);
|
||||
cv_undef(cv);
|
||||
if(hv) hv_undef(hv);
|
||||
}
|
||||
if(validation_sub) {
|
||||
cv = sv_2cv(validation_sub, &hv, &gv, 1);
|
||||
cv_undef(cv);
|
||||
if(hv) hv_undef(hv);
|
||||
}
|
||||
};
|
||||
|
||||
bool PerlFeatureMacro::Validate(AssFile *subs, const std::vector<int> &selected, int active)
|
||||
{
|
||||
// If there's no validation subroutine defined simply return true
|
||||
if(!validation_sub) return true;
|
||||
// otherwise...
|
||||
|
||||
// Sub lines
|
||||
AV *lines = PerlAss::MakeHasshLines(NULL, subs);
|
||||
// Selection array
|
||||
AV *selected_av = newAV();
|
||||
VECTOR_AV(selected, selected_av, int, iv);
|
||||
|
||||
// Sync script's vars with package's
|
||||
script->Activate();
|
||||
|
||||
bool ret = false;
|
||||
int c = 0;
|
||||
|
||||
// Prepare the stack
|
||||
dSP;
|
||||
|
||||
ENTER;
|
||||
SAVETMPS;
|
||||
|
||||
// Push the parameters on the stack
|
||||
PUSHMARK(SP);
|
||||
XPUSHs(sv_2mortal(newRV_noinc((SV*)lines)));
|
||||
XPUSHs(sv_2mortal(newRV_noinc((SV*)selected_av)));
|
||||
XPUSHs(sv_2mortal(newSViv(active)));
|
||||
PUTBACK;
|
||||
|
||||
// Call back the callback
|
||||
c = call_sv(validation_sub, G_EVAL | G_SCALAR);
|
||||
SPAGAIN;
|
||||
|
||||
if(SvTRUE(ERRSV)) {
|
||||
wxLogVerbose(wxString(SvPV_nolen(ERRSV), pl2wx));
|
||||
ret = false;
|
||||
}
|
||||
else {
|
||||
SV *wtf = sv_mortalcopy(POPs);
|
||||
ret = SvTRUE(wtf);
|
||||
}
|
||||
|
||||
// Tidy up everything
|
||||
PUTBACK;
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
script->Deactivate();
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
void PerlFeatureMacro::Process(AssFile *subs, std::vector<int> &selected, int active, wxWindow * const progress_parent)
|
||||
{
|
||||
// Reference to the hassh (lines)
|
||||
AV *lines = PerlAss::MakeHasshLines(NULL, subs);
|
||||
// Selection array
|
||||
AV *selected_av = newAV();
|
||||
VECTOR_AV(selected, selected_av, int, iv);
|
||||
|
||||
script->Activate();
|
||||
|
||||
// Prepare the stack
|
||||
dSP;
|
||||
|
||||
ENTER;
|
||||
SAVETMPS;
|
||||
|
||||
// Push the parameters on the stack
|
||||
PUSHMARK(SP);
|
||||
XPUSHs(sv_2mortal(newRV_noinc((SV*)lines)));
|
||||
XPUSHs(sv_2mortal(newRV_noinc((SV*)selected_av)));
|
||||
XPUSHs(sv_2mortal(newSViv(active)));
|
||||
PUTBACK;
|
||||
|
||||
// Call back the callback :)
|
||||
call_sv(processing_sub, G_EVAL | G_VOID);
|
||||
|
||||
if(SvTRUE(ERRSV)) {
|
||||
// Error
|
||||
wxLogError(wxString(SvPV_nolen(ERRSV), pl2wx));
|
||||
}
|
||||
else {
|
||||
// Non-error: recreate the hassh :S
|
||||
subs->FlagAsModified(GetName());
|
||||
PerlAss::MakeAssLines(subs, lines);
|
||||
// And reset selection vector
|
||||
selected.clear();
|
||||
AV_VECTOR(selected_av, selected, IV);
|
||||
CHOP_SELECTED(subs, selected);
|
||||
}
|
||||
|
||||
// Clean everything
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
script->Deactivate();
|
||||
}
|
||||
|
||||
|
||||
};
|
||||
|
||||
|
||||
#endif //WITH_PERL
|
||||
|
|
@ -38,26 +38,20 @@
|
|||
|
||||
|
||||
#include "auto4_perl.h"
|
||||
#include "auto4_perl_console.h"
|
||||
#include "version.h"
|
||||
#include "standard_paths.h"
|
||||
#include <wx/filename.h>
|
||||
#include <wx/utils.h>
|
||||
|
||||
|
||||
#ifdef __VISUALC__
|
||||
#pragma warning(disable: 4800)
|
||||
#endif
|
||||
|
||||
|
||||
namespace Automation4 {
|
||||
|
||||
|
||||
void xs_perl_script(pTHX)
|
||||
{
|
||||
newXS("Aegisub::Script::set_info", set_info, __FILE__);
|
||||
newXS("Aegisub::Script::register_macro", register_macro, __FILE__);
|
||||
}
|
||||
|
||||
|
||||
//////////////////////
|
||||
// PerlScript class
|
||||
//
|
||||
|
|
@ -69,12 +63,14 @@ namespace Automation4 {
|
|||
// Create a package name for the script
|
||||
package.Printf(_T("Aegisub::Script::p%lx"), this);
|
||||
|
||||
// local @INC; # lol
|
||||
inc_saved = newAV();
|
||||
|
||||
// Buggy
|
||||
reload = false;
|
||||
mtime = 0;
|
||||
|
||||
// Load the code
|
||||
// Load the script
|
||||
load();
|
||||
}
|
||||
|
||||
|
|
@ -92,7 +88,8 @@ namespace Automation4 {
|
|||
|
||||
void PerlScript::load()
|
||||
{
|
||||
wxLogTrace(_T("Loading %*s inside %s"), 0, GetFilename().c_str(), package.c_str());
|
||||
wxTRACE_METH(load);
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("filename = '%s', package = '%s'"), GetFilename().c_str(), package.c_str());
|
||||
|
||||
// Feed some defaults into the script info
|
||||
name = GetPrettyFilename().BeforeLast(_T('.'));
|
||||
|
|
@ -100,10 +97,6 @@ namespace Automation4 {
|
|||
author = wxGetUserId();
|
||||
version = GetAegisubShortVersionString();
|
||||
|
||||
// Get file's mtime
|
||||
//struct stat s;
|
||||
//stat(GetFilename().mb_str(wxConvLibc), &s);
|
||||
//mtime = s.st_mtime;
|
||||
wxFileName fn(GetFilename());
|
||||
wxDateTime mod;
|
||||
fn.GetTimes(NULL,&mod,NULL);
|
||||
|
|
@ -125,8 +118,10 @@ namespace Automation4 {
|
|||
|
||||
// Let's eval the 'boxed' script
|
||||
eval_pv(_script.mb_str(wx2pl), 0);
|
||||
// and check on errors
|
||||
if(SvTRUE(ERRSV)) {
|
||||
wxLogError(wxString(SvPV_nolen(ERRSV), pl2wx));
|
||||
description = wxString(SvPV_nolen(ERRSV), pl2wx);
|
||||
wxLogError(description); // Remove?
|
||||
loaded = false;
|
||||
}
|
||||
else {
|
||||
|
|
@ -135,10 +130,13 @@ namespace Automation4 {
|
|||
|
||||
// The script has done loading (running)
|
||||
deactivate();
|
||||
|
||||
wxTRACE_RET(load);
|
||||
}
|
||||
|
||||
void PerlScript::unload() {
|
||||
wxLogTrace(_T("Unloading %*s(%s)"), 0, name, package.c_str());
|
||||
wxTRACE_METH(unload);
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("name = '%s' package = '%s'"), name.c_str(), package.c_str());
|
||||
|
||||
// Deinstantiate(?) all features and clear the vector
|
||||
for(; !features.empty(); features.pop_back()) {
|
||||
|
|
@ -150,14 +148,18 @@ namespace Automation4 {
|
|||
hv_undef((HV*)gv_stashpv(package.mb_str(wx2pl), 0));
|
||||
|
||||
// Officially finished with unloading
|
||||
wxLogDebug(_T("'%s' (%s) unloaded"), name.c_str(), package.c_str());
|
||||
loaded = false;
|
||||
wxTRACE_RET(unload);
|
||||
}
|
||||
|
||||
void PerlScript::activate(PerlScript *script)
|
||||
{
|
||||
wxLogTrace(_T("Activating %*s(%s)"), 0, script->GetName(), script->GetPackage().c_str());
|
||||
wxTRACE_FUNC(PerlScript::activate);
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("name = '%s', package = '%s'"), script->GetName().c_str(), script->GetPackage().c_str());
|
||||
|
||||
// Check if the source file is newer
|
||||
/* FIX */
|
||||
if(script->reload) {
|
||||
// struct stat s;
|
||||
// stat(script->GetFilename().mb_str(wxConvLibc), &s);
|
||||
|
|
@ -165,14 +167,13 @@ namespace Automation4 {
|
|||
wxDateTime mod;
|
||||
fn.GetTimes(NULL,&mod,NULL);
|
||||
if(script->mtime != mod.GetTicks()) {
|
||||
printf("%d != %d !\n", script->mtime, mod.GetTicks());
|
||||
wxLogVerbose(_("Reloading %s because the file on disk (%s) changed"), script->GetName().c_str(), script->GetFilename().c_str());
|
||||
PerlLogVerbose(wxString::Format(_("Reloading %s because the file on disk (%s) changed"), script->GetName().c_str(), script->GetFilename().c_str()));
|
||||
script->Reload();
|
||||
}
|
||||
}
|
||||
|
||||
// Hooking $SIG{__WARN__}
|
||||
wxLogTrace(_T("Hooking $SIG{__WARN__}"), 0);
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("$SIG{__WARN__} = \\&Aegisub::warn"));
|
||||
eval_pv("$SIG{__WARN__} = \\&Aegisub::warn", 1);
|
||||
|
||||
// Add the script's includes to @INC
|
||||
|
|
@ -186,27 +187,34 @@ namespace Automation4 {
|
|||
// Make room in @INC
|
||||
I32 inc_count = script->include_path.GetCount();
|
||||
av_unshift(inc_av, inc_count);
|
||||
// Add the include paths
|
||||
// Add the automation include paths
|
||||
for(I32 i = 0; i < inc_count; i++) {
|
||||
wxLogDebug(_T("Adding %d to @INC"), script->include_path.Item(i).c_str());
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("$INC[%d] = '%s'"), i, script->include_path.Item(i).c_str());
|
||||
AV_TOUCH(inc_av, i)
|
||||
AV_STORE(newSVpv(script->include_path.Item(i).mb_str(wx2pl), 0));
|
||||
}
|
||||
wxLogTrace(_T("@INC = ( %*s )"), 0, SvPV_nolen(eval_pv("\"@INC\"", 1)));
|
||||
wxLogDebug(_T("@INC = ( %s )"), wxString(SvPV_nolen(eval_pv("\"@INC\"", 1)), pl2wx).c_str());
|
||||
}
|
||||
else {
|
||||
wxLogWarning(_("Unable to add the automation include path(s) to @INC, you may have problems running the script."));
|
||||
PerlLogWarning(_("Unable to add the automation include path(s) to @INC: the script's code may not compile or execute properly."));
|
||||
}
|
||||
|
||||
// Require the core modules
|
||||
load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Aegisub", 7), NULL);
|
||||
load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Aegisub::Progress", 17), NULL);
|
||||
//load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Aegisub::Script", 15), NULL);
|
||||
|
||||
// Set the values of script vars
|
||||
script->WriteVars();
|
||||
|
||||
active = script;
|
||||
wxLogDebug(_T("%s(%p) activated"), active->GetName().c_str(), active);
|
||||
wxLogDebug(_T("'%s' (%p) activated"), active->GetName().c_str(), active);
|
||||
}
|
||||
|
||||
void PerlScript::deactivate()
|
||||
{
|
||||
wxLogTrace(_T("Deactivating %*s (%s)"), 0, active->GetName().c_str(), active->GetPackage().c_str());
|
||||
wxTRACE_FUNC(PerlScript::deactivate);
|
||||
wxLogTrace(wxTRACE_AutoPerl, _T("name = '%s', package = '%s'"), active->GetName().c_str(), active->GetPackage().c_str());
|
||||
|
||||
// Revert @INC to its value before the script activation
|
||||