Aegisub/aegisub/auto4_perl_script.cpp

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