The removal of Auto4 Ruby and Auto4 Perl code. Updates #665 and #938.

Originally committed to SVN as r3205.
This commit is contained in:
Niels Martin Hansen 2009-07-23 01:39:57 +00:00
parent af5df13f00
commit 31657f94da
28 changed files with 0 additions and 5473 deletions

View file

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

View file

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

View file

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

View file

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

View file

@ -1,6 +0,0 @@
package Aegisub::PerlConsole;
use Exporter 'import';
@EXPORT = qw( echo register_console );
1;

View file

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

View file

@ -1,6 +0,0 @@
package Aegisub::Script;
use Exporter 'import';
@EXPORT = qw( register_macro set_info );
1;

View file

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

View file

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

View file

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

View file

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

View 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"

View file

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

View file

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