Aegisub/aegisub/auto4_perl_script.cpp
Rodrigo Braz Monteiro cee958b2d3 Raised the warning level on MSVC8 to 4, and fixed several warnings caused by that.
Originally committed to SVN as r2045.
2008-03-13 19:12:55 +00:00

473 lines
13 KiB
C++

// 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 "version.h"
#include "standard_paths.h"
#include <wx/filename.h>
#include <wx/utils.h>
#ifdef __VISUALC__
#pragma warning(disable: 4800)
#pragma warning(disable: 4706)
#endif
namespace Automation4 {
//////////////////////
// PerlScript class
//
PerlScript *PerlScript::active = NULL;
PerlScript::PerlScript(const wxString &filename):
Script(filename)
{
// 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 script
load();
}
PerlScript::~PerlScript()
{
unload();
}
void PerlScript::Reload()
{
unload();
reload = false;
load();
}
void PerlScript::load()
{
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('.'));
description = _("Perl script");
author = wxGetUserId();
version = GetAegisubShortVersionString();
wxFileName fn(GetFilename());
wxDateTime mod;
fn.GetTimes(NULL,&mod,NULL);
mtime = mod.GetTicks();
// Create the script's package
gv_stashpv(package.mb_str(wx2pl), 1);
// Set this script as active
activate(this);
// 'Enclose' the script into its package
wxString _script = _T("package ") + package + _T(";\n")
_T("require Aegisub; require Aegisub::Script; require Aegisub::Progress;") // Core modules
_T("our ($_script_reload, $_script_path, $_script_package);\n") // Internal vars
_T("our ($script_name, $script_description, $script_author, $script_version);\n") // Package info
_T("open SCRIPT, $_script_path;\n") // Open the script file
_T("local @_source = <SCRIPT>;\n") // read the source
_T("close SCRIPT;\n") // close the file
_T("eval \"@{_source}\n1;\" || die $@;"); // eval the source
// Let's eval the 'boxed' script
eval_pv(_script.mb_str(wx2pl), 0);
SV *_err = newSVsv(ERRSV); // We need this later
// Done running
deactivate();
// and check on errors
if(SvTRUE(_err)) {
description = wxString(SvPV_nolen(_err), pl2wx);
loaded = false;
}
else {
loaded = true;
}
wxTRACE_RET(load);
}
void PerlScript::unload() {
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()) {
delete (Feature*) features.back();
}
features.clear();
// Dismiss the package's stash
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)
{
wxTRACE_FUNC(PerlScript::activate);
wxLogTrace(wxTRACE_AutoPerl, _T("name = '%s', package = '%s'"), script->GetName().c_str(), script->GetPackage().c_str());
// Hooking $SIG{__WARN__}
wxLogTrace(wxTRACE_AutoPerl, _T("$SIG{__WARN__} = \\&Aegisub::warn"));
eval_pv("$SIG{__WARN__} = \\&Aegisub::warn", 1);
// Add the script's includes to @INC
AV *inc_av = get_av("main::INC", 0);
if(inc_av) {
dAV;
// Save the previous includes
AV_COPY(inc_av, script->inc_saved);
// Make room in @INC
I32 inc_count = script->include_path.GetCount();
av_unshift(inc_av, inc_count);
// Add the automation include paths
for(I32 i = 0; i < inc_count; i++) {
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));
}
wxLogDebug(_T("@INC = ( %s )"), wxString(SvPV_nolen(eval_pv("\"@INC\"", 1)), pl2wx).c_str());
}
else {
PerlLogWarning(_("Unable to add the automation include path(s) to @INC: the script's code may not compile or execute properly."));
}
// Set the values of script vars
script->WriteVars();
active = script;
wxLogDebug(_T("'%s' (%p) activated"), active->GetName().c_str(), active);
}
void PerlScript::deactivate()
{
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
AV *inc_av = get_av("main::INC", 0);
if(inc_av) {
dAV;
// Reset @INC
if(av_len(active->inc_saved) >= 0) {
// If there's a saved one
AV_COPY(active->inc_saved, inc_av);
wxLogDebug(_T("@INC = ( %s )"), wxString(SvPV_nolen(eval_pv("\"@INC\"", 1)), pl2wx).c_str());
av_clear(active->inc_saved);
}
}
// Read the values of script vars
active->ReadVars();
// If reload flag is set...
/* STILL BROKEN :< */
if(active->reload) {
// check if the source file on disk changed
wxFileName fn(active->GetFilename());
wxDateTime mod;
fn.GetTimes(NULL,&mod,NULL);
if(active->mtime != mod.GetTicks()) {
// and reload the script
PerlLogVerbose(wxString::Format(_("Reloading %s because the file on disk (%s) changed."), active->GetName().c_str(), active->GetFilename().c_str()));
active->Reload();
}
}
// Unhooking $SIG{__WARN__}
wxLogTrace(wxTRACE_AutoPerl, _T("undef $SIG{__WARN__}"));
eval_pv("undef $SIG{__WARN__}", 1);
wxLogDebug(_T("%s(%p) deactivated"), active->GetName().c_str(), active);
active = NULL;
}
void PerlScript::AddFeature(Feature *feature)
{
wxTRACE_METH(AddFeature);
features.push_back(feature);
wxLogDebug(_T("Added '%s' to '%s'(%s)'s features"), feature->GetName().c_str(), name.c_str(), package.c_str());
}
void PerlScript::DeleteFeature(Feature *feature)
{
wxTRACE_METH(DeleteFeature);
for(std::vector<Feature*>::iterator it = features.begin(); it != features.end(); it++)
if(*it == feature) {
delete feature;
wxLogDebug(_T("Deleted '%s' from '%s'(%s)'s features"), feature->GetName().c_str(), name.c_str(), package.c_str());
features.erase(it);
}
}
void PerlScript::ReadVars()
{
wxTRACE_METH(ReadVars);
// This will get anything inside it °_°
SV *whore = NULL;
// All the vars' names will stick to it #_#
wxString bitch;
bitch = package + _T("::script_name");
whore = get_sv(bitch.mb_str(wx2pl), 0);
if(whore) name = wxString(SvPV_nolen(whore), pl2wx);
bitch = package + _T("::script_description");
whore = get_sv(bitch.mb_str(wx2pl), 0);
if(whore) description = wxString(SvPV_nolen(whore), pl2wx);
bitch = package + _T("::script_author");
whore = get_sv(bitch.mb_str(wx2pl), 0);
if(whore) author = wxString(SvPV_nolen(whore), pl2wx);
bitch = package + _T("::script_version");
whore = get_sv(bitch.mb_str(wx2pl), 0);
if(whore) version = wxString(SvPV_nolen(whore), pl2wx);
//bitch = package + _T("::_script_reload");
//whore = get_sv(bitch.mb_str(wx2pl), 0);
//if(whore) reload = SvTRUE(whore);
}
void PerlScript::WriteVars() const
{
wxTRACE_METH(WriteVars);
// Somewhat as above
SV *whore = NULL;
wxString bitch;
bitch = package + _T("::_script_package");
whore = get_sv(bitch.mb_str(wx2pl), 1);
sv_setpv(whore, package.mb_str(wx2pl));
bitch = package + _T("::_script_path");
whore = get_sv(bitch.mb_str(wx2pl), 1);
sv_setpv(whore, GetFilename().mb_str(wx2pl));
bitch = package + _T("::_script_reload");
whore = get_sv(bitch.mb_str(wx2pl), 1);
sv_setiv(whore, int(reload));
bitch = package + _T("::script_name");
whore = get_sv(bitch.mb_str(wx2pl), 1);
sv_setpv(whore, name.mb_str(wx2pl));
bitch = package + _T("::script_description");
whore = get_sv(bitch.mb_str(wx2pl), 1);
sv_setpv(whore, description.mb_str(wx2pl));
bitch = package + _T("::script_author");
whore = get_sv(bitch.mb_str(wx2pl), 1);
sv_setpv(whore, author.mb_str(wx2pl));
bitch = package + _T("::script_version");
whore = get_sv(bitch.mb_str(wx2pl), 1);
sv_setpv(whore, version.mb_str(wx2pl));
}
//////////////////////
// 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
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);
// Activate the owner script
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;
// Deactivate the script
script->Deactivate();
return ret;
}
void PerlFeatureMacro::Process(AssFile *subs, std::vector<int> &selected, int active, wxWindow * const progress_parent)
{
/* TODO: extend the progress window 'coverage' */
// Convert the AssFile::Line to perl stuff
AV *lines = PerlAss::MakeHasshLines(NULL, subs);
// Same with the selection array
AV *selected_av = newAV();
VECTOR_AV(selected, selected_av, int, iv);
// Prepare the stack
dSP;
ENTER;
SAVETMPS;
// Push the arguments onto the stack
PUSHMARK(SP);
SV* lines_ref = sv_2mortal(newRV_noinc((SV*)lines));
XPUSHs(lines_ref);
SV* selected_ref = sv_2mortal(newRV_noinc((SV*)selected_av));
XPUSHs(selected_ref);
XPUSHs(sv_2mortal(newSViv(active)));
PUTBACK;
// Create a progress window
PerlProgressSink *ps = new PerlProgressSink(progress_parent, GetName());
// Start the callback thread
script->Activate();
PerlThread call(processing_sub, G_EVAL | G_VOID);
// Show the progress window until it is dismissed
ps->ShowModal();
// Now wait the thread to return
call.Wait();
script->Deactivate();
if(!SvTRUE(ERRSV)) {
// Show progress sink again
ps->Show(true);
ps->SetTask(_("Saving changes"));
// Recreate the ass :S
subs->FlagAsModified(GetName());
PerlAss::MakeAssLines(subs, (AV*)SvRV(lines_ref));
// And reset selection vector
selected.clear();
AV_VECTOR((AV*)SvRV(selected_ref), selected, IV);
CHOP_SELECTED(subs, selected);
ps->Hide();
}
// Delete the progress sink
ps->Destroy();
// Clean the call stack
FREETMPS;
LEAVE;
}
};
#endif //WITH_PERL