Originally committed to SVN as r3205.
This commit is contained in:
Niels Martin Hansen
parent
af5df13f00
commit
31657f94da
28 changed files with 0 additions and 5473 deletions
|
|
@ -1,62 +0,0 @@
|
|||
#!/usr/bin/perl
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use Aegisub; # don't forget this
|
||||
|
||||
$script_name = "Add/remove edgeblur macro (Perl version)";
|
||||
$script_description = "A demo macro showing how to do simple macros in Auto4-Perl";
|
||||
$script_author = "Karl Blomster";
|
||||
$script_version = "1";
|
||||
|
||||
|
||||
# this is a line-by-line translation of the Lua macro of the same name.
|
||||
sub add_edgeblur {
|
||||
# get the arguments; they are all references (important later)
|
||||
my ($subtitles, $selected_lines, $active_line) = @_;
|
||||
|
||||
# loop over the selected lines (note the dereferencing)
|
||||
foreach my $lineno ( @{$selected_lines} ) {
|
||||
# $line now contains a reference to the line we're working on.
|
||||
# Note that the "line" is actually a hash with the dialogue line fields as keys.
|
||||
my $line = $subtitles->[$lineno];
|
||||
# Tack on {\be1} to the start of the "text" field...
|
||||
$line->{"text"} = '{\\be1}' . $line->{"text"};
|
||||
# And write our $line back to the file.
|
||||
$subtitles->[$lineno] = $line;
|
||||
}
|
||||
|
||||
# This ain't implemented yet :(
|
||||
# Aegisub::Script::set_undo_point("Add edgeblur");
|
||||
}
|
||||
|
||||
|
||||
# This routine is NOT a Lua translation and may therefore seem more perlish. :>
|
||||
sub remove_edgeblur {
|
||||
# same as above
|
||||
my ($subtitles, $selected_lines, $active_line) = @_;
|
||||
|
||||
foreach my $lineno ( @{$selected_lines} ) {
|
||||
# Since we're only going to change the text field of the line,
|
||||
# why bother copying the entire line? We copy only the text field instead.
|
||||
# We could also do stuff directly on $subtitles->[$lineno]->{"text"} but
|
||||
# that's too long to write and is also risky if you blow something up.
|
||||
my $text = $subtitles->[$lineno]->{"text"};
|
||||
|
||||
# remove any \be1 tags contained in the first {} block
|
||||
$text =~ s!^\{(.*?)\\be1(.*?)\}!\{${1}${2}\}!;
|
||||
# if that leaves nothing in it, remove it
|
||||
$text =~ s!^\{\}!!;
|
||||
|
||||
# write back
|
||||
$subtitles->[$lineno]->{"text"} = $text;
|
||||
}
|
||||
|
||||
# Still not implemented :/
|
||||
# Aegisub::Script::set_undo_point("Remove edgeblur");
|
||||
}
|
||||
|
||||
|
||||
# Register macros with Aegisub
|
||||
Aegisub::Script::register_macro("Add edgeblur (Perl)", "Adds \\be1 tags to all selected lines", \&add_edgeblur);
|
||||
Aegisub::Script::register_macro("Remove edgeblur (Perl)", "Removes \\be1 tags from the start of all selected lines", \&remove_edgeblur);
|
||||
|
|
@ -1,62 +0,0 @@
|
|||
load 'karaoke.rb'
|
||||
load 'utils.rb'
|
||||
|
||||
include Aegisub
|
||||
|
||||
$script_name = "simple k-replacer"
|
||||
$script_description = "k-replacer test"
|
||||
$script_author = "Pomyk"
|
||||
$script_version = "1"
|
||||
|
||||
register_macro("Simple k-replacer", "k-replacer macro", :k_replace_macro, nil)
|
||||
register_filter("Simple k-replacer", "k-replacer filter", 100, :k_replace_filter, :k_replace_cfg)
|
||||
|
||||
|
||||
def k_replace_macro(subs, sel, act)
|
||||
|
||||
cfg = k_replace_cfg(subs, nil)
|
||||
ok, opt = display_dialog(cfg, nil)
|
||||
return if not ok # cancelled
|
||||
|
||||
write_options(subs, {$script_name => opt})
|
||||
subs.each do |l|
|
||||
k_replace(l, opt[:templ], opt[:strip]) if l[:class] == :dialogue && # replace if its dialogue
|
||||
(opt[:style] =="" || l[:style] == opt[:style]) # and has the right style
|
||||
end
|
||||
return subs
|
||||
end
|
||||
|
||||
def k_replace_filter(subs, opt)
|
||||
subs.each do |l|
|
||||
k_replace(l, opt[:templ], opt[:strip]) if l[:class] == :dialogue && # replace if its dialogue
|
||||
opt[:style] =="" || l[:style] == opt[:style] # and has the right style
|
||||
end
|
||||
return subs
|
||||
end
|
||||
|
||||
def k_replace_cfg(subs, opt)
|
||||
styles = []
|
||||
subs.each { |l| # read style names
|
||||
styles << l[:name] if l[:class] == :style
|
||||
break if l[:class] == :dialogue
|
||||
}
|
||||
header_text = <<-head
|
||||
Expressions are enclosed in % pairs.
|
||||
Variables:
|
||||
$start = Start-time of syllable (ms)
|
||||
$end = End-time of syllable (ms)
|
||||
$mid = Time midways through the syllable (ms)
|
||||
$dur = Duration of syllable (cs)
|
||||
Calculation example:
|
||||
\\t($start,%$start+$dur*2%,\\fscx110)
|
||||
\\t(%$start+$dur*2%,$end,\\fscx90)
|
||||
head
|
||||
opt ||= {}
|
||||
cfg = ScriptCfg.new # helper class for building dialogs
|
||||
cfg.header header_text, :x => 1, :width => 1
|
||||
cfg.edit :templ, "template", :text => opt[:templ]
|
||||
cfg.dropdown :style, "Style", :items => styles, :value => opt[:style]
|
||||
cfg.checkbox :strip, "", :label => "Strip tags?", :value => (opt[:strip] == "true" ? true : false)
|
||||
cfg.to_ary # convert to array
|
||||
end
|
||||
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
# Perl console script
|
||||
# by Simone Cociancich
|
||||
# This script simply call the registration function for the builtin perl console
|
||||
# the perl console is chiefly intended as a development and debug tool
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
Aegisub::Script::set_info(
|
||||
'Perl console',
|
||||
"\nThis script provides a console for messing with the perl engine \\^^/
|
||||
(if you break something don't complain >:)",
|
||||
'ShB');
|
||||
|
||||
use Aegisub::PerlConsole;
|
||||
register_console();
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
package Aegisub;
|
||||
use Exporter 'import';
|
||||
|
||||
@EXPORT = qw( text_extents
|
||||
log_fatal log_error log_warning log_hint log_debug log_trace log_message );
|
||||
@EXPORT_OK = qw( LOG_FATAL LOG_ERROR LOG_WARNING LOG_HINT LOG_DEBUG LOG_TRACE LOG_MESSAGE
|
||||
LOG_WX
|
||||
log warn );
|
||||
|
||||
# Constants
|
||||
sub LOG_FATAL { 0 }
|
||||
sub LOG_ERROR { 1 }
|
||||
sub LOG_WARNING { 2 }
|
||||
sub LOG_HINT { 3 }
|
||||
sub LOG_DEBUG { 4 }
|
||||
sub LOG_TRACE { 5 }
|
||||
sub LOG_MESSAGE { 6 }
|
||||
|
||||
sub LOG_WX { 8 }
|
||||
|
||||
# Shortcut functions
|
||||
sub log_fatal { Aegisub::log LOG_FATAL, @_; }
|
||||
sub log_error { Aegisub::log LOG_ERROR, @_; }
|
||||
sub log_warning { Aegisub::log LOG_WARNING, @_; }
|
||||
sub log_hint { Aegisub::log LOG_HINT, @_; }
|
||||
sub log_debug { Aegisub::log LOG_DEBUG, @_; }
|
||||
sub log_trace { Aegisub::log LOG_TRACE, @_; }
|
||||
sub log_message { Aegisub::log LOG_MESSAGE, @_; }
|
||||
|
||||
# wxLog variety
|
||||
sub wxlog {
|
||||
if($_[0] =~ /^\d+$/) {
|
||||
$_[0] |= 0x8;
|
||||
}
|
||||
else {
|
||||
unshift @_, LOG_MESSAGE | LOG_WX;
|
||||
}
|
||||
Aegisub::log @_;
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
package Aegisub::PerlConsole;
|
||||
use Exporter 'import';
|
||||
|
||||
@EXPORT = qw( echo register_console );
|
||||
|
||||
1;
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
package Aegisub::Progress;
|
||||
use Exporter 'import';
|
||||
|
||||
@EXPORT = qw( set_progress set_task set_title is_cancelled );
|
||||
@EXPORT_OK = qw( set task title );
|
||||
|
||||
sub set { set_progress @_ }
|
||||
sub task { set_task @_ }
|
||||
sub title { set_title @_ }
|
||||
|
||||
1;
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
package Aegisub::Script;
|
||||
use Exporter 'import';
|
||||
|
||||
@EXPORT = qw( register_macro set_info );
|
||||
|
||||
1;
|
||||
|
|
@ -1,251 +0,0 @@
|
|||
#/usr/bin/perl
|
||||
|
||||
#########
|
||||
#
|
||||
# Written by Karl Blomster (TheFluff) 2008.
|
||||
# (OK, mostly just a translation of utils-auto4.lua.)
|
||||
#
|
||||
# This script is hereby given into the public domain.
|
||||
# If that is not possible according to local laws, I, the author, hereby grant
|
||||
# anyone the right to use this script for any purpose.
|
||||
#
|
||||
#########
|
||||
|
||||
package Auto4Utils;
|
||||
require Exporter;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
use feature ":5.10";
|
||||
use utf8; # just to be safe
|
||||
use POSIX (); # gah, we only need floor(), no need to import all of IEEE 1003.1
|
||||
|
||||
|
||||
# Export everything by default
|
||||
our @ISA = qw(Exporter);
|
||||
our @EXPORT = qw(extract_color alpha_from_style color_from_style HSV_to_RGB HSL_to_RGB interpolate_color interpolate_alpha
|
||||
ass_color ass_alpha ass_style_color string_trim clamp interpolate);
|
||||
|
||||
|
||||
# Given 3 integers R,G,B, returns ASS formatted &HBBGGRR& string
|
||||
sub ass_color {
|
||||
my ($r, $g, $b) = @_;
|
||||
return(sprintf("&H%02X%02X%02X&", $b, $g, $r));
|
||||
}
|
||||
# Perlier version of that:
|
||||
# sub ass_color { return sprintf "&H%02X%02X%02X&", reverse }
|
||||
# I don't think reverse reverses @_ by default, rats :(
|
||||
|
||||
# Convert decimal alpha value to &H00& form
|
||||
sub ass_alpha {
|
||||
return(sprintf("&H%02X&", shift(@_)));
|
||||
}
|
||||
|
||||
# Given 4 integers R,G,B,A, returns a v4+ formatted style color string
|
||||
# (note no terminating &)
|
||||
sub ass_style_color {
|
||||
my ($r, $g, $b, $a) = @_;
|
||||
return(sprintf("&H%02X%02X%02X%02X", $a, $b, $g, $r));
|
||||
}
|
||||
|
||||
# Tries its best to convert a string to 4 integers R,G,B,A.
|
||||
# Returns them in that order if it succeeds, or undef if it can't do it.
|
||||
# Useless in scalar context.
|
||||
sub extract_color {
|
||||
my $string = shift(@_);
|
||||
|
||||
# This here thingie is a switch statement. Magic!
|
||||
given ( $string ) {
|
||||
# try v4+ style (ABGR)
|
||||
when ( /\&H([[:xdigit:]]{2})([[:xdigit:]]{2})([[:xdigit:]]{2})([[:xdigit:]]{2})/i ) {
|
||||
return(hex($4), hex($3), hex($2), hex($1));
|
||||
}
|
||||
# color override? (BGR)
|
||||
when ( /\&H([[:xdigit:]]{2})([[:xdigit:]]{2})([[:xdigit:]]{2})\&H/i ) {
|
||||
return(0, hex($3), hex($2), hex($1));
|
||||
}
|
||||
# alpha override? (A)
|
||||
# (bug: bogus results with \c&H<hex>& with the first four zeros omitted)
|
||||
when ( /\&H([[:xdigit:]]{2})\&/i ) {
|
||||
return(hex($1), 0, 0, 0);
|
||||
}
|
||||
# try HTML format for laffs (RGB)
|
||||
when ( /\#([[:xdigit:]]{2})([[:xdigit:]]{2})?([[:xdigit:]]{2})?/i ) {
|
||||
return(0, (hex($2) or 0), (hex($2) or 0), (hex($3) or 0));
|
||||
}
|
||||
default {
|
||||
return(undef, undef, undef, undef);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Given a a style color string, returns the alpha part formatted as override
|
||||
sub alpha_from_style {
|
||||
my $color_string = shift(@_);
|
||||
my ($r, $g, $b, $a) = extract_color($color_string);
|
||||
return(ass_alpha($a or 0));
|
||||
}
|
||||
|
||||
# Given a style color string, returns the color part formatted as override
|
||||
sub color_from_style {
|
||||
my $color_string = shift(@_);
|
||||
my ($r, $g, $b, $a) = extract_color($color_string);
|
||||
return(ass_color(($r or 0), ($g or 0), ($b or 0)));
|
||||
}
|
||||
|
||||
|
||||
# Converts 3 integers H, S, V (hue, saturation, value) to R, G, B
|
||||
sub HSV_to_RGB {
|
||||
my ($H, $S, $V) = @_;
|
||||
my ($r, $g, $b);
|
||||
|
||||
# saturation is zero, make grey
|
||||
if ($S == 0) {
|
||||
$r = $V * 255;
|
||||
$r = clamp($r, 0, 255);
|
||||
($g, $b) = ($r, $r);
|
||||
}
|
||||
# else calculate color
|
||||
else {
|
||||
# calculate subvalues
|
||||
$H = $H % 360; # put $h in range [0,360]
|
||||
my $Hi = POSIX::floor($H/60);
|
||||
my $f = $H/60 - $Hi;
|
||||
my $p = $V * (1 - $S);
|
||||
my $q = $V * (1 - $f * $S);
|
||||
my $t = $V * (1 - (1 - $f) * $S);
|
||||
|
||||
# do math based on hue index
|
||||
if ($Hi == 0) { $r = $V*255; $g = $t*255; $b = $p*255; }
|
||||
elsif ($Hi == 1) { $r = $q*255; $g = $V*255; $b = $p*255; }
|
||||
elsif ($Hi == 2) { $r = $p*255; $g = $V*255; $b = $t*255; }
|
||||
elsif ($Hi == 3) { $r = $p*255; $g = $q*255; $b = $V*255; }
|
||||
elsif ($Hi == 4) { $r = $t*255; $g = $p*255; $b = $V*255; }
|
||||
elsif ($Hi == 5) { $r = $V*255; $g = $p*255; $b = $q*255; }
|
||||
# TODO: replace this with Aegisub::Script::debug_out() or whatever it is
|
||||
else { warn("HSV_to_RGB: Hi got an unexpected value: $Hi"); }
|
||||
}
|
||||
|
||||
$r = POSIX::floor($r);
|
||||
$g = POSIX::floor($g);
|
||||
$b = POSIX::floor($b);
|
||||
return($r, $g, $b);
|
||||
}
|
||||
|
||||
|
||||
# Converts 3 integers H, S, L (hue, saturation, luminance) to R, G, B
|
||||
# NOTE: THE OUTPUT AND S,V INPUT IS IN THE RANGE [0,1]!
|
||||
# Routine is best performed to "The HSL Song" by Diablo-D3 and the #darkhold idlers.
|
||||
# The lyrics are as follows:
|
||||
# I see a little silluetto of a man
|
||||
# It's in color, its in color, can you convert to HSL?
|
||||
# Cyan, yellow and magenta, very very outdated now
|
||||
# Alvy Smith, Alvy Smith, Alvy Smith, Alvy Smith, Fiigaarrooo
|
||||
# I'm just a poor boy, stuck with RGB
|
||||
# (He's just a poor boy, from a poor colorspace, spare him his eyes from this monstrosity)
|
||||
#
|
||||
# Easy come, easy go, will you let me HSL?
|
||||
# (No! We will not let you HSL!)
|
||||
# Let him HSL!
|
||||
# (No! We will not let you HSL!)
|
||||
# Let him HSL!
|
||||
# (No! We will not let you HSL!)
|
||||
# Let me HSL!
|
||||
# (Will not HSL!)
|
||||
# Let me HSL!
|
||||
# (Will not HSL!)
|
||||
# Let me HSL! Let me HSL!
|
||||
# (Never never never never never!)
|
||||
# Let me HHHHHSSSSSLLLLL!
|
||||
# (No no no no no no no!)
|
||||
#
|
||||
# [70's rock/bad humour segment ends here. We now return to your regularily scheduled Perl hacking...]
|
||||
sub HSL_to_RGB {
|
||||
my ($H, $S, $L) = @_;
|
||||
my ($r, $g, $b, $Q);
|
||||
|
||||
# make sure input is in range
|
||||
$H = $H % 360;
|
||||
$S = clamp($S, 0, 1);
|
||||
$L = clamp($L, 0, 1);
|
||||
|
||||
# simple case if saturation is 0, all grey
|
||||
if ($S == 0) {
|
||||
($r, $g, $b) = ($L, $L, $L);
|
||||
}
|
||||
# more common case, saturated color
|
||||
else {
|
||||
if ($L < 0.5) { $Q = $L * (1 + $S); }
|
||||
else { $Q = $L + $S - ($L * $S); }
|
||||
|
||||
my $P = 2 * $L - $Q;
|
||||
my $Hk = $H / 360;
|
||||
|
||||
my ($Tr, $Tg, $Tb);
|
||||
$Tg = $Hk;
|
||||
if ($Hk < 1/3) { $Tr = $Hk + 1/3; $Tb = $Hk + 2/3; }
|
||||
elsif ($Hk > 2/3) { $Tr = $Hk - 2/3; $Tb = $Hk - 1/3; }
|
||||
else { $Tr = $Hk + 1/3; $Tb = $Hk - 1/3; }
|
||||
|
||||
# anonymous subroutine required for closure reasons
|
||||
my $get_component = sub {
|
||||
my $T = shift(@_);
|
||||
if ($T < 1/6) { return($P + (($Q - $P) * 6 * $T)) }
|
||||
elsif (1/6 <= $T and $T < 1/2) { return($Q) }
|
||||
elsif (1/2 <= $T and $T < 2/3) { return($P + (($Q - $P) * (2/3 - $T) * 6)) }
|
||||
else { return($P) }
|
||||
};
|
||||
|
||||
$r = $get_component->($Tr);
|
||||
$g = $get_component->($Tg);
|
||||
$b = $get_component->($Tb);
|
||||
}
|
||||
|
||||
return($r, $g, $b);
|
||||
}
|
||||
|
||||
|
||||
# Removes whitespace at the start and end of a string
|
||||
# (will anyone ever use this in a perl program?)
|
||||
sub string_trim {
|
||||
my $string = shift(@_);
|
||||
$string =~ s!^\s*(.+?)\s*$!$1!;
|
||||
return($string);
|
||||
}
|
||||
|
||||
|
||||
# Clamp a numeric value to a range
|
||||
sub clamp {
|
||||
my ($val, $min, $max) = @_;
|
||||
if ($val < $min) { return($min) }
|
||||
elsif ($val > $max) { return($max) }
|
||||
else { return($val) }
|
||||
}
|
||||
|
||||
# interpolate between two numbers
|
||||
sub interpolate {
|
||||
my ($pct, $min, $max) = @_;
|
||||
if ($pct <= 0) { return($min) }
|
||||
elsif ($pct >= 1) { return($max) }
|
||||
else { return($pct * ($max - $min) + $min) }
|
||||
}
|
||||
|
||||
# interpolate between two color values (given as &HBBGGRR strings)
|
||||
# returns string formatted with \c&H override format
|
||||
sub interpolate_color {
|
||||
my ($pct, $start, $end) = @_;
|
||||
my ($r1, $g1, $b1) = extract_color($start);
|
||||
my ($r2, $g2, $b2) = extract_color($end);
|
||||
my ($r, $g, $b) =
|
||||
(interpolate($pct, $r1, $r2), interpolate($pct, $g1, $g2), interpolate($pct, $b1, $b2));
|
||||
return(ass_color($r, $g, $b));
|
||||
}
|
||||
|
||||
# interpolate between two alpha values (given as either override or part of style color strings)
|
||||
# returns string formatted with \c&H override format
|
||||
sub interpolate_alpha {
|
||||
my ($pct, $start, $end) = @_;
|
||||
my ($r1, $g1, $b1, $a1) = extract_color($start);
|
||||
my ($r2, $g2, $b2, $a2) = extract_color($end);
|
||||
return(ass_alpha(interpolate($pct, $a1, $a2)));
|
||||
}
|
||||
|
|
@ -1,68 +0,0 @@
|
|||
module Aegisub
|
||||
|
||||
|
||||
# parsing karaoke line
|
||||
# should work more or less like the lua version
|
||||
# input: dialogue line with karaoke tags
|
||||
# output: number of syllables in karaoke
|
||||
def parse_karaoke(line)
|
||||
return 0 if line[:class] != :dialogue
|
||||
return line[:karaoke].size if line[:karaoke].class == Array
|
||||
karaoke = []
|
||||
time = 0
|
||||
line[:text].scan(/(?:{.*?\\(K|k[fto]?)(\d+).*?}([^{]*))|({.*?})([^{]*)/) do |k|
|
||||
if $1 # karaoke tag
|
||||
ktag = $1
|
||||
kdur = $2.to_i
|
||||
syl = Hash.new
|
||||
syl[:start_time] = time
|
||||
if ktag == 'kt'
|
||||
time = kdur*10
|
||||
syl[:duration] = 0
|
||||
else
|
||||
time += kdur*10
|
||||
syl[:duration] = kdur
|
||||
end
|
||||
syl[:end_time] = time
|
||||
syl[:tag] = ktag
|
||||
syl[:text] = $&
|
||||
syl[:text_stripped] = $3
|
||||
karaoke << syl
|
||||
else # no karaoke - append to the last syllable
|
||||
tag = $4
|
||||
text = $5
|
||||
if not karaoke.empty?
|
||||
karaoke.last[:text] << tag << text
|
||||
karaoke.last[:text_stripped] << text if text and tag !~ /\\p\d/ # no drawings
|
||||
end
|
||||
end
|
||||
end
|
||||
line[:karaoke] = karaoke
|
||||
return karaoke.size
|
||||
end
|
||||
|
||||
# replaces matched pattern in the line with an evaluated template
|
||||
# input: line, template (string), strip (bool), pattern (regexp or string)
|
||||
# output: line with karaoke effect
|
||||
def k_replace(line, template, strip, pattern = /\\(:?K|k[fo]?\d+)/) # default pattern = any karaoke tag
|
||||
return if parse_karaoke(line) == 0
|
||||
|
||||
res = ""
|
||||
t = template.gsub(/\$(start|end|dur|mid|text|i|kind)/, '_\1')
|
||||
_i = 0
|
||||
line[:karaoke].each do |s|
|
||||
_start = s[:start_time]
|
||||
_end = s[:end_time]
|
||||
_dur = s[:duration]
|
||||
_mid = _start + _dur*5
|
||||
_text = s[:text_stripped]
|
||||
_kind = s[:tag]
|
||||
ev = t.gsub(/(_(:?start|end|dur|mid|text|i|kind))/) { |m| eval($1).to_s } # evalute variables
|
||||
ev.gsub!(/\%([^%]+)\%/) { |m| eval($1).to_s } # evaluate expressions
|
||||
res << (strip ? "{" << ev << "}" << s[:text_stripped] : s[:text].gsub!(pattern, ev) )
|
||||
_i += 1
|
||||
end
|
||||
line[:text] = res
|
||||
end
|
||||
|
||||
end
|
||||
|
|
@ -1,114 +0,0 @@
|
|||
#include Aegisub
|
||||
|
||||
class Object
|
||||
def deep_clone
|
||||
Marshal.load(Marshal.dump(self))
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
|
||||
module Aegisub
|
||||
|
||||
class ScriptCfg
|
||||
def initialize # constructor
|
||||
@opt = []
|
||||
@x = 0
|
||||
@y = 0
|
||||
@labels = true
|
||||
@width = 1 # TODO
|
||||
@height = 1
|
||||
end
|
||||
|
||||
private
|
||||
def control(type, name, opt = {})
|
||||
@opt << {:class => type, :name => name, :x => @x, :y => @y,
|
||||
:width => 1, :height => 1}.merge!(opt)
|
||||
end
|
||||
|
||||
# some meta-programming :]
|
||||
def self.create_functions(*arr)
|
||||
arr.each do |a|
|
||||
class_eval(%Q[
|
||||
def #{a.to_s}(name, text, opt = {})
|
||||
if @labels; label text, opt; @x += 1; end
|
||||
control "#{a.to_s}", name, opt
|
||||
@y += 1
|
||||
@x = 0
|
||||
end
|
||||
])
|
||||
end
|
||||
end
|
||||
|
||||
public
|
||||
create_functions *[:edit, :intedit, :floatedit, :textbox,
|
||||
:dropdown, :checkbox, :color, :coloralpha, :alpha ]
|
||||
|
||||
def no_labels; @labels = false; end
|
||||
|
||||
def label(text, opt = {})
|
||||
control :label, text, opt.merge({:label => text})
|
||||
end
|
||||
|
||||
def header(text, opt = {})
|
||||
label text, opt.merge!({:width => 2})
|
||||
@y += 1
|
||||
end
|
||||
|
||||
def to_ary # conversion to array
|
||||
@opt
|
||||
end
|
||||
|
||||
end
|
||||
|
||||
# inserts lines with options into [Script Info] section
|
||||
def write_options(subs, opt, sep = "~~")
|
||||
subs.collect! do |l|
|
||||
if l[:class] == :info
|
||||
info = true
|
||||
value = opt.delete(l[:key])
|
||||
l[:value] = value.instance_of?(Hash) ? value.to_a.flatten!.join(sep) : value.to_s if value
|
||||
l
|
||||
elsif info
|
||||
r = [l]
|
||||
opt.each do |key, val|
|
||||
r << {:class => :info, :key => key,
|
||||
:value => value.instance_of?(Hash) ? value.to_a.flatten!.join(sep) : value.to_s,
|
||||
:section => "[Script Info]"}
|
||||
end
|
||||
info = false
|
||||
r
|
||||
else
|
||||
l
|
||||
end
|
||||
end
|
||||
end
|
||||
|
||||
# returns a hash with options from [Script Info] section
|
||||
def read_options(subs, name, sep = "~~")
|
||||
opt = {}
|
||||
subs.each { |l| opt[l[:key].to_sym] = l[:value] if l[:class] == :info }
|
||||
n_sym = name.to_sym
|
||||
if opt[n_sym] # parsing of script specific options
|
||||
a = opt[n_sym].split(sep)
|
||||
h = {}
|
||||
(a.size/2).times { |j| h[a[2*j].to_sym] = a[2*j+1] }
|
||||
opt[n_sym] = h
|
||||
end
|
||||
return opt
|
||||
end
|
||||
|
||||
def rgb_to_ssa(*c)
|
||||
res = "&H"
|
||||
c.reverse_each {|v| res << "%02X" % v}
|
||||
res << "&"
|
||||
return res
|
||||
end
|
||||
|
||||
def ssa_to_rgb(col)
|
||||
res = []
|
||||
col.scan(/[0-9a-fA-F]{2}/) { res.unshift $1.to_i(16) }
|
||||
res
|
||||
end
|
||||
end
|
||||
|
||||
|
|
@ -1,273 +0,0 @@
|
|||
------------------------------------
|
||||
Quick reference on Perl engine's API
|
||||
------------------------------------
|
||||
|
||||
All the packages that form the perl interface to Aegisub are automatically
|
||||
loaded, however none of their symbols are exported initially. If you want to
|
||||
import them you can use the usual 'use' mechanism; if you call it without a
|
||||
list of imports it will import more or less everything in your script's
|
||||
package. Wether they are exported or not is indicated in the following
|
||||
reference by <--EXPORTED--> (exported by default within a plain 'use'
|
||||
statement) and <--EXPORTABLE--> (can be imported specifying them explicitely in
|
||||
the 'use' statement) tags. Finally, <--NOT EXPORTABLE--> indicates symbols that
|
||||
can't be exported through 'use'.
|
||||
|
||||
|
||||
====================================
|
||||
package Aegisub
|
||||
|
||||
------------------------------------
|
||||
Constants defined:
|
||||
<--EXPORTABLE-->
|
||||
|
||||
LOG_FATAL == 0
|
||||
LOG_ERROR == 1
|
||||
LOG_WARNING == 2
|
||||
LOG_HINT == 3
|
||||
LOG_DEBUG == 4
|
||||
LOG_TRACE == 5
|
||||
LOG_MESSAGE == 6
|
||||
Log levels, to be used with the 'log' function.
|
||||
|
||||
LOG_WX == 8
|
||||
Flag to force logging through wxWidgets facilites.
|
||||
|
||||
------------------------------------
|
||||
Subroutines defined:
|
||||
<--EXPORTED-->
|
||||
|
||||
text_extents STYLE, TEXT
|
||||
Computes the metric for a string of text, based on a specific style.
|
||||
Arguments:
|
||||
STYLE The style to use, as a string or ref to a style line.
|
||||
TEXT Text for which to compute the metrics.
|
||||
Returns:
|
||||
WIDTH The width of the text (if called in scalar context, only this is returned).
|
||||
ASCENT The ascent, i.e. the distance from the baseline to the top of the letters.
|
||||
DESCENT Descent, i.e. the distance from the baseline to the bottom.
|
||||
EXTLEADING External leading, i.e. the distance between to lines of text.
|
||||
|
||||
log_fatal LIST
|
||||
...
|
||||
log_message LIST
|
||||
These are shortcuts for 'log(LOG_FATAL, LIST)' to 'log(LOG_MESSAGE, LIST)'
|
||||
(see below).
|
||||
|
||||
<--EXPORTABLE-->
|
||||
|
||||
log LEVEL, LIST
|
||||
log LIST
|
||||
Prints a log message inside the progress window, if LEVEL is less or equal
|
||||
to the tracelevel set inside automation options. If called from outside a
|
||||
callback (i.e. during script loading) prints through the wxWidgets logging
|
||||
mechanism. 'log(LIST)' is equal to 'log(Aegisub::LOG_MESSAGE, LIST)'. The
|
||||
short form is used whenever there are at least two arguments and the first
|
||||
one cannot be read as an integer; it is always used when given only one
|
||||
argument. This function is not exported by default (review man perlfunc to
|
||||
understand why :).
|
||||
|
||||
Arguments:
|
||||
LEVEL The debug level, may be one of the following (the descriptions are
|
||||
indicative):
|
||||
0 Fatal error, for vital errors;
|
||||
1 Error, for serious but not too much threatening errors;
|
||||
2 Warning, for something that's apparently going wrong;
|
||||
3 Hint, for indicating something peculiar is happening;
|
||||
4 Debug, for debugging!
|
||||
5 Trace, for really verbose debugging;
|
||||
6 Message, always printed.
|
||||
If you OR one of these values with the flag LOG_WX the log message will
|
||||
be delivered though wxWidgets regardless of wether there is a progress
|
||||
window displayed (you won't normally need this feature, though).
|
||||
LIST List of arguments to print.
|
||||
|
||||
warn LIST
|
||||
Prints a warning through the GUI log facilities (it is equivalent to
|
||||
'log(Aegisub::LOG_WARNING, LIST)'). It is automatically hooked to the
|
||||
global 'warn' function during script execution, thus it is not exported by
|
||||
default.
|
||||
Arguments:
|
||||
LIST List of arguments to print.
|
||||
|
||||
<--NOT EXPORTABLE-->
|
||||
|
||||
wxlog LEVEL, LIST
|
||||
wxlog LIST
|
||||
Similar to 'log', but with the LOG_WX flag implicitely set. This function
|
||||
is top-secret.
|
||||
|
||||
|
||||
====================================
|
||||
package Aegisub::PerlConsole
|
||||
------------------------------------
|
||||
This package contains the perl console, a debug tool not intended for normal
|
||||
use by normal users (it's not even enabled in release builds). They are shown
|
||||
here for completeness.
|
||||
|
||||
------------------------------------
|
||||
Subroutines defined:
|
||||
<--EXPORTED-->
|
||||
|
||||
echo LIST
|
||||
Prints a list of arguments on the console, or on STDOUT if no console is
|
||||
registered, a trailing \n is printed too.
|
||||
Arguments:
|
||||
LIST List of arguments to print.
|
||||
|
||||
register_console NAME, DESC
|
||||
Registers an instance of the console, as a macro. You don't want to know
|
||||
any more because in fact you'll never have to do with this. >:)
|
||||
Arguments:
|
||||
NAME Set the name for the macro. (optional)
|
||||
DESC Set the macro's description. (optional)
|
||||
|
||||
|
||||
====================================
|
||||
package Aegisub::Progress
|
||||
------------------------------------
|
||||
This package provides an interface to the progress window automatically showed
|
||||
during the execution of a feature. Its functions are somewhat different to
|
||||
those available in lua because of clarity, however aliases are given.
|
||||
|
||||
------------------------------------
|
||||
Subroutines defined:
|
||||
<--EXPORTED-->
|
||||
|
||||
set_progress VALUE
|
||||
Sets the value of the progress bar. It accepts values comprised in [0, 1]
|
||||
OR (1, 100] (for instance, a value of 0.86 is equivalent to a value of 86:
|
||||
they both represent '86%'). You should really always use values in the
|
||||
range [0, 1] if you don't wanna be mocked by your friends and relatives
|
||||
(and normally they're more immediately computable).
|
||||
Arguments:
|
||||
VALUE The value for the progress bar.
|
||||
|
||||
set_task DESC
|
||||
Sets the description for the current task inside progress window (just
|
||||
below the progress bar).
|
||||
Arguments:
|
||||
DESC The description for the current task.
|
||||
|
||||
set_title TITLE
|
||||
Sets the title for the progress window (which is not actually the window's
|
||||
title, but a flashier label below it). The default title is 'Executing ...'
|
||||
(with the ellpsis possibly replaced by the feature's name).
|
||||
Arguments:
|
||||
TITLE The title to set.
|
||||
|
||||
is_cancelled
|
||||
Returns: A boolean indicating wether the cancel button on the progress
|
||||
window where pressed in the near past.
|
||||
|
||||
<--EXPORTABLE-->
|
||||
|
||||
set VALUE
|
||||
Synonym for 'set_progress(VALUE)'.
|
||||
|
||||
task DESC
|
||||
Synonym for 'set_desc(DESC)',
|
||||
|
||||
title TITLE
|
||||
Synonym for 'set_title(TITLE)'.
|
||||
|
||||
|
||||
====================================
|
||||
package Aegisub::Script
|
||||
|
||||
------------------------------------
|
||||
Subroutines defined:
|
||||
<--EXPORTED-->
|
||||
|
||||
register_macro NAME, DESC, PROC_SUB, VAL_SUB
|
||||
Register a new macro.
|
||||
Arguments:
|
||||
NAME The name of the macro.
|
||||
DESC A description for the macro.
|
||||
PROC_SUB A ref to a subroutine to be used as the macro processing function
|
||||
(see the callbacks section). Please, really use a reference and not
|
||||
just the name of the sub, because of the script 'pacakging' described
|
||||
below.
|
||||
VAL_SUB A ref to a subroutine to be used as the macro validation function
|
||||
(see callbacks)(optional, if not defined will be considered as always true).
|
||||
|
||||
set_info NAME, DESC, AUTHOR, VERSION
|
||||
You can set all of the script's info values with a call to this
|
||||
function. (Otherwise you can set the corresponding predefined script
|
||||
variables individually.)
|
||||
Arguments: see the parts about script variables, anything is optional.
|
||||
|
||||
|
||||
====================================
|
||||
package Aegisub::Script::pxxxxxxxx
|
||||
------------------------------------
|
||||
Every script that's loaded gets its code evaluated inside a different package -
|
||||
whose name is chosen at 'random' - whereas the perl interpreter is unique, so
|
||||
all the scripts see the same global package, and can possibly access other
|
||||
scripts' packages. Therefore is recommended to ALWAYS declare all of the
|
||||
script's local variables with 'my', and of course to 'use strict' to check on
|
||||
this. You can still declare another package for your script; the script's
|
||||
predefined variables should be still visible from it without any change in the
|
||||
code (they're declared as 'our'), however this is discouraged.
|
||||
|
||||
------------------------------------
|
||||
Variables defined:
|
||||
|
||||
$script_author
|
||||
Holds the script author's name. Default is the user executing aegisub.
|
||||
|
||||
$script_description
|
||||
Holds a description for the script. Default is 'Perl script'.
|
||||
|
||||
$script_name
|
||||
Holds the script's name. Default is the script's filename.
|
||||
|
||||
$script_version
|
||||
Holds the script's version. Default is current aegisub version.
|
||||
|
||||
$_script_path
|
||||
The full path to the script's file. Any change to this variable is ignored
|
||||
and overwritten.
|
||||
|
||||
$_script_package
|
||||
The full script package as a string. Any change to this variable is
|
||||
currently ignored and overwritten, and may be so forever.
|
||||
|
||||
|
||||
------------------------------------
|
||||
Callbacks definable:
|
||||
|
||||
macro_processing_function LINES, SELECTED, ACTIVE
|
||||
A function to be used as a callback for Aegisub::Script::register_macro().
|
||||
This function will be called when the user selects the corresponding macro
|
||||
in the Automation menu. The first two arguments can be modified, and the
|
||||
modifications will be reflected in the subtitles file.
|
||||
Arguments:
|
||||
LINES A reference to the list containing the subtitle file lines.
|
||||
Each element of the list is a reference to a hash that represents a
|
||||
single subtitle line. For the hash keys refer to lua documentation,
|
||||
they are basically the same.
|
||||
Example:
|
||||
|
||||
my $lines = $_[0]; # DON'T shift @_ (unless you reconstruct it
|
||||
# afterwards) or you'll break everything and
|
||||
# your hard disk be erased >:)
|
||||
# The first selected line's index
|
||||
my $first = $_[1][0];
|
||||
# An entire line
|
||||
my $l = $lines->[$first];
|
||||
# The text field of a dialogue line
|
||||
my $text = $lines->[$first]->{"text"};
|
||||
|
||||
SELECTED A ref to an array of ints, showing the currently selected
|
||||
lines in the file.
|
||||
ACTIVE Index of the currently active line in the subtitle file (sic).
|
||||
|
||||
macro_validation_function LINES, SELECTED, ACTIVE
|
||||
A function to be used as a callback for Aegisub::Script::register_macro().
|
||||
This function will be called whenever the Automation menu is opened to
|
||||
decide what macros are applicable to the current script.
|
||||
Arguments: same as macro_processing_function; however any change to the
|
||||
first two ones will be ignored upon function return.
|
||||
Returns:
|
||||
VALID A 'boolean' value to indicate if the macro is applicable to this
|
||||
particular subtitles file.
|
||||
|
|
@ -563,62 +563,6 @@
|
|||
>
|
||||
</File>
|
||||
</Filter>
|
||||
<Filter
|
||||
Name="Ruby"
|
||||
>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_ruby.cpp"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_ruby.h"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_ruby_assfile.cpp"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_ruby_dialog.cpp"
|
||||
>
|
||||
</File>
|
||||
</Filter>
|
||||
<Filter
|
||||
Name="Perl"
|
||||
>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_perl.cpp"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_perl.h"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_perl_ass.cpp"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_perl_console.cpp"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_perl_console.h"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_perl_dialogs.cpp"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_perl_script.cpp"
|
||||
>
|
||||
</File>
|
||||
<File
|
||||
RelativePath="..\..\src\auto4_perldata.inc"
|
||||
>
|
||||
</File>
|
||||
</Filter>
|
||||
</Filter>
|
||||
<Filter
|
||||
Name="Wrappers"
|
||||
|
|
|
|||
|
|
@ -1,11 +0,0 @@
|
|||
<?xml version="1.0" encoding="Windows-1252"?>
|
||||
<VisualStudioPropertySheet
|
||||
ProjectType="Visual C++"
|
||||
Version="8.00"
|
||||
Name="delayload_perl_32"
|
||||
>
|
||||
<Tool
|
||||
Name="VCLinkerTool"
|
||||
DelayLoadDLLs="perl510.dll"
|
||||
/>
|
||||
</VisualStudioPropertySheet>
|
||||
|
|
@ -1,598 +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
|
||||
//
|
||||
|
||||
|
||||
#include "config.h"
|
||||
|
||||
#ifdef WITH_PERL
|
||||
|
||||
|
||||
#include "auto4_perl.h"
|
||||
#include "auto4_perl_console.h"
|
||||
#include "auto4_perl_factory.h"
|
||||
#include "options.h"
|
||||
#include "ass_style.h"
|
||||
|
||||
#ifdef __VISUALC__
|
||||
#pragma warning(disable: 4800)
|
||||
#pragma warning(disable: 4706)
|
||||
#endif
|
||||
|
||||
#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 {
|
||||
|
||||
static PerlInterpreter *perl_interpreter = NULL;
|
||||
|
||||
///////////////////////////////////
|
||||
// Perl -> C++ interface (XSUBS)
|
||||
//
|
||||
|
||||
/* package Aegisub */
|
||||
XS(perl_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)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::warn);
|
||||
dXSARGS;
|
||||
|
||||
if(items >= 1) {
|
||||
wxString buf;
|
||||
COLLECT_PV(buf, 0, items-1);
|
||||
PerlLogWarning(buf);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
XS(perl_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 {
|
||||
PerlLogWarning(_("Not enough parameters for Aegisub::text_extents()"));
|
||||
// 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;
|
||||
}
|
||||
|
||||
XS(perl_script_set_undo_point)
|
||||
{
|
||||
wxTRACE_FUNC(Aegisub::Script::set_undo_point);
|
||||
dXSARGS;
|
||||
|
||||
wxString desc;
|
||||
if(items > 0)
|
||||
desc = wxString(SvPV_nolen(ST(0)), pl2wx);
|
||||
else
|
||||
desc = _T("Auto4Perl");
|
||||
|
||||
AssFile::top->FlagAsModified(desc);
|
||||
|
||||
XSRETURN_YES;
|
||||
}
|
||||
|
||||
/* 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);
|
||||
dMARK; dAX;
|
||||
|
||||
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);
|
||||
#ifdef WITH_PERLCONSOLE
|
||||
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));
|
||||
}
|
||||
XSRETURN_YES;
|
||||
#else
|
||||
dMARK; dAX;
|
||||
PerlLogWarning(_("Tried to register PerlConsole, but support for it was disabled in this version.")); // Warning or Hint?
|
||||
XSRETURN_UNDEF;
|
||||
#endif
|
||||
}
|
||||
|
||||
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);
|
||||
}
|
||||
|
||||
#ifdef WITH_PERLCONSOLE
|
||||
if(PerlConsole::GetConsole()) {
|
||||
// If there's a console echo to it
|
||||
PerlConsole::Echo(buffer);
|
||||
}
|
||||
else
|
||||
#endif
|
||||
// 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);
|
||||
|
||||
/* XS registration */
|
||||
EXTERN_C void xs_perl_main(pTHX)
|
||||
{
|
||||
dXSUB_SYS;
|
||||
|
||||
/* DynaLoader is a special case */
|
||||
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
|
||||
|
||||
// My XSUBS ^^
|
||||
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::Script::set_undo_point", perl_script_set_undo_point, __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
|
||||
}
|
||||
|
||||
PERL_SET_CONTEXT(perl_interpreter);
|
||||
ExitCode ec = NULL;
|
||||
switch(type) {
|
||||
case CALL:
|
||||
if(sv) ec = (ExitCode)((size_t)call_sv(sv, flags));
|
||||
else if(pv) ec = (ExitCode)((size_t)call_pv(pv, flags));
|
||||
break;
|
||||
case EVAL:
|
||||
if(sv) ec = (ExitCode)((size_t) | ||||