[13447] in Perl-Users-Digest
Perl-Users Digest, Issue: 857 Volume: 9
daemon@ATHENA.MIT.EDU (Perl-Users Digest)
Mon Sep 20 14:17:29 1999
Date: Mon, 20 Sep 1999 11:10:16 -0700 (PDT)
From: Perl-Users Digest <Perl-Users-Request@ruby.OCE.ORST.EDU>
To: Perl-Users@ruby.OCE.ORST.EDU (Perl-Users Digest)
Message-Id: <937851016-v9-i857@ruby.oce.orst.edu>
Content-Type: text
Perl-Users Digest Mon, 20 Sep 1999 Volume: 9 Number: 857
Today's topics:
Positioning the Cursor on a terminal <dkyount@worldnet.att.net>
Re: Positioning the Cursor on a terminal (Kragen Sitaker)
Re: Positioning the Cursor on a terminal <tchrist@mox.perl.com>
Re: Positioning the Cursor on a terminal <jerrad@networkengines.com>
Re: Programmer Needed <crt@kiski.net>
Qns about passing by reference, etc <jonnyace@pacific.net.sg>
Re: Qns about passing by reference, etc (Kragen Sitaker)
range of array indexes <picaza@chsi.com>
Re: range of array indexes <Allan@due.net>
Re: s/// conditional substitution <uri@sysarch.com>
Re: s/// conditional substitution <picaza@chsi.com>
Re: s/// conditional substitution <uri@sysarch.com>
Re: Some e-mails get sent, some don't (Bill Moseley)
Re: Some e-mails get sent, some don't (Kragen Sitaker)
Re: System Call only works on 4K of input <cw@dwc.ch>
Digest Administrivia (Last modified: 16 Sep 99) (Perl-Users-Digest Admin)
----------------------------------------------------------------------
Date: Mon, 20 Sep 1999 11:55:43 -0500
From: "Daniel" <dkyount@worldnet.att.net>
Subject: Positioning the Cursor on a terminal
Message-Id: <7s5p50$kjd$1@bgtnsc03.worldnet.att.net>
I am developing an interactive program that runs strictly in from the
command line, but I don't want it to appear as if it is running from the
command line. I know that in C there is a way to position the cursor on the
screen/terminal and accept input from that position. What I was wondering
is if anyone knew of a way to perform this same technique in perl. So that
I will not have to continuously clear the screen with the \n and then
redisplay the information just to accept a users input.
Thanks,
Daniel.
------------------------------
Date: Mon, 20 Sep 1999 17:10:01 GMT
From: kragen@dnaco.net (Kragen Sitaker)
Subject: Re: Positioning the Cursor on a terminal
Message-Id: <JTtF3.22304$N77.1781358@typ11.nn.bcandid.com>
In article <7s5p50$kjd$1@bgtnsc03.worldnet.att.net>,
Daniel <dkyount@worldnet.att.net> wrote:
>I am developing an interactive program that runs strictly in from the
>command line, but I don't want it to appear as if it is running from the
>command line. I know that in C there is a way to position the cursor on the
>screen/terminal and accept input from that position.
Well, sort of. Not really.
> What I was wondering
>is if anyone knew of a way to perform this same technique in perl.
There's a Curses module. I haven't tried it. There's also an
(apparently fetal) Term::Slang module, and apparently a Term::Info
module, and the Term::Cap module that comes with Perl.
All of these are originally C libraries.
--
<kragen@pobox.com> Kragen Sitaker <http://www.pobox.com/~kragen/>
Mon Sep 20 1999
49 days until the Internet stock bubble bursts on Monday, 1999-11-08.
<URL:http://www.pobox.com/~kragen/bubble.html>
------------------------------
Date: 20 Sep 1999 11:10:55 -0700
From: Tom Christiansen <tchrist@mox.perl.com>
Subject: Re: Positioning the Cursor on a terminal
Message-Id: <37e66a9f@cs.colorado.edu>
[courtesy cc of this posting mailed to cited author]
In comp.lang.perl.misc,
"Daniel" <dkyount@worldnet.att.net> writes:
:I am developing an interactive program that runs strictly in from the
:command line, but I don't want it to appear as if it is running from the
:command line. I know that in C there is a way to position the cursor on the
:screen/terminal and accept input from that position. What I was wondering
:is if anyone knew of a way to perform this same technique in perl. So that
:I will not have to continuously clear the screen with the \n and then
:redisplay the information just to accept a users input.
You can use the standard Term::Cap module's Tgoto() method:
require Term::Cap;
$terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
$terminal->Trequire(qw/ce ku kd/);
$terminal->Tgoto('cm', $col, $row, $FH);
$terminal->Tputs('dl', $count, $FH);
$terminal->Tpad($string, $count, $FH);
Or you can be studly and use Curses and/or the Curses:Widget module from
CPAN. Here's a kludged up demo a thwapped together the other day. I wish I'd
known as much at the beginning as I did at the end. :-)
People seeking a raw getchar might scroll to the very bottom. I had
to write my own with POSIX, although I could have used Term::ReadKey's
"ultraraw" mode.
--tom
#!/usr/bin/perl -w
#
# iotutor - teach people bytestream model
# tchrist@perl.com
# completely alpha version!!
use strict;
use Curses;
use Fcntl;
use Carp;
use sigtrap qw(die normal-signals);
use Text::Wrap;
# too slow
#use FindBin;
#use lib "$FindBin::Bin/lib";
# this is expected to be @INC, and is supplied
use Errno::Msgs;
$SIG{__WARN__} = sub {
error_message("perl warning: @_");
confess("unexpected warning promoted into fatal:\n\t@_\nTraceback:\n");
};
my %KeyCmd = (
'o' => \&cmd_open,
'c' => \&cmd_close,
'r' => \&cmd_read,
'y' => \&cmd_read,
'w' => \&cmd_write,
'p' => \&cmd_write,
'P' => \&cmd_write_before, # put before
'W' => sub { cmd_write(1) },
's' => \&cmd_seek,
'#' => \&cmd_seek,
't' => \&cmd_truncate,
'D' => sub { cmd_truncate(1) },
'e' => \&cmd_edit,
'q' => \&cmd_quit,
'm' => \&cmd_manpage,
'?' => \&cmd_help,
KEY_LEFT() => \&curse_left,
KEY_RIGHT() => \&curse_right,
'h' => \&curse_left,
'l' => \&curse_right,
KEY_NPAGE() => \&page_right,
KEY_PPAGE() => \&page_left,
"\cF" => \&page_right,
"\cB" => \&page_left,
">" => \&page_right,
"<" => \&page_left,
"\t" => \&page_right,
'^' => \&zip_left,
'$' => \&zip_right,
' ' => \&curse_right,
KEY_BACKSPACE() => \&curse_left,
);
my $FW;
BEGIN {
my $Screen_Enabled = 0;
use Carp;
$SIG{__DIE__} = sub {
disable_screen();
my $fn = \&confess;
for (my $i = 0; my @ci = caller($i); $i++) {
if ($ci[3] eq 'Carp::confess') {
$fn = sub { print STDERR @_; POSIX::_exit(1) };
}
}
$fn->("Uncaught exception: @_\n") if @_;
};
sub disable_screen {
if ($Screen_Enabled) {
endwin();
$Screen_Enabled = 0;
}
}
sub enable_screen {
unless ($Screen_Enabled) {
initscr();
noecho();
cbreak();
keypad(1); # enable keypad mode
$Screen_Enabled = 1;
}
}
sub Curses::DESTROY() { }
}
sub main {
enable_screen(); # start screen
if (@ARGV) {
cmd_open($ARGV[0]);
}
while (1) {
show_commands();
halfdelay(5); # so getch() is non-blocking
if ((my $key = getch()) ne ERR) { # maybe multiple keys
if (my $func = $KeyCmd{$key}) {
$func->();
next;
}
error_message("Unknown key: " .
( unkey($key) || uncontrol($key)) );
next;
}
clock();
}
}
main(@ARGV);
exit();
END {
disable_screen();
}
############### ############### ############### ###############
sub cmd_help {
my(
$new_width,
$new_height,
$start_x,,
$start_y,
@file_commands,
@misc_commands,
@move_commands,
);
@file_commands = (
['o', 'open file'],
['c', 'close file'],
['r,y', 'read into buffer'],
['w,p', 'overwrite after CUR'],
['W', '!overwrite after CUR'],
['P', 'overwrite before CUR'],
['t', 'truncate at CUR'],
['D', '!truncate at CUR'],
['s,#', 'seek to offset'],
);
@misc_commands = (
['?', 'this help'],
['m', 'manpage'],
['e', 'edit buffer'],
['q', 'quit program'],
);
@move_commands = (
['RIGHT, SPC, l', 'seek +1'],
['NPAGE, TAB, ^F, >', 'next screen'],
['LEFT, BSP, h', 'seek -1'],
['PPAGE, ^B, <', 'prev screen'],
['^', 'start of view'],
['$', 'end of view'],
);
$new_width = int(0.80 * $COLS);
$start_x = int(0.10 * $COLS);
$new_height = int(0.80 * $LINES);
$start_y = int(0.10 * $LINES);
my $boxwin = Curses->new($new_height, $new_width, $start_y, $start_x)
|| confess("no boxwin: $new_height, $new_width,$start_y, $start_x");
$boxwin->box(ACS_VLINE, ACS_HLINE);
$boxwin->refresh();
my $helpwin = $boxwin->new($new_height-2, $new_width-2, $start_y+1, $start_x+1)
|| panic("no helpwin: $new_height-2, $new_width-2, 1, 1");
local *write_column = sub {
my($name, $cmdlist, $top_y, $top_x) = @_;
my($keywidth,$cmdwidth) = (0,0);
for my $pair ( @$cmdlist ) {
if (length($pair->[0]) > $keywidth) {
$keywidth = length($pair->[0]);
}
if (length($pair->[1]) > $cmdwidth) {
$cmdwidth = length($pair->[1]);
}
}
$keywidth = 3 if $keywidth < 3;
my $desc_column = $keywidth + 3;
my $line = $top_y;
# write header
$helpwin->move($line, $top_x);
$helpwin->attrset(A_REVERSE);
$helpwin->addstr("Key");
$helpwin->move($line, 2 + $top_x + $keywidth);
$helpwin->addstr("$name Command");
$helpwin->attrset(A_NORMAL);
$line++;
for my $pair ( @$cmdlist ) {
$helpwin->move($line, $top_x);
$helpwin->attrset(A_BOLD);
$helpwin->addstr($pair->[0]);
$helpwin->move($line, 2 + $top_x + $keywidth);
$helpwin->attrset(A_NORMAL);
$helpwin->addstr($pair->[1]);
$line++;
}
};
write_column("Move", \@move_commands, 0, int($new_width/2));
write_column("File", \@file_commands, 0, 0);
write_column("Misc", \@misc_commands, @file_commands + 2, 0);
$helpwin->refresh();
more($helpwin);
$helpwin->delwin();
$boxwin->delwin();
touchwin();
}
sub cmd_open {
my $file;
if (@_) {
$file = $_[0];
} else {
$file = prompt("File to open? ");
}
return unless length($file);
if (defined fileno(*CURFILE)) {
close *CURFILE;
show_fileinfo();
}
unless (sysopen(CURFILE, $file, O_RDWR)
||
sysopen(CURFILE, $file, O_RDONLY) )
{
syserr("open", 0+$!);
return;
}
binmode(CURFILE); # for idiot systems
$FW = new FileView "HANDLE" => *CURFILE;
show_fileinfo();
slow_message("open succeeded");
}
sub show_fileinfo {
show_metadata();
show_contents();
}
sub cmd_close {
if (close(CURFILE)) {
show_fileinfo();
slow_message("close succeeded");
}
else {
syserr("close", 0+$!);
}
}
BEGIN {
my $Buffer = '';
sub clear_buffer {
$Buffer = '';
}
sub cmd_edit {
return unless $FW;
$FW->calculate_screen_location()
unless defined $FW->{SCREEN_ROW};
my $row = $FW->{SCREEN_ROW} + 6;
move($row, 0);
attron(A_REVERSE);
addstr("Buffer");
attrset(A_NORMAL);
addstr(": ");
$Buffer = editline($Buffer);
# show_buffer();
}
sub show_buffer {
return unless $FW;
$FW->calculate_screen_location()
unless defined $FW->{SCREEN_ROW};
my $row = $FW->{SCREEN_ROW} + 6;
move($row, 0);
attron(A_REVERSE);
addstr("Buffer");
attrset(A_NORMAL);
addstr(": ");
addstr(uncontrol($Buffer));
clrtoeol();
}
sub cmd_read {
unless (defined fileno(*CURFILE)) {
error_message("cannot read until you open");
return;
}
my $bytes;
GET_BYTES:
{
$bytes = prompt("Read how many bytes? ");
if ($bytes eq '$') {
$bytes = filesize(*CURFILE);
}
if ($bytes !~ /^\d+$/) {
error_message("Need integral bytecount to read");
return;
}
if ($bytes > $FW->{MAX_PRINTLEN}) {
error_message("Sorry, your buffer isn't that big(yet)");
redo GET_BYTES;
}
}
my $howmany = sysread(*CURFILE, $Buffer, $bytes);
unless (defined $howmany) {
syserr("read", $!+0);
return;
}
show_buffer();
show_fileinfo();
slow_message("read $howmany bytes");
}
sub cmd_write_before {
my $no_confirm = @_ ? shift : 0;
unless (defined fileno(*CURFILE)) {
error_message("cannot write until you open");
return;
}
my $len = length($Buffer);
if (!$len) {
error_message("No buffer to write");
return;
}
unless ($no_confirm) {
return unless boolprompt("Really overwrite behind you?");
}
if (cmd_seek( -$len )) {
cmd_write(1);
}
}
sub cmd_write {
my $no_confirm = @_ ? shift : 0;
unless (defined fileno(*CURFILE)) {
error_message("cannot write until you open");
return;
}
unless ($no_confirm) {
return unless boolprompt("Really overwrite existing filedata"
. " on disk with buffer?");
}
my $old_pointer = $FW->left_seek();
my $howmany = syswrite(*CURFILE, $Buffer,
length($Buffer)); # soon optional
unless (defined $howmany) {
syserr("write", $!+0);
return;
}
$FW->refresh_arrow(systell());
show_fileinfo();
slow_message("wrote $howmany bytes");
}
}
sub set_pointer {
my $place = shift;
sysseek(*CURFILE, $place, 0) || confess("seek failed: $!");
}
sub cmd_seek {
my $whither = $_[0];
unless (defined fileno(*CURFILE)) {
error_message("Can't seek until you open");
return;
}
unless (@_) {
$whither = prompt("Seek to position: ");
}
my $whence = 0;
return unless length($whither);
$whither =~ s/\s//g;
unless ($whither =~ /^\$\Z|[\$]?[\-+]?\d+$/) {
error_message("Bad seek destination: $whither");
return;
}
if ($whither =~ s/^\$//) {
$whence = 2;
$whither =~ s/^\+//;
$whither = 0 unless length $whither;
}
elsif ($whither =~ s/^\+// || $whither =~ m/^-/) {
$whence = 1;
}
if (sysseek(*CURFILE, $whither, $whence)) {
show_fileinfo();
refresh();
slow_message("seek succeeded");
return 1;
}
else {
syserr("lseek", $!+0);
return 0;
}
}
sub cmd_truncate {
my $no_confirm = @_ ? shift : 0;
unless (defined fileno(*CURFILE)) {
error_message("cannot write until you open");
return;
}
my $curpos = systell(*CURFILE) || 0;
unless ($no_confirm) {
my $where = $curpos ? "after byte $curpos" : "in file";
return unless boolprompt("Really destroy all data $where?");
}
unless (truncate(*CURFILE, $curpos)) {
syserr("ftruncate", $!+0);
return;
}
$FW->refresh_arrow($curpos);
show_fileinfo();
slow_message("truncated to $curpos bytes");
}
sub cmd_manpage {
my(
$new_width,
$new_height,
$start_x,,
$start_y,
@msglines,
);
$start_x = int(0.10 * $COLS);
$start_y = int(0.40 * $LINES);
$new_width = int(0.80 * $COLS);
local $Text::Wrap::columns = $new_width - 5;
@msglines = ( wrap("Q: ", " ", <<EOQ), '',
How do I insert a line in a text file?
EOQ
wrap("A: ", " ", <<EOA) );
You can't, because a text file is like a tape casette, not like a deck of playing cards!
EOA
$new_height = 6 + @msglines;
my $boxwin = Curses->new($new_height, $new_width, $start_y, $start_x)
|| confess("no boxwin: $new_height, $new_width,$start_y, $start_x");
$boxwin->box(ACS_VLINE, ACS_HLINE);
$boxwin->refresh();
my $errwin = $boxwin->new($new_height-2, $new_width-2, $start_y+1, $start_x+1)
|| panic("no errwin");
my $line = 0;
$errwin->attron(A_REVERSE);
$errwin->addstr($line++, 0, "Abbreviated Manpage");
$errwin->attrset(A_NORMAL);
for (@msglines) { $errwin->addstr($line++, 0, $_) }
$errwin->refresh();
more($errwin);
$errwin->delwin();
$boxwin->delwin();
touchwin();
}
sub cmd_quit {
message("See ya!");
clear_bottom();
refresh();
exit();
}
sub show_form {
show_fileinfo();
show_buffer();
show_contents();
show_commands();
refresh(); # flush new output to display
}
sub show_contents {
$FW->display();
show_metadata();
}
sub show_metadata {
my @sb;
my $fd;
clear_meta_area();
if (defined ($fd = fileno(*CURFILE))) {
@sb = stat(*CURFILE);
my $line = 0;
#addstr($line++, 0, "File Metadata: fd=$fd");
attron(A_REVERSE);
addstr($line++, 0, "File Metadata");
attrset(A_NORMAL);
addstr(" fd=$fd");
addstr($line++, 0, " size: $sb[7] bytes");
addstr($line++, 0, " dev/ino: $sb[0]/$sb[1] ");
#addstr($line++, 0, " blocks: $sb[12] blocks @ $sb[11] bytes");
addstr($line++, 0, " atime: " . localtime($sb[8]));
addstr($line++, 0, " mtime: " . localtime($sb[9]));
addstr($line++, 0, " ctime: " . localtime($sb[10]));
addstr($line++, 0, " seek point: ");
my $place = systell(*CURFILE);
if (defined $place) {
addstr($place);
} else {
attron(A_BOLD);
addstr($place = "UNDEFINED");
attron(A_NORMAL);
}
my $flen = filesize(*CURFILE);
return if !defined $flen;
return if $place eq 'UNDEFINED';
if ($place == $flen) {
addstr(" ");
attron(A_BOLD);
addstr("(at EOF)");
attrset(A_NORMAL);
}
elsif ($place > $flen) {
addstr(" ");
attron(A_REVERSE);
addstr("(beyond EOF)");
$FW->clear_arrow_display();
attrset(A_NORMAL);
}
}
}
sub show_commands {
move($LINES-1, 0);
attron(A_REVERSE);
addstr("Commands");
attrset(A_NORMAL);
addstr(": ");
attrset(A_BOLD);
if (!defined fileno(*CURFILE)) {
addstr( "open edit ?help");
}
elsif (!defined systell(*CURFILE)) {
addstr( "open close read write trunc ?help");
}
else {
addstr( "open close read write seek trunc ?help");
}
attrset(A_NORMAL);
clrtoeol(); # just in case
}
sub events {
my($x, $y);
save_cursor();
#show_metadata();
clock();
restore_cursor();
refresh();
}
sub clock {
my $now = localtime();
addstr(0, $COLS - length $now, $now);
}
sub message {
my $msg = "@_";
move($LINES-1, 0);
clrtoeol();
addstr($LINES-1, 0, $msg);
refresh();
}
sub confirm_message {
save_cursor();
goto_bottom();
my $oldstr;
instr($oldstr);
message(@_);
more();
message($oldstr);
restore_cursor();
}
sub error_message {
beep();
attron(A_BOLD);
slow_message("Error:",@_);
attrset(A_NORMAL);
}
sub uncontrol {
local($_) = @_;
confess("undef arg?") unless defined;
s/\n/\\n/g;
s/\r/\\r/g;
s/\a/\\b/g;
s/\f/\\f/g;
s/\t/\\t/g;
s/([\200-\237])/sprintf("\\x%02x",ord($1))/eg;
s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
return $_;
}
sub unkey {
my $key = shift;
my $name;
if ($key && $key =~ /^\d+/ && $key > 0177) {
$name = keyname($key);
$name = '' if $name eq chr(0);
}
return $name;
}
sub goto_bottom() {
move($LINES-1, 0);
}
sub clear_bottom() {
goto_bottom();
clrtoeol();
}
sub syserr {
my($syscall, $errno) = @_;
my(
$new_width,
$new_height,
$start_x,,
$start_y,
$errstr,
);
{
local $! = $errno;
$errstr = $! . "";
}
unless (boolprompt("$syscall failed: $errstr; more info?")) {
clear_bottom();
return;
}
$start_x = int(0.10 * $COLS);
$start_y = int(0.10 * $LINES);
$new_width = int(0.80 * $COLS);
local $Text::Wrap::columns = $new_width - 5;
my $extmsg = join(" -OR- ", errmsgs($syscall, $errno));
my @msglines = wrap(" ", " ", $extmsg);
$new_height = 6 + @msglines;
my $boxwin = Curses->new($new_height, $new_width, $start_y, $start_x)
|| confess("no boxwin: $new_height, $new_width,$start_y, $start_x");
$boxwin->box(ACS_VLINE, ACS_HLINE);
$boxwin->refresh();
my $errwin = $boxwin->new($new_height-2, $new_width-2, $start_y+1, $start_x+1)
|| panic("no errwin");
my $line = 0;
$errwin->attron(A_REVERSE);
$errwin->addstr($line++, 0, "Extended Error");
$errwin->attrset(A_NORMAL);
$errwin->addstr(" " . errname($errno) . ": $errstr");
for (@msglines) { $errwin->addstr($line++, 0, $_) }
$errwin->refresh();
more($errwin);
$errwin->delwin();
$boxwin->delwin();
touchwin();
#refresh();
}
sub syserr2 {
my($syscall, $errno) = @_;
my $errstr;
{
local $! = $errno;
$errstr = $! . "";
}
unless (boolprompt("$syscall failed: $errstr; more info?")) {
clear_bottom();
return;
}
my($y,$x);
save_cursor();
clear_meta_area();
my $line = 0;
attron(A_REVERSE);
addstr($line++, 0, "Extended Error");
attrset(A_NORMAL);
addstr(" " . errname($errno));
my $extmsg = join(" -OR- ", errmsgs($syscall, $errno));
my @msglines = wrap(" ", " ", $extmsg);
for (@msglines) {
addstr($line++, 0, $_);
}
restore_cursor();
more();
show_metadata();
}
sub clear_meta_area {
move(0,0);
addstr(0, 0, " " x 40);
for my $line (1 .. 10) {
addstr($line, 0, " " x 72);
clrtoeol();
}
}
sub quick_prompt {
my($msg) = @_;
clear_bottom();
attron(A_BOLD);
addstr($LINES-1, 0, $msg);
attrset(A_NORMAL);
move($LINES-1, length($msg));
my $key = slow_key();
#clear_bottom();
return $key;
}
sub boolprompt {
my($msg) = @_;
my $key;
$msg .= " (y/n) ";
do {
$key = quick_prompt($msg);
} until $key =~ /^[yn]$/;
return lc($key) eq 'y';
}
sub prompt {
my($msg) = @_;
my $input;
move($LINES-1,0);
clrtoeol();
attron(A_BOLD);
addstr($LINES-1, 0, $msg);
attrset(A_NORMAL);
my $file;
$input = editline();
trim($input);
clear_bottom();
return trim($input);
}
sub trim {
my @out = @_;
for (@out) {
s/^\s+//;
s/\s+$//;
}
return @out if wantarray;
return '' if @out == 0;
return $out[0];
}
sub more {
my $win = @_ ? $_[0] : stdscr();
my ($lines, $cols);
$win->getmaxyx($lines, $cols);
$win->move($lines-1, $cols - 6);
$win->attron(A_REVERSE);
$win->addstr("-More-");
$win->attrset(A_NORMAL);
$win->refresh();
my $key;
beep() until slow_key() =~ /[\sqy]/i;
flushinp();
return $key;
}
sub slow_key {
#halfdelay(10);
notimeout(0);
my $key;
flushinp();
while (($key = getch()) eq ERR) {
events();
}
return $key;
}
sub quick_key {
notimeout(0);
flushinp();
my $key = getch();
return $key;
}
sub slow_message {
message(@_);
refresh();
isleep(1);
}
# use this instead of sleep so that a keystroke on
# stdin will interrupt the sleep
sub isleep {
my $timeout = $_[0];
my ($in, $out) = ('', '');
vec($in,fileno(STDIN),1) = 1; # look for key on stdin
select($out = $in,undef,undef,$timeout);# wait up to this long
}
BEGIN {
my $confessking = 0;
sub panic {
delete $SIG{__WARN__};
delete $SIG{__DIE__};
if (0 and $confessking++) {
syswrite(STDERR, "Recursive confess\r\n", 17);
POSIX::_exit(1);
}
confess("confess: @_");
# XXX: NOTREACHED
$confessking = 0;
}
}
BEGIN {
my @cursor_stack;
sub save_cursor {
my($y,$x);
getyx($y,$x);
push @cursor_stack, [$y, $x];
}
sub restore_cursor {
confess("no cursor to restore") unless @cursor_stack;
move(@{ pop @cursor_stack});
}
}
sub systell(;*) {
local *FH = @_ ? $_[0] : *CURFILE;
my $offset = sysseek(*FH, 0, 1);
return undef unless defined $offset;
return $offset + 0; # dang 0 but true
}
sub curse_right {
return unless defined fileno(*CURFILE);
#return unless systell(*CURFILE) < filesize(*CURFILE);
sysseek(*CURFILE, 1, 1);
show_contents();
}
sub curse_left {
unless (defined fileno(*CURFILE) && systell(*CURFILE)) {
cmd_help();
return;
}
sysseek(*CURFILE, -1, 1);
show_contents();
}
sub page_left {
return unless defined fileno(*CURFILE);
my $position = systell(*CURFILE);
return unless $position;
$position -= $FW->max_printlen();
$position = 0 if $position < 0;
sysseek(*CURFILE, $position, 0)
|| confess("seek to $position failed: $!");
show_contents();
}
sub page_right {
return unless defined fileno(*CURFILE);
my $position = systell(*CURFILE);
return if $position == filesize(*CURFILE);
$position += $FW->max_printlen();
my $flen = filesize(*CURFILE);
$position = $flen if $position > $flen;
sysseek(*CURFILE, $position, 0)
|| confess("seek to $position failed: $!");
show_contents();
}
sub zip_right {
return unless defined fileno(*CURFILE);
my $position = systell(*CURFILE);
return if $FW->arrow_col() ==
( $FW->screen_row() + $FW->max_printlen() );
$position = $FW->left_seek() + length($FW->raw_string()) - 1;
sysseek(*CURFILE, $position, 0)
|| confess("seek to $position failed: $!");
show_contents();
}
sub zip_left {
return unless defined fileno(*CURFILE);
my $position = systell(*CURFILE);
return if $position == $FW->left_seek();
# return if $FW->arrow_col() == $FW->screen_row();
$position = $FW->left_seek();
sysseek(*CURFILE, $position, 0)
|| confess("seek to $position failed: $!");
show_contents();
}
sub filesize(;*) {
my $fh = shift || *CURFILE;
return -s($fh);
}
BEGIN {
package FileView;
use Curses;
use Carp;
# XXX: fix this cavalier import
*uncontrol = \&main::uncontrol;
sub new {
my $class = shift;
my $object = {
HANDLE => undef, # what filehandle we're viewing
STICKY_PLACEMENT => undef, # [row,col] explicitly set
SCREEN_ROW => undef, # row at which we start
SCREEN_COL => undef, # col at which we start
ARROW_COL => undef, # where our graphic arrow now is
LEFT_SEEK => undef, # current fileview anchored here
RAW_STRING => undef, # current raw read-in buffer
PRINT_STRING => undef, # escaped version of buffer
MAX_PRINTLEN => undef, # how much we can print at once
SCROLLBAR => undef, # ascii proportional scrollbar
@_, # extra constructor arguments?
};
$object->{SCREEN_COL} = 0;
$object->{MAX_PRINTLEN} = $COLS;
bless($object, $class);
return $object;
}
{
my $tmp = __PACKAGE__ -> new();
for my $field (keys %$tmp) {
no strict 'refs';
*{ lc($field) } = sub {
my $self = shift;
if (@_) {
$self->{$field} = $_[0];
}
return $self->{$field};
};
}
}
sub clear_arrow_display {
my $self = shift;
my $row = $self->{SCREEN_ROW};
my $col = $self->{SCREEN_COL};
if (defined $row) {
for my $offset (0 .. 2) {
# don't use $col here because they might
# want to change the horizontal start point
move($row + $offset, 0);
clrtoeol();
}
}
}
sub display {
my $self = shift;
# clear old display first, then recalculate
# midpoint; this way we do resizes right
$self->clear_arrow_display();
$self->calculate_screen_location();
$self->sync_dataview();
}
sub dump {
my $self = shift;
print STDERR "Dump: \n";
for my $field ( sort keys %$self ) {
printf STDERR " %s: %s\r\n",
$field, defined($self->{$field})
? $self->{$field}
: "UNDEFINED FIELD";
}
}
sub calculate_screen_location {
my $self = shift;
if ($self->{STICKY_PLACEMENT}) {
$self->{SCREEN_ROW} = $self->{STICKY_PLACEMENT}->[0];
$self->{SCREEN_COL} = $self->{STICKY_PLACEMENT}->[1];
}
else {
$self->{SCREEN_COL} = 0;
for my $line ($self->{SCREEN_ROW}) {
$line = int($LINES / 2 + 0.5) - 1;
if ($line < 12) {
$line = 12
}
}
}
}
sub set_width {
my($self, $width) = @_;
unless (@_ == 1 && $width =~ /^\d+/ && $width > 0) {
confess("bad argument, need positive width");
}
$self->{MAX_PRINTLEN} = $width;
}
sub get_width {
my($self) = @_;
my $width;
unless ($width = $self->{MAX_PRINTLEN}) {
$width = $COLS - $self->{SCREEN_COL};
}
return $width;
}
sub set_placement {
my $self = shift;
my %parms = @_;
my ($row, $col);
# e.g. set_placement(ROW => 12)
# or set_placement(ROW => 12, COLUMN => 3);
# haven't make up my mind yet
$col = $parms{ROW} if defined $parms{ROW};
$col = $parms{COLUMN} if defined $parms{COLUMN};
$col = $parms{X} if defined $parms{X};
$row = $parms{LINE} if defined $parms{LINE};
$row = $parms{Y} if defined $parms{Y};
# or using set_placement(12) or set_placement(12,3)
($row, $col) = @_ unless defined $row;
$col = 0 unless defined $col;
$self->{STICKY_PLACEMENT} = [ $row, $col ];
}
sub is_open {
my $self = shift;
defined fileno($self->{HANDLE});
}
sub seek_pointer {
my $self = shift;
return unless $self->is_open();
my $offset = sysseek($self->{HANDLE}, 0, 1);
return unless defined $offset;
return $offset + 0; # dang 0 but true
}
sub set_position {
my $self = shift;
# FIXME
}
sub read_byte {
my $self = shift;
my $char;
return unless sysread($self->{HANDLE}, $char, 1);
return $char;
}
# this not only prints the arrow for the seek pointer, it also
# fills the print and raw buffers as needed if repositioning is
# required. the old seek pointer is restored if any reading
# is done.
sub set_arrow {
my($self) = @_;
my $place = $self->seek_pointer();
return unless defined $place; # not seekable file
return if $place > $self->filesize();
# in current view
if (defined $self->{LEFT_SEEK} &&
$place >= $self->{LEFT_SEEK} &&
$place < $self->{LEFT_SEEK} + length($self->{RAW_STRING}))
{
$self->print_arrow($place);
return;
}
# just one more. we need this mess to get horizontal
# scrolling to the right to work properly
if ( defined $self->{LEFT_SEEK} &&
$place == $self->{LEFT_SEEK} + length($self->{RAW_STRING})
)
{
my $newbyte = $self->read_byte();
if (defined $newbyte) {
# restore place
sysseek($self->{HANDLE}, $place, 0); # XXX: failure?
$self->{LEFT_SEEK}++;
my $print_string = uncontrol($newbyte);
$self->{RAW_STRING} .= $newbyte;
my $need_killed = length $print_string;
do {
my $first_char =
substr($self->{RAW_STRING}, 0, 1);
substr($self->{RAW_STRING}, 0, 1) = '';
$need_killed -= length(uncontrol($first_char));
} while $need_killed > 0;
$self->{PRINT_STRING} = uncontrol($self->{RAW_STRING});
addstr($self->{SCREEN_ROW}, $self->{SCREEN_COL}+1,
$self->{PRINT_STRING});
my $newcol = $self->{SCREEN_COL}
+ $self->{MAX_PRINTLEN}
- length($print_string);
# addstr($self->{SCREEN_ROW}, $newcol, $print_string);
}
$self->print_arrow($place);
return;
}
# otherwise, not yet in current view
$self->{LEFT_SEEK} = $place;
my $max_width = $self->get_width();
my $strwidth = $max_width - 2;
my $view_string = '';
my $count = 0;
my $hit_eof;
my $raw_string = '';
while (length($view_string) < $strwidth) {
my $char = '';
if (!defined($char = $self->read_byte())) {
$hit_eof = 1;
last;
}
$count++;
my $viewable = uncontrol($char);
last if length($view_string . $viewable) > $strwidth;
$raw_string .= $char;
$view_string .= $viewable;
}
$self->{RAW_STRING} = $raw_string;
$self->{PRINT_STRING} = $view_string;
# restore old place
sysseek($self->{HANDLE}, $place, 0); # XXX: failure?
$self->print_arrow($place);
}
sub print_arrow {
my ($self, $place) = @_;
confess("need place argument") unless @_ == 2;
# remove old arrow
addstr(2+$self->{SCREEN_ROW}, $self->{ARROW_COL}, " ")
if defined $self->{ARROW_COL};
# make new arrow
my $offset = $place - $self->{LEFT_SEEK};
my $width = length(uncontrol(
substr($self->{RAW_STRING}, 0, $offset)));
$self->{ARROW_COL} = $width + 1 + $self->{SCREEN_COL};
move(2+$self->{SCREEN_ROW}, $self->{ARROW_COL});
attrset(A_ALTCHARSET);
addch(ACS_UARROW);
attrset(A_NORMAL);
}
# pretend we don't know what's in view (invalidated)
sub refresh_arrow {
my $self = shift;
my $fresh_point = shift;
my $old_left = $self->{LEFT_SEEK};
return unless defined $old_left;
undef $self->{LEFT_SEEK};
sysseek($self->{HANDLE}, $old_left, 0); # XXX: shouldn't need both
$self->set_arrow($old_left); # FIXME api
sysseek($self->{HANDLE}, $fresh_point, 0); # XXX: shouldn't need both
$self->set_arrow($fresh_point); # FIXME api
}
sub filesize {
my $self = shift;
return -s($self->{HANDLE});
}
sub sync_dataview {
my $self = shift;
return unless $self->is_open();
# prints arrow and fills buffers
$self->set_arrow();
# LEFT_SEEK set by set_arrow
return unless defined $self->{LEFT_SEEK};
my $filesize = -s($self->{HANDLE});
my $barline = $self->compute_bar_line(
$filesize,
$self->{LEFT_SEEK},
length($self->{PRINT_STRING}));
addstr($self->{SCREEN_ROW}, $self->{SCREEN_COL}, $barline);
addstr(1 + $self->{SCREEN_ROW},
1 + $self->{SCREEN_COL},
$self->{PRINT_STRING});
}
sub compute_bar_line {
my $self = shift;
my($buflen, $curpos, $visible) = @_;
my $cols = $self->get_width();
$visible = $cols unless $visible;
my($bar) = '-' x $self->{MAX_PRINTLEN};
my($start, $width, $end);
if ($buflen) {
$start = $curpos / $buflen;
$start = int( $start * $visible + 0.5 );
$end = int( $visible * (($curpos + $visible) / $buflen)
+ 0.5 );
$end = $cols if $end >= $cols;
$end--;
if ($end == $cols) {
$end = $cols - 1;
}
if ($start == $end || $end < $start) {
substr($bar, $start||1, 1) = '|';
}
elsif ($buflen > $visible) {
substr($bar, $start, 1) = '(';
substr($bar, $end, 1) = ')';
}
# FIXME: sometimes the buck is one over, sometimes two!
if ($self->{LEFT_SEEK} + length($self->{RAW_STRING})
>= -s(*::CURFILE))
{
substr($bar, $end+2, 1) = '$' if length($bar) > $end+2;
}
substr($bar, 0, 1) = '[';
substr($bar, length($bar) - 1, 1) = ']';
substr($bar, length($bar) - 2, 1) = '(';
}
return $bar;
}
}
BEGIN {
my(
$my_erase,
$my_werase,
$my_kill,
$Termios,
);
sub get_tty {
use subs qw(VERASE VKILL);
if ($Termios || eval "use POSIX qw(:termios_h); 1") {
$Termios = POSIX::Termios->new unless $Termios;
$Termios->getattr(fileno(STDIN));
$my_erase = chr($Termios->getcc(POSIX::VERASE()));
$my_kill = chr($Termios->getcc(POSIX::VKILL()));
$Termios->setattr(fileno(STDIN));
} else {
$my_erase = "\cH";
$my_kill = "\cU";
}
$my_werase = "\cW";
}
get_tty();
sub editline {
my($contents) = @_;
$contents = '' unless @_;
my($orig_y,$orig_x);
getyx($orig_y,$orig_x);
addstr(uncontrol($contents)) if length $contents;
clrtoeol();
my $keystroke;
my $position = length($contents);
notimeout(1);
while ( ($keystroke = slow_key()) ne ERR ) {
if ($keystroke eq "\cF" || $keystroke eq KEY_RIGHT) {
if ($position < length($contents)) {
$position++;
move($orig_y, $orig_x +
length(uncontrol(substr($contents,0,$position))));
}
next;
}
if ($keystroke eq KEY_UP || $keystroke eq KEY_DOWN) {
# skip these because they have no meaning in linemode
next;
}
if ($keystroke eq KEY_IC) {
# skip these because they have no meaning in linemode
next;
}
if ($keystroke eq "\cB" || $keystroke eq KEY_LEFT) {
if ($position > 0) {
$position--;
move($orig_y, $orig_x +
length(uncontrol(substr($contents,0,$position))));
}
next;
}
if ($keystroke eq "\cA") {
$position = 0;
move($orig_y,$orig_x);
next;
}
if ($keystroke eq "\cE") {
$position = length $contents;
move($orig_y, $orig_x + length(uncontrol($contents)));
next;
}
if ($keystroke eq "\n") {
last;
}
if ($keystroke eq $my_erase || $keystroke eq KEY_BACKSPACE) {
if ($position > 0) {
$position--;
move($orig_y, $orig_x +
length(uncontrol(substr($contents,0,$position))));
my $deadchar = uncontrol(substr($contents,$position,1));
for (1 .. length($deadchar)) {
delch();
}
eval {
substr($contents,$position,1) = '';
};
if ($@) {
die "eval failed of substr $contents,$position: $@";
}
}
next;
}
if ($keystroke eq chr(0177)) {
if ($position <= length($contents)) {
my $deadchar = uncontrol(substr($contents,$position,1));
for (1 .. length($deadchar)) {
delch();
}
substr($contents,$position,1) = '';
move($orig_y, $orig_x +
length(uncontrol(substr($contents,0,$position))));
}
next;
}
if ($keystroke eq $my_kill) {
move($orig_y, $orig_x);
$contents = '';
$position = 0;
clrtoeol();
next;
}
if ($keystroke eq $my_werase) {
if ($position > 0) {
if (substr($contents, 0, $position)
=~ s/(.*?)(\S*\s*$)/$1/s)
{
$position = length uncontrol($1);
move($orig_y, $orig_x);
addstr(uncontrol($contents)) if length $contents;
clrtoeol();
move($orig_y, $orig_x +
length(uncontrol(substr($contents,0,$position))));
}
}
next;
}
if ($keystroke eq "\cR") {
move($orig_y, $orig_x);
addstr(uncontrol($contents)) if length $contents;
clrtoeol();
move($orig_y, $orig_x +
length(uncontrol(substr($contents,0,$position))));
next;
}
if (unkey($keystroke)) {
# error_message(unkey($keystroke) . " ignored");
# skip these because they have no meaning in linemode
next;
}
if ($keystroke eq "\cV") {
addstr("^");
move($orig_y, $orig_x +
length(uncontrol(substr($contents,0,$position))));
refresh();
keypad(0);
$keystroke = raw_getch();
keypad(1);
cbreak();
# FALL THROUGH
}
if ($position < length $contents) {
substr($contents, $position, 1) = $keystroke;
$position++;
move($orig_y, $orig_x);
addstr(uncontrol($contents)) if length $contents;
clrtoeol();
move($orig_y, $orig_x +
length(uncontrol(substr($contents,0,$position))));
} else {
$contents .= $keystroke;
$position++;
addstr(uncontrol($keystroke));
}
} continue {
refresh();
}
return $contents;
}
sub raw_getch() {
use subs qw(IGNBRK BRKINT PARMRK ISTRIP INLCR IGNCR ICRNL IXON
OPOST ECHO ECHONL ICANON ISIG IEXTEN CSIZE PARENB CS8);
# XXX: would savetty() and restoretty() work here?
raw();
my ($old_iflag, $old_oflag, $old_lflag, $old_cflag);
if ($Termios || eval "use POSIX qw(:termios_h); 1") {
$Termios = POSIX::Termios->new unless $Termios;
$Termios->getattr(fileno(*STDIN));
$Termios->setiflag(($old_iflag = $Termios->getiflag()) &
~(IGNBRK|BRKINT|PARMRK|ISTRIP|INLCR|IGNCR|ICRNL|IXON));
$Termios->setoflag(($old_oflag = $Termios->getoflag()) & ~OPOST());
$Termios->setlflag(($old_lflag = $Termios->getlflag()) &
~(ECHO|ECHONL|ICANON|ISIG|IEXTEN));
$Termios->setcflag(($old_cflag = $Termios->getcflag()) &
~(CSIZE|PARENB));
$Termios->setcflag( $Termios->getcflag() | CS8 );
}
my $char;
sysread(*STDIN, $char, 1);
noraw();
cbreak();
if ($Termios) {
$Termios->setiflag($old_iflag);
$Termios->setoflag($old_oflag);
$Termios->setlflag($old_lflag);
$Termios->setcflag($old_cflag);
}
return $char;
}
}
__END__
--
"The printing on the t-shirt was not an encrypted message, it was a Perl
script... " (Don Henson, "alt.security.pgp" June 1995)
"You just contradicted yourself there... :-)" (Larry Wall,
"alt.security.pgp" June 1995, answer to Don Henson)
------------------------------
Date: Mon, 20 Sep 1999 13:23:47 -0400
From: jerrad pierce <jerrad@networkengines.com>
Subject: Re: Positioning the Cursor on a terminal
Message-Id: <37E66DA3.1CDF5A27@networkengines.com>
need more info. what platform?
in win32 use WIN32::Console;
in a sane environment se Curses;
------------------------------
Date: Mon, 20 Sep 1999 13:23:19 -0400
From: "Casey R. Tweten" <crt@kiski.net>
Subject: Re: Programmer Needed
Message-Id: <Pine.OSF.4.10.9909201306070.31154-100000@home.kiski.net>
On Mon, 20 Sep 1999, Tom Briles wrote:
:Uri Guttman wrote:
:>
:> >>>>> "DW" == Danum Web <webmaster@danum.com> writes:
:>
:> DW> Experienced programmer URGENTLY needed for several projects.
:> DW> Must have experience of all of the following:
:> DW> Perl, Mod Perl, C++, MySQL, Java, HTTP Sockets.
:>
:> what is an http socket? and where can i get one?
:>
:
:In my set, it's right between '20 mm' and 'Spark Plug'. Just above the
:ratchet.
sub dry_humor {
print <<__EOT__;
I got mine at Sears. I looked for Java while I was their too, but
couldn't find any. I was lost at Sears and ended up in the ladies
C++ section. I saw old mod_perl their (such a sweet old ladie), she
said, "Have you seen MySQL yet? It is even better than my first
movie." I told her that I hadn't seen it, but I do plan on it. In
any case, I managed to make it out of the ladies section, and then
decided to buy a ring for my "friend" (of the girl variety). I
stopped by the jewlrey section only to find the perfect ring, (can you
see this comming?) it had a big beautiful Perl on it! And I still
don't have any Java. :-(
__EOT__
}
dry_humor;
--
Casey R. Tweten <joke> This
Web Developer is 100% certified
HighVision Associates virus and bug
crt@highvision.com free code. </joke>
------------------------------
Date: Tue, 21 Sep 1999 00:38:03 +0800
From: Jonathan Teo <jonnyace@pacific.net.sg>
Subject: Qns about passing by reference, etc
Message-Id: <37E662EA.633F6DD6@pacific.net.sg>
I've been using Perl a bit now, but some points still escape me.
1. How do sub-routines change value of variables? eg, how would you
write something like chop(&)?
2. If a sub-routine creates an object (eg $x = new
SomeModule::SomeObject), how do you pass it out to the calling routine
without
$x being a global variable.
3. How do you redirect STDERR, eg, so that "die" messages will go into a
file rather than console?
Any pointers would be much appreciated.
Thanks in advance,
Jonathan Teo
------------------------------
Date: Mon, 20 Sep 1999 17:03:23 GMT
From: kragen@dnaco.net (Kragen Sitaker)
Subject: Re: Qns about passing by reference, etc
Message-Id: <vNtF3.22267$N77.1780329@typ11.nn.bcandid.com>
In article <37E662EA.633F6DD6@pacific.net.sg>,
Jonathan Teo <jonnyace@pacific.net.sg> wrote:
>1. How do sub-routines change value of variables? eg, how would you
>write something like chop(&)?
@_ consists of aliases to the real variables. Modifying items in @_
modifies the original variables.
>2. If a sub-routine creates an object (eg $x = new
>SomeModule::SomeObject), how do you pass it out to the calling routine
>without
> $x being a global variable.
return $x;
>3. How do you redirect STDERR, eg, so that "die" messages will go into a
>file rather than console?
open STDERR, ">a-file" or die "Couldn't open a-file: $!\n";
This script outputs 'yeah! at - line 4.' to a-file.
#!/usr/bin/perl -w
open STDERR, ">a-file" or die "Couldn't open a-file: $!";
warn "yeah!"
>Any pointers would be much appreciated.
char *x;
--
<kragen@pobox.com> Kragen Sitaker <http://www.pobox.com/~kragen/>
Mon Sep 20 1999
49 days until the Internet stock bubble bursts on Monday, 1999-11-08.
<URL:http://www.pobox.com/~kragen/bubble.html>
------------------------------
Date: Mon, 20 Sep 1999 13:42:54 -0400
From: "Peter Icaza" <picaza@chsi.com>
Subject: range of array indexes
Message-Id: <7s5rm0$d51o$1@pike.uhc.com>
hi,
i seem to come up with this problem often and i think that there must be a
better way. i want to put into a string, array elements x thru the end of
array. something like:
$str = array[$x-$#array];
or
$str = join(' ', array[$x-$#array] );
yet i do it in a loop as:
for ($X=7; $X<$Z; $X++)
{
$str.= "$array[$X] ";
}
i dont find anything addressing this. any pointers to resources or is this
"wish list" item a fantasy?
on going thanks cause i do learn
------------------------------
Date: Mon, 20 Sep 1999 13:59:44 -0400
From: "Allan M. Due" <Allan@due.net>
Subject: Re: range of array indexes
Message-Id: <7s5srv$eij$1@nntp2.atl.mindspring.net>
Peter Icaza wrote in message <7s5rm0$d51o$1@pike.uhc.com>...
:
:i seem to come up with this problem often and i think that there must
:be abetter way. i want to put into a string, array elements x thru the
:end of array. something like:
:
: $str = array[$x-$#array];
:or
:$str = join(' ', array[$x-$#array] );
:
:yet i do it in a loop as:
:for ($X=7; $X<$Z; $X++) {
: $str.= "$array[$X] ";
: }
:i dont find anything addressing this. any pointers to resources or is
:this "wish list" item a fantasy?
Why not just :
$str = join('',@array);
?
AmD
--
$email{'Allan M. Due'} = ' All@n.Due.net ';
--random quote --
Arithmetical proofs of theorems that do not have arithmetical bases
prove nothing.
- Ashley-Perry Statistical Axioms[5]
------------------------------
Date: 20 Sep 1999 12:23:10 -0400
From: Uri Guttman <uri@sysarch.com>
Subject: Re: s/// conditional substitution
Message-Id: <x7hfkp8scx.fsf@home.sysarch.com>
>>>>> "jp" == jerrad pierce <jerrad@networkengines.com> writes:
jp> s/(.)(.)/$2 eq a ? : $1."a" : $1."b"/e;
^
it would help if you test this before posting. it has a syntax error.
and using /e will work but a hash will do it simpler and faster:
%inex = ( in => '', ex => '^' ) ;
s/(in|ex)clude/$inex{$1}/ ;
<snip of jeopardy quote of entire post>
why do you do that?
uri
--
Uri Guttman ----------------- SYStems ARCHitecture and Software Engineering
uri@sysarch.com --------------------------- Perl, Internet, UNIX Consulting
Have Perl, Will Travel ----------------------------- http://www.sysarch.com
The Best Search Engine on the Net ------------- http://www.northernlight.com
"F**king Windows 98", said the general in South Park before shooting Bill.
------------------------------
Date: Mon, 20 Sep 1999 13:30:08 -0400
From: "Peter Icaza" <picaza@chsi.com>
Subject: Re: s/// conditional substitution
Message-Id: <7s5qu2$adr6$1@pike.uhc.com>
hi,
thanks to all for the help
this is what i came up with:
if ($subsetCriteria[$X] =~ (s/(.*) +(in|ex)clude +'?(.*)\b'?\s+(.*)/($2 eq
"in" ?"(_RC$Ctr = '1') $4":"^(_RC$Ctr = '1') $4")/e))
i would have like it better as something like:
if ($subsetCriteria[$X] =~ (s/(.*) +(in|ex)clude +'?(.*)\b'?\s+(.*)/($2
eq "in" ?"" : "^")(_RC$Ctr = '1') $4/e))
but alas it doesnt work that way :(
thanks again, i learned something.
------------------------------
Date: 20 Sep 1999 13:47:14 -0400
From: Uri Guttman <uri@sysarch.com>
Subject: Re: s/// conditional substitution
Message-Id: <x7aeqh8ogt.fsf@home.sysarch.com>
>>>>> "PI" == Peter Icaza <picaza@chsi.com> writes:
PI> hi,
PI> thanks to all for the help
PI> this is what i came up with:
PI> if ($subsetCriteria[$X] =~ (s/(.*) +(in|ex)clude +'?(.*)\b'?\s+(.*)/($2 eq
^
why the parens here? not needed at all.
use the /x modifier so you can write the regex on multiple lines with
comments. this is impossible to read.
PI> i would have like it better as something like:
PI> if ($subsetCriteria[$X] =~ (s/(.*) +(in|ex)clude +'?(.*)\b'?\s+(.*)/($2
PI> eq "in" ?"" : "^")(_RC$Ctr = '1') $4/e))
PI> but alas it doesnt work that way :(
use a hash like i posted. no need for /e
uri
--
Uri Guttman ----------------- SYStems ARCHitecture and Software Engineering
uri@sysarch.com --------------------------- Perl, Internet, UNIX Consulting
Have Perl, Will Travel ----------------------------- http://www.sysarch.com
The Best Search Engine on the Net ------------- http://www.northernlight.com
"F**king Windows 98", said the general in South Park before shooting Bill.
------------------------------
Date: Mon, 20 Sep 1999 09:16:02 -0700
From: moseley@best.com (Bill Moseley)
Subject: Re: Some e-mails get sent, some don't
Message-Id: <MPG.124ffd9d8f11fe9598975b@nntp1.ba.best.com>
Uri Guttman (uri@sysarch.com) seems to say...
> >> $addr =~ s/'/\\'/g;
> >> if(!open(M,"|mail '$addr'"){
>
> BM> I wonder that too. But I also wonder if someone could use LWP and
> BM> create a POST that includes, say ^U to empty the line buffer. Is that a
> BM> possibility?
>
> that would only work for an interactive shell which this surely is
> not.
Ok. What about the previous question:
>> $addr =~ s/'/\\'/g;
>> if(!open(M,"|mail '$addr'"){
Can anyone think of holes in that simple approach?
[Apologies for straying so far off the topic of c.l.p.m]
--
Bill Moseley mailto:moseley@best.com
pls note the one line sig, not counting this one.
------------------------------
Date: Mon, 20 Sep 1999 16:47:42 GMT
From: kragen@dnaco.net (Kragen Sitaker)
Subject: Re: Some e-mails get sent, some don't
Message-Id: <OytF3.22233$N77.1778328@typ11.nn.bcandid.com>
In article <m1n1uivehk.fsf@halfdome.holdit.com>,
Randal L. Schwartz <merlyn@stonehenge.com> wrote:
>>>>>> "Kragen" == Kragen Sitaker <kragen@dnaco.net> writes:
>Kragen> Don't allow everything not explicitly forbidden. Forbid everything not
>Kragen> explicitly allowed. And it probably doesn't have to work for "fred and
>Kragen> barney"@redcat.com; if someone has chosen such an obnoxious email
>Kragen> address, they deserve to have things break. (They are not being
>Kragen> conservative in what they send.)
>
>Kragen, I disagree with you again. Complex addresses are usually not
>"chosen", but rather "required" because of some corporate gateway or
>firewall, or perhaps a good spamtracking scheme.
>
>And sending valid RFC822 email address *is* being conservative.
>Please don't twist that phrase to mean anything you'd like it to
>mean... the people that invented it meant "don't transmit anything
>but what is permitted by the RFCs".
RFC 1122, the Host Requirements RFC:
At every layer of the protocols, there is a general rule whose
application can lead to enormous benefits in robustness and
interoperability [IP:1]:
"Be liberal in what you accept, and
conservative in what you send"
[discussion of "liberal" omitted"]
The second part of the principle is almost as important:
software on other hosts may contain deficiencies that make it
unwise to exploit legal but obscure protocol features. It is
unwise to stray far from the obvious and simple, lest untoward
effects result elsewhere. A corollary of this is "watch out for
misbehaving hosts"; host software should be prepared, not just
to survive other misbehaving hosts, but also to cooperate to
limit the amount of disruption such hosts can cause to the
shared communication facility.
The way I read this is not "don't transmit anything but what is
permitted by the RFCs". It says it may be that it is "unwise to
exploit legal but obscure protocol features".
(RFC 791, which is the IP:1 footnote above, does indeed explain the
principle to mean exactly what you said.)
I was advocating writing software with such deficiencies, because the
small-scale alternative is great complexity in a security-critical part
of the software. This obviously violates the "liberal in what you
accept" part of the dictum; indeed, it goes beyond not being liberal to
being conservative.
The slightly-larger-scale alternative is to fix the software so we
don't have to worry about shell metacharacters in people's email
addresses.
>The right way to handle an email address is to handle RFC email addresses.
>Period. Anything less, and you risk shutting out that BIG customer.
>
>Heck, I see stupid forms that don't even let me put in enough characters
>for stonehenge.com some times. Idjits.
Well, I guess you're right. Still, I don't trust anything much more
complex than that tr expression to filter out shell metacharacters.
Conclusion: don't send mail with system() or open X, "|mail $stuff".
This makes it safe to be *much* more liberal.
--
<kragen@pobox.com> Kragen Sitaker <http://www.pobox.com/~kragen/>
Mon Sep 20 1999
49 days until the Internet stock bubble bursts on Monday, 1999-11-08.
<URL:http://www.pobox.com/~kragen/bubble.html>
------------------------------
Date: Mon, 20 Sep 1999 18:17:38 +0200
From: Christoph Wernli <cw@dwc.ch>
Subject: Re: System Call only works on 4K of input
Message-Id: <37E65E22.DB1FEA6C@dwc.ch>
Uli Brass wrote:
>
> I have got a problem with a system call in my perl script. The script itself
> modifies the /etc/mail/virtusertable file and changes the sendmail virtual
> users. After the modification I call /usr/sbin/makemap (with sudo as root)
> to generate a hash table from the modified source file. The makmap command
> starts to convert the source but stops after exactly 4096 bytes. The rest of
> the virtusertable file is completely ignored.
> I use the makemap command in the system call exactly the same way as I do it
> on the shell. And running it from the shell it converts the whole file into
> a hash-table without any problems.
I'm doing (almost) the exact same thing and haven't run into any problems. The only
difference to your setuo is that I don't use sudo, but run the script as root instead. You
might want to give that a try; else provide more infos.
Cheers,
-w
------------------------------
Date: 16 Sep 99 21:33:47 GMT (Last modified)
From: Perl-Users-Request@ruby.oce.orst.edu (Perl-Users-Digest Admin)
Subject: Digest Administrivia (Last modified: 16 Sep 99)
Message-Id: <null>
Administrivia:
The Perl-Users Digest is a retransmission of the USENET newsgroup
comp.lang.perl.misc. For subscription or unsubscription requests, send
the single line:
subscribe perl-users
or:
unsubscribe perl-users
to almanac@ruby.oce.orst.edu.
| NOTE: The mail to news gateway, and thus the ability to submit articles
| through this service to the newsgroup, has been removed. I do not have
| time to individually vet each article to make sure that someone isn't
| abusing the service, and I no longer have any desire to waste my time
| dealing with the campus admins when some fool complains to them about an
| article that has come through the gateway instead of complaining
| to the source.
To submit articles to comp.lang.perl.announce, send your article to
clpa@perl.com.
To request back copies (available for a week or so), send your request
to almanac@ruby.oce.orst.edu with the command "send perl-users x.y",
where x is the volume number and y is the issue number.
For other requests pertaining to the digest, send mail to
perl-users-request@ruby.oce.orst.edu. Do not waste your time or mine
sending perl questions to the -request address, I don't have time to
answer them even if I did know the answer.
------------------------------
End of Perl-Users Digest V9 Issue 857
*************************************
