Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

Zaxo's scratchpad

by Zaxo (Archbishop)
on Jun 01, 2004 at 18:20 UTC ( [id://358348]=scratchpad: print w/replies, xml ) Need Help??

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

  1. Installing Perl on a Windows PC
  2. The Scalar Range Operator
  3. Perl Idioms Explained - !!expr
  4. Getting Matching Items From An Array
  5. Using select and IO::Select
  6. Using ModPerl::Registry without root
  7. Perl Special Variables Quick Reference
  8. It's a dog, but what kind? (polymorphism , in Perl OO)
  9. Uncommon* but Useful Perl Command Line Options for One-liners
  10. Flash graphics with perl: installing ming
  11. Getting started with DateTime
  12. Introduction to Parallel::ForkManager
  13. A simple example OO script for total beginners
  14. A very simple OO example for total beginners
  15. Criando uma conta no PerlMonks (now sitefaqlet)
  16. Eu preciso de ajuda! Quem pode me ajudar? (now sitefaqlet)
  17. I need help! Who can help me?
  18. Why you should use strict
  19. Antes que você escreva...
  20. Benvindo ao Mosteiro! Sinta-se em Casa (PT_BR)
  21. Adding elements using XML::Simple
  22. Lingua::Romana::Perligata - Basica Basicum Basicus
  23. Utilizando perl
  24. Don't Use Regular Expressions To Parse IP Addresses!
  25. Installing Modules on a Web Server
  26. Tips for Using Apache::Session
  27. PerlMonks for the Absolute Beginner
  28. writting unix password cracker in perl lithuanian language
  29. A CGI Help Guide
  30. Directory Recursion
  31. chop() and chomp()
  32. read()
  33. My program it doesn't work could you tell me my mistakes?
  34. Template with optional PHP execution
  35. Some Parse::RecDescent Tutorials
  36. Adjacency List Processing in XML::Twig
  37. Minimal Perl for the Impatient
  38. Choosing a Templating System
  39. Process ID
  40. DBIx::XML_RDB Tutorial
  41. Unix commands from within Perl?
  42. Using (s)printf()
  43. The tie()s That Bind
  44. Gtk-Perl Tutorial
  45. MP3 server with IO::Socket
  46. Tie: Creating Special Objects
  47. Blessables -- What Can You Make Into Objects?
  48. Operators: arithmetic and otherwise
  49. 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.


Hook::LexWrap problem *SOLVED*

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

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others lurking in the Monastery: (4)
As of 2024-03-28 18:20 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found