1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
##
## WML -- Website META Language
##
## Copyright (c) 1996-2001 Ralf S. Engelschall.
## Copyright (c) 1999-2001 Denis Barbier.
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program; if not, write to
##
## Free Software Foundation, Inc.
## 59 Temple Place - Suite 330
## Boston, MA 02111-1307, USA
##
## Notice, that ``free software'' addresses the fact that this program
## is __distributed__ under the term of the GNU General Public License
## and because of this, it can be redistributed and modified under the
## conditions of this license, but the software remains __copyrighted__
## by the author. Don't intermix this with the general meaning of
## Public Domain software or such a derivated distribution label.
##
## The author reserves the right to distribute following releases of
## this program under different conditions or license agreements.
##
package TheWML::Frontends::Wml::PassObj;
use strict;
use warnings;
use Carp::Always;
use Class::XSAccessor (
constructor => 'new',
accessors => +{ map { $_ => $_ } qw( cb opt_pass time_ src_cb) }
);
use File::Basename qw/ basename /;
use File::Which qw/ which /;
# remove escape backslashes
sub unquotearg
{
my ($arg) = @_;
$arg =~ s/\\([\$"`])/$1/g;
return $arg;
}
sub dosource
{
my ( $pass, $_pass_mgr, $prog, $args, $cb ) = @_;
$_pass_mgr->verbose( 2, "source: $prog $args\n" );
$_pass_mgr->verbose( 9, "loading: $prog\n" );
if ( !defined( $pass->src_cb ) )
{
$pass->src_cb($cb);
}
$_pass_mgr->verbose( 9, "splitting from args: $args\n" );
my @argv;
while ($args)
{
redo
if $args =~
s|^\s*(-[a-zA-Z0-9]\S*)|push(@argv, unquotearg($1)), ''|egis;
redo
if $args =~
s|^\s*"(.*?(?!\\).)"|push(@argv, unquotearg($1)), ''|egis;
redo if $args =~ s|^\s*'([^']*)'|push(@argv, $1), ''|egis;
redo if $args =~ s|^\s*(\S+)|push(@argv, unquotearg($1)), ''|egis;
redo if $args =~ s|^\s+$|''|egis;
}
$_pass_mgr->verbose( 9, "splitting to argv: " . join( "|", @argv ) . "\n" );
$_pass_mgr->verbose( 9, "running script\n" );
my $rc = $pass->src_cb->(@argv);
$rc //= '';
$_pass_mgr->verbose( 9, "running script: rc=$rc\n" );
$rc = 256 if not defined $rc;
return $rc;
}
1;
|
