ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/rxvt-unicode/src/urxvt.pm
(Generate patch)

Comparing rxvt-unicode/src/urxvt.pm (file contents):
Revision 1.204 by sf-exg, Mon Dec 5 12:52:57 2011 UTC vs.
Revision 1.215 by root, Thu Jun 7 16:30:58 2012 UTC

… …
20=head1 DESCRIPTION 20=head1 DESCRIPTION
21 21
22Every time a terminal object gets created, extension scripts specified via 22Every time a terminal object gets created, extension scripts specified via
23the C<perl> resource are loaded and associated with it. 23the C<perl> resource are loaded and associated with it.
24 24
25Scripts are compiled in a 'use strict' and 'use utf8' environment, and 25Scripts are compiled in a 'use strict "vars"' and 'use utf8' environment, and
26thus must be encoded as UTF-8. 26thus must be encoded as UTF-8.
27 27
28Each script will only ever be loaded once, even in @@RXVT_NAME@@d, where 28Each script will only ever be loaded once, even in @@RXVT_NAME@@d, where
29scripts will be shared (but not enabled) for all terminals. 29scripts will be shared (but not enabled) for all terminals.
30 30
… …
755=cut 755=cut
756 756
757package urxvt; 757package urxvt;
758 758
759use utf8; 759use utf8;
760use strict; 760use strict 'vars';
761use Carp (); 761use Carp ();
762use Scalar::Util (); 762use Scalar::Util ();
763use List::Util (); 763use List::Util ();
764 764
765our $VERSION = 1; 765our $VERSION = 1;
766our $TERM; 766our $TERM;
767our @TERM_INIT; 767our @TERM_INIT; # should go, prevents async I/O etc.
768our @TERM_EXT; 768our @TERM_EXT; # should go, prevents async I/O etc.
769our @HOOKNAME; 769our @HOOKNAME;
770our %HOOKTYPE = map +($HOOKNAME[$_] => $_), 0..$#HOOKNAME; 770our %HOOKTYPE = map +($HOOKNAME[$_] => $_), 0..$#HOOKNAME;
771our %OPTION; 771our %OPTION;
772 772
773our $LIBDIR; 773our $LIBDIR;
… …
943 }; 943 };
944} 944}
945 945
946no warnings 'utf8'; 946no warnings 'utf8';
947 947
948sub parse_resource {
949 my ($term, $name, $isarg, $longopt, $flag, $value) = @_;
950
951 $term->scan_meta;
952
953 my $r = $term->{meta}{resource};
954 while (my ($pattern, $v) = each %$r) {
955 $name =~ y/-/./ if $isarg;
956
957 if (
958 $pattern =~ /\.$/
959 ? $pattern eq substr $name, 0, length $pattern
960 : $pattern eq $name
961 ) {
962 $name = "$urxvt::RESCLASS.$name";
963
964 push @{ $term->{perl_ext_3} }, $v->[0];
965
966 if ($v->[1] eq "boolean") {
967 $term->put_option_db ($name, $flag ? "true" : "false");
968 return 1;
969 } else {
970 $term->put_option_db ($name, $value);
971 return 1 + 2;
972 }
973 }
974 }
975
976 0
977}
978
979sub usage {
980 my ($term, $usage_type) = @_;
981
982 $term->scan_meta;
983
984 my $r = $term->{meta}{resource};
985
986 for my $pattern (sort keys %$r) {
987 my ($ext, $type, $desc) = @{ $r->{$pattern} };
988
989 $desc .= " (-pe $ext)";
990
991 if ($usage_type == 1) {
992 $pattern =~ y/./-/;
993 $pattern =~ s/-$/-.../g;
994
995 if ($type eq "boolean") {
996 urxvt::log sprintf " -%-30s %s\n", "/+$pattern", $desc;
997 } else {
998 urxvt::log sprintf " -%-30s %s\n", "$pattern $type", $desc;
999 }
1000 } else {
1001 $pattern =~ s/\.$/.*/g;
1002 urxvt::log sprintf " %-31s %s\n", "$pattern:", $type;
1003 }
1004 }
1005}
1006
948my $verbosity = $ENV{URXVT_PERL_VERBOSITY}; 1007my $verbosity = $ENV{URXVT_PERL_VERBOSITY};
949 1008
950sub verbose { 1009sub verbose {
951 my ($level, $msg) = @_; 1010 my ($level, $msg) = @_;
952 warn "$msg\n" if $level <= $verbosity; 1011 warn "$msg\n" if $level <= $verbosity;
… …
968 1027
969 open my $fh, "<:raw", $path 1028 open my $fh, "<:raw", $path
970 or die "$path: $!"; 1029 or die "$path: $!";
971 1030
972 my $source = 1031 my $source =
973 "package $pkg; use strict; use utf8; no warnings 'utf8';\n" 1032 "package $pkg; use strict 'vars'; use utf8; no warnings 'utf8';\n"
974 . "#line 1 \"$path\"\n{\n" 1033 . "#line 1 \"$path\"\n{\n"
975 . (do { local $/; <$fh> }) 1034 . (do { local $/; <$fh> })
976 . "\n};\n1"; 1035 . "\n};\n1";
977 1036
978 eval $source 1037 eval $source
… …
988sub invoke { 1047sub invoke {
989 local $TERM = shift; 1048 local $TERM = shift;
990 my $htype = shift; 1049 my $htype = shift;
991 1050
992 if ($htype == 0) { # INIT 1051 if ($htype == 0) { # INIT
993 my @dirs = ((split /:/, $TERM->resource ("perl_lib")), "$ENV{HOME}/.urxvt/ext", "$LIBDIR/perl"); 1052 my @dirs = $TERM->perl_libdirs;
994 1053
995 my %ext_arg; 1054 my %ext_arg;
996 1055
997 { 1056 {
998 my @init = @TERM_INIT; 1057 my @init = @TERM_INIT;
… …
1001 my @pkg = @TERM_EXT; 1060 my @pkg = @TERM_EXT;
1002 @TERM_EXT = (); 1061 @TERM_EXT = ();
1003 $TERM->register_package ($_) for @pkg; 1062 $TERM->register_package ($_) for @pkg;
1004 } 1063 }
1005 1064
1065 for (
1066 @{ delete $TERM->{perl_ext_3} },
1006 for (grep $_, map { split /,/, $TERM->resource ("perl_ext_$_") } 1, 2) { 1067 grep $_, map { split /,/, $TERM->resource ("perl_ext_$_") } 1, 2
1068 ) {
1007 if ($_ eq "default") { 1069 if ($_ eq "default") {
1008 $ext_arg{$_} ||= [] for qw(selection option-popup selection-popup searchable-scrollback readline); 1070 $ext_arg{$_} ||= [] for qw(selection option-popup selection-popup searchable-scrollback readline);
1009 } elsif (/^-(.*)$/) { 1071 } elsif (/^-(.*)$/) {
1010 delete $ext_arg{$1}; 1072 delete $ext_arg{$1};
1011 } elsif (/^([^<]+)<(.*)>$/) { 1073 } elsif (/^([^<]+)<(.*)>$/) {
… …
1159=head2 The C<urxvt::anyevent> Class 1221=head2 The C<urxvt::anyevent> Class
1160 1222
1161The sole purpose of this class is to deliver an interface to the 1223The sole purpose of this class is to deliver an interface to the
1162C<AnyEvent> module - any module using it will work inside urxvt without 1224C<AnyEvent> module - any module using it will work inside urxvt without
1163further programming. The only exception is that you cannot wait on 1225further programming. The only exception is that you cannot wait on
1164condition variables, but non-blocking condvar use is ok. What this means 1226condition variables, but non-blocking condvar use is ok.
1165is that you cannot use blocking APIs, but the non-blocking variant should 1227
1166work. 1228In practical terms this means is that you cannot use blocking APIs, but
1229the non-blocking variant should work.
1167 1230
1168=cut 1231=cut
1169 1232
1170our $VERSION = '5.23'; 1233our $VERSION = '5.23';
1171 1234
… …
1265 $self->{_pkg}{$pkg} = $proxy; 1328 $self->{_pkg}{$pkg} = $proxy;
1266 1329
1267 for my $name (@HOOKNAME) { 1330 for my $name (@HOOKNAME) {
1268 if (my $ref = $pkg->can ("on_" . lc $name)) { 1331 if (my $ref = $pkg->can ("on_" . lc $name)) {
1269 $proxy->enable ($name => $ref); 1332 $proxy->enable ($name => $ref);
1333 }
1334 }
1335}
1336
1337sub perl_libdirs {
1338 map { split /:/ }
1339 $_[0]->resource ("perl_lib"),
1340 $ENV{URXVT_PERL_LIB},
1341 "$ENV{HOME}/.urxvt/ext",
1342 "$LIBDIR/perl"
1343}
1344
1345sub scan_meta {
1346 my ($self) = @_;
1347 my @libdirs = perl_libdirs $self;
1348
1349 return if $self->{meta_libdirs} eq join "\x00", @libdirs;
1350
1351 my %meta;
1352
1353 $self->{meta_libdirs} = join "\x00", @libdirs;
1354 $self->{meta} = \%meta;
1355
1356 for my $dir (reverse @libdirs) {
1357 opendir my $fh, $dir
1358 or next;
1359 for my $ext (readdir $fh) {
1360 $ext ne "."
1361 and $ext ne ".."
1362 and open my $fh, "<", "$dir/$ext"
1363 or next;
1364
1365 while (<$fh>) {
1366 if (/^#:META:X_RESOURCE:(.*)/) {
1367 my ($pattern, $type, $desc) = split /:/, $1;
1368 $pattern =~ s/^%(\.|$)/$ext$1/g; # % in pattern == extension name
1369 if ($pattern =~ /[^a-zA-Z0-9\-\.]/) {
1370 warn "$dir/$ext: meta resource '$pattern' contains illegal characters (not alphanumeric nor . nor *)\n";
1371 } else {
1372 $meta{resource}{$pattern} = [$ext, $type, $desc];
1373 }
1374 } elsif (/^\s*(?:#|$)/) {
1375 # skip other comments and empty lines
1376 } else {
1377 last; # stop parsing on first non-empty non-comment line
1378 }
1379 }
1270 } 1380 }
1271 } 1381 }
1272} 1382}
1273 1383
1274=item $term = new urxvt::term $envhashref, $rxvtname, [arg...] 1384=item $term = new urxvt::term $envhashref, $rxvtname, [arg...]
… …
1395 1505
1396This method should only be called during the C<on_start> hook, as there is 1506This method should only be called during the C<on_start> hook, as there is
1397only one resource database per display, and later invocations might return 1507only one resource database per display, and later invocations might return
1398the wrong resources. 1508the wrong resources.
1399 1509
1510=item $value = $term->x_resource_boolean ($pattern)
1511
1512Like C<x_resource>, above, but interprets the string value as a boolean
1513and returns C<1> for true values, C<0> for false values and C<undef> if
1514the resource or option isn't specified.
1515
1516You should always use this method to parse boolean resources.
1517
1518=cut
1519
1520sub x_resource_boolean {
1521 my $res = &x_resource;
1522
1523 $res =~ /^\s*(?:true|yes|on|1)\s*$/i ? 1 : defined $res && 0
1524}
1525
1400=item $success = $term->parse_keysym ($key, $octets) 1526=item $success = $term->parse_keysym ($key, $octets)
1401 1527
1402Adds a key binding exactly as specified via a resource. See the 1528Adds a key binding exactly as specified via a resource. See the
1403C<keysym> resource in the @@RXVT_NAME@@(1) manpage. 1529C<keysym> resource in the @@RXVT_NAME@@(1) manpage.
1404 1530

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines