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 2008-01-24 17:20:47 +00:00
parent 260c2b5cb2
commit b2518f9ca1
13 changed files with 1007 additions and 499 deletions

View file

@ -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

View file

@ -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
}
}

View file

@ -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()
};

View file

@ -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) {

View file

@ -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());
}
}
};

View file

@ -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);
};

View file

@ -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);
}
}
};

View file

@ -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

View file

@ -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