367 lines
10 KiB
C++
367 lines
10 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 "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
|
|
//
|
|
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);
|
|
|
|
inc_saved = newAV();
|
|
|
|
reload = false;
|
|
mtime = 0;
|
|
|
|
// Load the code
|
|
load();
|
|
}
|
|
|
|
PerlScript::~PerlScript()
|
|
{
|
|
unload();
|
|
}
|
|
|
|
void PerlScript::Reload()
|
|
{
|
|
unload();
|
|
reload = false;
|
|
load();
|
|
}
|
|
|
|
void PerlScript::load()
|
|
{
|
|
wxLogTrace(_T("Loading %*s inside %s"), 0, GetFilename().c_str(), package.c_str());
|
|
|
|
// Feed some defaults into the script info
|
|
name = GetPrettyFilename().BeforeLast(_T('.'));
|
|
description = _("Perl script");
|
|
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);
|
|
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("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);
|
|
if(SvTRUE(ERRSV)) {
|
|
wxLogError(wxString(SvPV_nolen(ERRSV), pl2wx));
|
|
loaded = false;
|
|
}
|
|
else {
|
|
loaded = true;
|
|
}
|
|
|
|
// The script has done loading (running)
|
|
deactivate();
|
|
}
|
|
|
|
void PerlScript::unload() {
|
|
wxLogTrace(_T("Unloading %*s(%s)"), 0, name, 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
|
|
loaded = false;
|
|
}
|
|
|
|
void PerlScript::activate(PerlScript *script)
|
|
{
|
|
wxLogTrace(_T("Activating %*s(%s)"), 0, script->GetName(), script->GetPackage().c_str());
|
|
|
|
// Check if the source file is newer
|
|
if(script->reload) {
|
|
// struct stat s;
|
|
// stat(script->GetFilename().mb_str(wxConvLibc), &s);
|
|
wxFileName fn(script->GetFilename());
|
|
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());
|
|
script->Reload();
|
|
}
|
|
}
|
|
|
|
// Hooking $SIG{__WARN__}
|
|
wxLogTrace(_T("Hooking $SIG{__WARN__}"), 0);
|
|
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 include paths
|
|
for(I32 i = 0; i < inc_count; i++) {
|
|
wxLogDebug(_T("Adding %d to @INC"), 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)));
|
|
}
|
|
else {
|
|
wxLogWarning(_("Unable to add the automation include path(s) to @INC, you may have problems running the script."));
|
|
}
|
|
|
|
// Set the values of script vars
|
|
script->WriteVars();
|
|
active = script;
|
|
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());
|
|
|
|
// 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);
|
|
wxLogTrace(_T("@INC = ( %*s )"), 0, SvPV_nolen(eval_pv("\"@INC\"", 1)));
|
|
av_clear(active->inc_saved);
|
|
}
|
|
}
|
|
|
|
// Read the values of script vars
|
|
active->ReadVars();
|
|
|
|
// Unooking $SIG{__WARN__}
|
|
wxLogTrace(_T("Releasing $SIG{__WARN__} hook"), 0);
|
|
eval_pv("undef $SIG{__WARN__}", 1);
|
|
|
|
wxLogDebug(_T("%s(%p) deactivated"), active->GetName().c_str(), active);
|
|
active = NULL;
|
|
}
|
|
|
|
void PerlScript::AddFeature(Feature *feature)
|
|
{
|
|
features.push_back(feature);
|
|
wxLogDebug(_T("Added %s to %s(%s)'s features"), feature->GetName(), name, package);
|
|
}
|
|
|
|
void PerlScript::DeleteFeature(Feature *feature)
|
|
{
|
|
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(), name, package);
|
|
features.erase(it);
|
|
}
|
|
}
|
|
|
|
void PerlScript::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
|
|
{
|
|
// 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));
|
|
}
|
|
|
|
XS(set_info)
|
|
{
|
|
dXSARGS;
|
|
PerlScript *active = PerlScript::GetActive();
|
|
if(active) {
|
|
// Update the object's vars
|
|
active->ReadVars();
|
|
|
|
// 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(register_macro)
|
|
{
|
|
dXSARGS;
|
|
PerlScript *active = PerlScript::GetActive();
|
|
if(active && items >= 3) {
|
|
wxString name, description;
|
|
SV *proc_sub = NULL, *val_sub = NULL;
|
|
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;
|
|
}
|
|
|
|
|
|
};
|
|
|
|
|
|
#endif //WITH_PERL
|