ikegami, your alias code output:
use Data::Alias qw( alias );
use Devel::Peek qw( Dump );
my $x = 3;
my $y = 4;
Dump($x);
Dump($y);
alias $x = $y;
Dump($x);
Dump($y);
__END__
SV = IV(0x80ce4c8) at 0x805917c
REFCNT = 1
FLAGS = (PADBUSY,PADMY,IOK,pIOK)
IV = 3
SV = IV(0x80ce4cc) at 0x8059128
REFCNT = 1
FLAGS = (PADBUSY,PADMY,IOK,pIOK)
IV = 4
SV = IV(0x80ce4cc) at 0x8059128
REFCNT = 2
FLAGS = (PADBUSY,PADMY,IOK,pIOK)
IV = 4
SV = IV(0x80ce4cc) at 0x8059128
REFCNT = 2
FLAGS = (PADBUSY,PADMY,IOK,pIOK)
IV = 4
For ewijawa,
sub gc_frac {
local $_ = @_? shift : $_;
2 * (() = /(gc)/gi ) / length;
}
print gc_frac('AAgcTT'),$/
Prints,
0.333333333333333
$
Ascii art for parallel continuation lines in castaway's problem.
>>-----ASSIGN-----+---------------+----+--user-id--->
'--WITH REGRET--' '--group-id-->
>---password---------+-------NO PRIVILEGE----------><
>---group-password---'
Limbic's Lost Lesson List, Linked
- Installing Perl on a Windows PC
- The Scalar Range Operator
- Perl Idioms Explained - !!expr
- Getting Matching Items From An Array
- Using select and IO::Select
- Using ModPerl::Registry without root
- Perl Special Variables Quick Reference
- It's a dog, but what kind? (polymorphism , in Perl OO)
- Uncommon* but Useful Perl Command Line Options for One-liners
- Flash graphics with perl: installing ming
- Getting started with DateTime
- Introduction to Parallel::ForkManager
- A simple example OO script for total beginners
- A very simple OO example for total beginners
- Criando uma conta no PerlMonks (now sitefaqlet)
- Eu preciso de ajuda! Quem pode me ajudar? (now sitefaqlet)
- I need help! Who can help me?
- Why you should use strict
- Antes que você escreva...
- Benvindo ao Mosteiro! Sinta-se em Casa (PT_BR)
- Adding elements using XML::Simple
- Lingua::Romana::Perligata - Basica Basicum Basicus
- Utilizando perl
- Don't Use Regular Expressions To Parse IP Addresses!
- Installing Modules on a Web Server
- Tips for Using Apache::Session
- PerlMonks for the Absolute Beginner
- writting unix password cracker in perl lithuanian language
- A CGI Help Guide
- Directory Recursion
- chop() and chomp()
- read()
- My program it doesn't work could you tell me my mistakes?
- Template with optional PHP execution
- Some Parse::RecDescent Tutorials
- Adjacency List Processing in XML::Twig
- Minimal Perl for the Impatient
- Choosing a Templating System
- Process ID
- DBIx::XML_RDB Tutorial
- Unix commands from within Perl?
- Using (s)printf()
- The tie()s That Bind
- Gtk-Perl Tutorial
- MP3 server with IO::Socket
- Tie: Creating Special Objects
- Blessables -- What Can You Make Into Objects?
- Operators: arithmetic and otherwise
- some more issues with regular expressions
Select stuff for duff
Return values: What's a good use for the number of ready channels? What systems return something useful for the time remaining? Linux does, are there others?
Truth or not of the number tells whether the return from select was due to ready channels or a timeout. The number can be decremented with each channel handled to enable a quick test for completion. The timeleft value appears to be useful only on Linux.
$ perl -e'printf "OS: %s\tNum: %d\tTime left: %f\n", $^O, select undef, undef, undef, 1.5'
gives for several systems,
OS: linux Num: 0 Time left: 0.000000 (Zaxo)
OS: freebsd Num: 0 Time left: 1.500000 (sporty)
OS: solaris Num: 0 Time left: 1.500000 (sporty)
Thanks to sporty for his assistance with that.
Signal handling: Do signals awake a sleeping select? Does a select timeout affect a pending alarm?
This it readily checked with a couple of one-liners.
$ perl -e'alarm 1;printf "Num: %d\tTime left: %f\n", select undef, und
+ef, undef, 3.0'
Alarm clock
$
shows that setting timeout in select does not interfere with SIGALRM and that signals will awake pending select.
$ time perl -e'alarm 5;printf "Num: %d\tTime left: %f\n", select undef
+, undef, undef, 3.0'
Num: 0 Time left: 0.000000
$
shows that having an alarm set does not interfere with select timing.
$ perl -e'$SIG{ALRM}=sub {};alarm 1;printf "Num: %d\tTime left: %f\n",
+ select undef, undef, undef, 3.0'
Num: -1 Time left: 2.000000
$
shows that catching a signal will jolt select into returning. That points out another use of the number returned. On Linux the time left value would be useful in recovering from such interruptions.
++demerphq points out that it is the elements of @_ that are aliases, not @_ itself. Modifying $_[0] works as advertised.
This is either a Hook::LexWrap bug, or else I'm doing something silly:
#!/usr/bin/perl
use strict;
use warnings;
use Hook::LexWrap;
{
my $foo;
sub foo { @_ ? $foo = shift : $foo; }
my $wrapper = wrap *foo,
pre => sub {
warn 0+@_, " @_";
# splice @_, 0, 1, lc( $_[0]) if @_ > 1; # bad
$_[0] = lc $_[0] if @_ > 1; #new
warn 0+@_, " @_";
},
post => sub {
$_[-1] =
wantarray ?
[ map {uc} @{$_[-1]} ] :
uc $_[-1]
};
sub wrapper () :lvalue { $wrapper } # keeps the cloistered
# lexwrap alive
sub _foo () :lvalue { $foo } # inspection hatch
}
my $str = 'Quux';
my $tmp = $str;
printf "Given $str, wrapped setter reports %s, backdoor shows %s, arg
+is now %s.\n",
foo($tmp), _foo, $tmp; # setter
printf "Wrapped getter reports %s, and backdoor shows %s\n",
foo(), _foo; # getter
__END__
2 Quux ARRAY(0x804b3f8) at hlw.pl line 13.
2 quux ARRAY(0x804b3f8) at hlw.pl line 15.
Given Quux, wrapped setter reports QUUX, backdoor shows Quux, arg is n
+ow Quux.
1 ARRAY(0x804b50c) at hlw.pl line 13.
1 ARRAY(0x804b50c) at hlw.pl line 15.
Wrapped getter reports QUUX, and backdoor shows Quux
If I understand correctly, the pre code ought to be able to modify @_ and have the wrapped sub see the new argument. There is a similar example in the pod, doing temperature conversion.
Reading from a file descriptor in C.
C's library read() returns -1 on error, or the number of bytes read. Some errors, like EAGAIN, are usually handled by retrying. The function does not necessarily read as many bytes as you ask for.
ssize_t rd = 0;
size_t sofar = 0;
while (rd = read( fd, buf + sofar, BUFSIZE - sofar)) {
switch (rd) {
case -1:
switch (errno) {
case EAGAIN :
case EINTR :
continue;
default :
/* unrecoverable */
abort();
}
default:
sofar += rd;
}
}
This is just skeletal, more detailed error handling may be called for. The read call returns zero either on eof, or when its third argument is zero. The while loop exits in either case having read BUFSIZE chars, or all there were, whichever came first.
In C, it pays to be persnickety, there is no dwimmery to the language. It just does what you tell it to.
My external css, http://localhost/PerlMonks.css: PRE {
background-color: #CCEECC;
border: thin black solid;
padding: 5px;
font-family: fixed, courier;
font-size: 14pt;
white-space : pre;
}
H1 {font-size: 34pt}
H2 {font-size: 30pt}
H3 {font-size: 24pt}
H4 {font-size: 18pt}
H5 {font-size: 14pt}
H6 {font-size: 8pt}
That green makes the Red Theme look like spumoni.
Patched framechat2, line 6 only fixes xml header if it's broken: sub fixxml
{ # fix the xml nodes so they parse correctly
my$xml = shift;
my$fix = q{<?xml version="1.0" encoding="ISO-8859-1"?>
<!DOCTYPE CHATTER SYSTEM "dummy.dtd"[]>}; # mirod to the re
+scue!
$xml = ($xml=~/^<\?xml/i?'':$fix).$xml; # Zaxo
$xml =~ s/[\r\n\t]//g; # jcwren
$xml =~ y/\x00-\x1f//d; # strip control chrs
return $xml; # to the xml parser
}
for simon_proctor: #!/usr/bin/perl -w
use strict;
sub common {
my (%common, %test);
$_ = shift;
@common{@$_} = {} x @$_; # second use is scalar context
while ( $_ = shift) {
%test = ();
@test{@$_} = () x @$_;
delete @common{ grep { ! exists $test{$_} } keys %common};
}
return ( keys %common );
}
my @foo = (
[1,2,3,5,8,9,4,5],
[18,2,4,7,3,4.9],
[2,3,6,5,9],
[1,2,3,4,5,6,7,8,9,0],
[1,2,3,5,8],
[2,3,4,5,8,7],
);
print "@{[common(@foo)]}$/";
prints:
1 2
If you want to try insanely low-level things in perl on linux, here is a transcription to perl of linux-2.4 asm-i386/ioctl.h. A lot of perls were built with linux-2.2 headers, making perl's sys/ioctl.ph not quite right for rekerneled machines. # Constants and functions transcribed from linux 2.4 asm-i386/ioctl.h
+macros
use strict;
package Ioctl::Linux_2_4::I386;
BEGIN {
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA = qw(Exporter);
$VERSION = '0.04';
@EXPORT = qw( _IO _IOR _IOW _IOWR );
@EXPORT_OK = qw(
_IOC_DIR _IOC_SIZE _IOC_NR _IOC_TYPE
IOC_IN IOC_OUT IOC_INOUT
IOCSIZE_MASK IOCSIZE_SHIFT
);
%EXPORT_TAGS = (
decode => [qw( _IOC_DIR _IOC_SIZE _IOC_NR _IOC_TYPE)],
rawdir => [qw(IOC_IN IOC_OUT IOC_INOUT)],
rawsize => [qw(IOCSIZE_MASK IOCSIZE_SHIFT)]
);
}
# Bitfield layout of ioctl command word
use constant IOC_NRBITS => 8;
use constant IOC_TYPEBITS => 8;
use constant IOC_SIZEBITS => 14;
use constant IOC_DIRBITS => 2;
# Decoding masks
use constant IOC_NRMASK => ((1 << IOC_NRBITS) - 1 );
use constant IOC_TYPEMASK => ((1 << IOC_TYPEBITS) - 1 );
use constant IOC_SIZEMASK => ((1 << IOC_SIZEBITS) - 1 );
use constant IOC_DIRMASK => ((1 << IOC_DIRBITS) - 1 );
# Shift amounts derived from bitfield widths
use constant IOC_NRSHIFT => 0;
use constant IOC_TYPESHIFT => (IOC_NRSHIFT + IOC_NRBITS);
use constant IOC_SIZESHIFT => (IOC_TYPESHIFT + IOC_TYPEBITS);
use constant IOC_DIRSHIFT => (IOC_SIZESHIFT + IOC_SIZEBITS);
# Direction encoding
use constant IOC_NONE => 0;
use constant IOC_WRITE => 1;
use constant IOC_READ => 2;
# Convenience constants
use constant IOC_IN => (IOC_WRITE << IOC_DIRSHIFT);
use constant IOC_OUT => (IOC_READ << IOC_DIRSHIFT);
use constant IOC_INOUT => ((IOC_WRITE|IOC_READ) << IOC_DIRSHIFT);
use constant IOCSIZE_MASK => (IOC_SIZEMASK << IOC_SIZESHIFT);
use constant IOCSIZE_SHIFT => (IOC_SIZESHIFT);
# Control word packing
# arguments: direction, type, nr, size
sub _IOC ($$$$) {
($_[0] & IOC_DIRMASK) << IOC_DIRSHIFT |
($_[1] & IOC_TYPEMASK) << IOC_TYPESHIFT |
($_[2] & IOC_NRMASK) << IOC_NRSHIFT |
($_[3] & IOC_SIZEMASK) << IOC_SIZESHIFT
}
# arguments: type, nr
sub _IO ($$) {
_IOC( IOC_NONE, $_[0], $_[1], 0)
}
# arguments: type, nr, size
sub _IOR ($$$) {
_IOC( IOC_READ, $_[0], $_[1], $_[2])
}
# arguments type, nr, size
sub _IOW ($$$) {
_IOC( IOC_WRITE, $_[0], $_[1], $_[2])
}
# arguments type, nr, size
sub _IOWR ($$$) {
_IOC( IOC_WRITE | IOC_READ, $_[0], $_[1], $_[2])
}
# Decode ioctl numbers
sub _IOC_DIR ($;@) {
$_[0] >> IOC_DIRSHIFT & IOC_DIRMASK
}
sub _IOC_TYPE ($;@) {
$_[0] >> IOC_TYPESHIFT & IOC_TYPEMASK
}
sub _IOC_NR ($;@) {
$_[0] >> IOC_NRSHIFT & IOC_NRMASK
}
sub _IOC_SIZE ($;@) {
$_[0] >> IOC_SIZESHIFT & IOC_SIZEMASK
}
1;
__END__
I'm soliciting review of this. Is the heavy use of the constant pragma good? How about the prototypes? I want it to howl at compile time if it gets the wrong number of arguments. I don't want runtime errors in the midst of prodding a kernel device
Here is a minor obfu which may be useful to paste into replies to homework: {$_="r\@56O4\@FCE6DJO\@7OE96O!6C=>\@?<DO|@?2DE6CJ\n",y, -},O-} -N,,pri
+nt}
A modified version of this is published as Steal This Code
|