{
    use constant HWND_BROADCAST     => 0xffff;
    use constant WM_SETTINGCHANGE   => 0x001A;
    use constant SMTO_ABORTIFHUNG   => 2;
    my $send;

    sub BroadcastEnv {
        $send ||= Win32::API->new(
            'user32', 'SendMessageTimeout', 'LLLPLLL', 'L',
            # hWnd, msg, wParam, lParam, flags, msTimeout, pLResults
        )
            or  die "Can't load SendMessageTimeout(): $^E\n";
        $send->Call(
            HWND_BROADCAST(),
            WM_SETTINGCHANGE(),
            0,
            "Environment",
            SMTO_ABORTIFHUNG(),
            5000,
            0, # unpack 'L', pack 'P', my $res= ' 'x8;
        );
    }
}

##</code><code>##

/* try to decode a socks5 header */
#define SSH_SOCKS5_AUTHDONE 0x1000
#define SSH_SOCKS5_NOAUTH   0x00
#define SSH_SOCKS5_IPV4     0x01
#define SSH_SOCKS5_DOMAIN   0x03
#define SSH_SOCKS5_IPV6     0x04
#define SSH_SOCKS5_CONNECT  0x01
#define SSH_SOCKS5_SUCCESS  0x00

/* ARGSUSED */
static int
channel_decode_socks5(Channel *c, fd_set *readset, fd_set *writeset)
{
    struct {
        u_int8_t version;
        u_int8_t command;
        u_int8_t reserved;
        u_int8_t atyp;
    } s5_req, s5_rsp;
    u_int16_t dest_port;
    u_char *p, dest_addr[255+1], ntop[INET6_ADDRSTRLEN];
    u_int have, need, i, found, nmethods, addrlen, af;

    debug2("channel %d: decode socks5", c->self);
    p = buffer_ptr(&c->input);
    if (p[0] != 0x05)
        return -1;
    have = buffer_len(&c->input);
    if (!(c->flags & SSH_SOCKS5_AUTHDONE)) {
        /* format: ver | nmethods | methods */
        if (have < 2)
            return 0;
        nmethods = p[1];
        if (have < nmethods + 2)
            return 0;
        /* look for method: "NO AUTHENTICATION REQUIRED" */
        for (found = 0, i = 2; i < nmethods + 2; i++) {
            if (p[i] == SSH_SOCKS5_NOAUTH) {
                found = 1;
                break;
            }
        }
        if (!found) {
            debug("channel %d: method SSH_SOCKS5_NOAUTH not found",
                c->self);
            return -1;
        }
        buffer_consume(&c->input, nmethods + 2);
        buffer_put_char(&c->output, 0x05);      /* version */
        buffer_put_char(&c->output, SSH_SOCKS5_NOAUTH); /* method */
        FD_SET(c->sock, writeset);
        c->flags |= SSH_SOCKS5_AUTHDONE;
        debug2("channel %d: socks5 auth done", c->self);
        return 0;               /* need more */
    }
    debug2("channel %d: socks5 post auth", c->self);
    if (have < sizeof(s5_req)+1)
        return 0;           /* need more */
    memcpy(&s5_req, p, sizeof(s5_req));
    if (s5_req.version != 0x05 ||
        s5_req.command != SSH_SOCKS5_CONNECT ||
        s5_req.reserved != 0x00) {
        debug2("channel %d: only socks5 connect supported", c->self);
        return -1;
    }
    switch (s5_req.atyp){
    case SSH_SOCKS5_IPV4:
        addrlen = 4;
        af = AF_INET;
        break;
    case SSH_SOCKS5_DOMAIN:
        addrlen = p[sizeof(s5_req)];
        af = -1;
        break;
    case SSH_SOCKS5_IPV6:
        addrlen = 16;
        af = AF_INET6;
        break;
    default:
        debug2("channel %d: bad socks5 atyp %d", c->self, s5_req.atyp);
        return -1;
    }
    need = sizeof(s5_req) + addrlen + 2;
    if (s5_req.atyp == SSH_SOCKS5_DOMAIN)
        need++;
    if (have < need)
        return 0;
    buffer_consume(&c->input, sizeof(s5_req));
    if (s5_req.atyp == SSH_SOCKS5_DOMAIN)
        buffer_consume(&c->input, 1);    /* host string length */
    buffer_get(&c->input, (char *)&dest_addr, addrlen);
    buffer_get(&c->input, (char *)&dest_port, 2);
    dest_addr[addrlen] = '\0';
    if (c->path != NULL) {
        xfree(c->path);
        c->path = NULL;
    }
    if (s5_req.atyp == SSH_SOCKS5_DOMAIN) {
        if (addrlen >= NI_MAXHOST) {
            error("channel %d: dynamic request: socks5 hostname "
                "\"%.100s\" too long", c->self, dest_addr);
            return -1;
        }
        c->path = xstrdup(dest_addr);
    } else {
        if (inet_ntop(af, dest_addr, ntop, sizeof(ntop)) == NULL)
            return -1;
        c->path = xstrdup(ntop);
    }
    c->host_port = ntohs(dest_port);

    debug2("channel %d: dynamic request: socks5 host %s port %u command %u",
        c->self, c->path, c->host_port, s5_req.command);

    s5_rsp.version = 0x05;
    s5_rsp.command = SSH_SOCKS5_SUCCESS;
    s5_rsp.reserved = 0;            /* ignored */
    s5_rsp.atyp = SSH_SOCKS5_IPV4;
    ((struct in_addr *)&dest_addr)->s_addr = INADDR_ANY;
    dest_port = 0;              /* ignored */

    buffer_append(&c->output, &s5_rsp, sizeof(s5_rsp));
    buffer_append(&c->output, &dest_addr, sizeof(struct in_addr));
    buffer_append(&c->output, &dest_port, sizeof(dest_port));
    return 1;
}

##</code><code>##

    sub acos { atan2( sqrt(1-$_[0]*$_[0]), $_[0] ) }
    sub asin { atan2( $_[0], sqrt(1-$_[0]*$_[0]) ) }
    my $pi= atan2(0,-1);
    my @c= ( 33.943603, -118.408189, 39.17965, -76.668824 );
    my $lat1= $c[0]/180*$pi;
    my $lat2= $c[2]/180*$pi;
    my $dlong= ($c[1]-$c[3])/180*$pi;
    my $ang= acos( sin($lat1)*sin($lat2)
        + cos($lat1)*cos($lat2)*cos($dlong) );
    my $max= $ang * 3_963.19059;
    my $min= $ang * 3_949.90257;
    printf "%.1f .. %.1f miles (%.2f range)\n", $min, $max, $max-$min;
    my $h1= sin(($lat1-$lat2)/2);
    my $h2= sin($dlong/2);
    $ang= 2*asin( sqrt( $h1*$h1 + cos($lat1)*cos($lat2)*$h2*$h2 ) );
    $max= $ang * 3_963.19059;
    $min= $ang * 3_949.90257;
    printf "%.1f .. %.1f miles (%.2f range)\n", $min, $max, $max-$min;

2318.6 .. 2326.4 miles (7.80 range)
2318.6 .. 2326.4 miles (7.80 range)

##</code><code>##

    # Change within substr (or zero-width on an edge)
    if(     $beg < $end     # Not empty
        ||  $b == $e        # Both empty (identical)
        ||  (   $b < $beg
            &&  $end < $e )
    ) {     # Or not on an edge
        # changes within substr, change length:
        $e += $dif;
    }

##</code><code>##

a b c d e f g . h i j k l-o p . q r s . t u v . www x . y & z .
a b c d e f g . h i j . k l m . n o p q r s t . u v www x y z .

##</code><code>##

<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN">
<html><head>
  <title>PerlMonks Full-Page Chat</title>
  <base href="http://www.perlmonks.org/" />
  <link rel="stylesheet" href="/css/common.css" type="text/css" />
  <link rel="stylesheet" href="?node_id=204962" type="text/css" />
  <link rel="icon" href="/favicon.ico" />
</head>
  <frameset rows="48,*">
    <frameset cols="51.6%,48.4%">
      <frame src="/bare/?node=just_chat;textsize=42" />
      <frame src="/?node=just_search;formtarget=_blank;textsize=35;style=bare" />
    </frameset>
    <frameset cols="87%,13%">
      <frameset rows="20%,80%">
        <frame src="?displaytype=raw;type=fullpage;node=privatemessages" />
        <frame src="?displaytype=raw;node=showchatmessages" />
      </frameset>
      <frame src="?displaytype=raw;node=showotherusers" />
    </frameset>
  </frameset>
  <noframes>
    <p>No Frames?  <a href="?displaytype=raw;node=showchatmessages">Chat Here</a></p>
  </noframes>
</html>

##</code><code>##

:let @p="L?^#!\r/^__END__\ry''''p!Gperl\rG"

##</code><code>##

#!/usr/bin/perl -n
next if /.../;
s/.../.../;
s/.../.../;
if( /.../ ) {
    my( $date, $time )= /(\d([-/\d]+\d) (\d([\d:.]+\d)/;
    my( $hr, $min, $sec, $ms )= split /[:.]/, $time;
    my $now= $ms/1000 + $sec + 60*( $min + 60*$hr );
    if(  $Then  ) {
        $sec= $now - $Then;
        $min= int( $sec / 60 );
        $sec -= 60*$min;
        $_= sprintf "+%d:%06.3f %s", $min, $sec, $_;
    }
    $Then= $now;
}
print;
__END__
...

##</code><code>##

SOCKET
win32_socket(int af, int type, int protocol)
{
    SOCKET s;

    StartSockets();
    s = socket(af, type, protocol);
    if( s == INVALID_SOCKET || s == NULL )
        errno = WSAGetLastError();
    else
        s = OPEN_SOCKET(s);

    return s;
}

##</code><code>##

      C C
      v v
  _ _ _ _ _ _<C
  _ _ _ _ _ _<C
  _ _ _ _ _ _
  _ _ _ _ _ _<C
A>_ _ _ _ _ _
  _ _ _ _ _ _
            ^
            C

##</code><code>##

   my $message;
   my $q;
   my $reTime='\d*\.?\d+(?:\s*(?:h(?:ours?)?'
      . '|m(?:in(?:ute)?s?)?|s(?:ec(?:ond)?s?)?))?';
   if(  $message !~ m{
            ^/(borg|consume)
            \s+(?: (\S+) | \[ ([^\]]+) \] )
            (?:| \s+($reTime)
               (?:| \s+(\S.*) )
            )\s*$
         }ix
   ) {
      $q->param( "sentmessage",
         qq[<i>Syntax error in /borg; command ignored.</i>]
      );
      return;
   }

##</code><code>##

Final $ should be \$ or $name at line 6, within pattern
syntax error at line 11, near "!~ m{
            ^/(borg|consume)
            \s+(?: (\S+) | \[ ([^\]]+) \] )
            (?:| \s+($reTime)
               (?:| \s+(\S.*) )
            )\s* $
         }ix"
  (Might be a runaway multi-line {} string starting on line 5)
syntax error at line 17, near ";
   }"

##</code><code>##

#!/usr/bin/perl
use strict;
use warnings;

sub make_html {
    my $array= shift @_;

    my $rows= $#$array;
    my $cols= $#{$array->[0]};

    my @html;
    my @last= @{ $array->[$rows] };
    my @span= (1)  x (1+$cols);

    push @html, "</table>\n";
    foreach my $row (  reverse [], @$array[0..$rows-1]  ) {
        push @html, "</tr>\n";
        foreach my $col (  reverse 0..$cols  ) {
            if(  @$row  &&  $last[$col] eq $row->[$col]  ) {
                $span[$col]++;
            } else {
                my $span= 1==$span[$col] ? "" : " rowspan='$span[$col]'";
                push @html, "<td$span>$last[$col]</td>\n";
                $span[$col]= 1;
                $last[$col]= $row->[$col]   if  @$row;
            }
        }
        push @html, "<tr>\n";
    }
    push @html, "<table border='1'>\n";
    return join '', reverse @html;
}


my @t=(
        [ qw( A B C D E F H ) ],
        [ qw( A B C D E G I ) ],
        [ qw( A B C D F G J ) ],
        [ qw( A B C E F G K ) ],
        [ qw( A B D E F G L ) ],
        [ qw( A C D E F G M ) ],
        [ qw( B C D E F G N ) ],
      );

print make_html(\@t);

##</code><code>##

#!/usr/bin/perl -w
use strict;
 
for my $str (  @ARGV  ) {
    my @stack;
    my $list= [];
    for my $s (  $str =~ m/[()]|[^()]+/g  ) {
        if(  '(' eq $s  ) {
            push @stack, $list;
            push @$list, [];
            $list= $list->[-1];
        } elsif(  ')' eq $s  ) {
            if(  ! @stack  ) {
                die "Unmatched ')'";
            }
            $list= pop @stack;
        } else {
            push @$list, $s;
        }
    }
    if(  @stack  ) {
        die 0+@stack, " unclosed '('s";
    }
    warn "Done.\n";
}

##</code><code>##

class GetStreamString {
    # Nothing to see here.
    # Just a type to allow us to define the below operator.
};

const char* operator<<( std::ostream& ostr, const GetStreamString& )
{
     return dynamic_cast< std::stringstream& >( ostr ).str().c_str();
}

##</code><code>##

    function_that_accepts_some_string_argument( "Like this" );
    function_that_accepts_some_string_argument(
        std::stringstream()
            << "Make a dynamic string with " << n
            << " " << name << "s filled in"
            << GetStreamString()
    );

##</code><code>##

#!/usr/bin/perl -w
use strict;

sub X() { 0 }
sub Y() { 1 }

# Given a line segment from point A to point B:
my @A= splice @ARGV, 0, 2;
my @B= splice @ARGV, 0, 2;
# And another point P:
my @P=  splice @ARGV, 0, 2;

# Translate point A to be the origin of the
# plane (subtract A from the other points):
my @B1= ( $B[X]-$A[X], $B[Y]-$A[Y] );
my @P1= ( $P[X]-$A[X], $P[Y]-$A[Y] );

# Rotate the plane so B is on the X axis:
# (Also expands the plane by a factor
#  equal to the length of the line segment)
@P1= ( $P1[X]*$B1[X] + $P1[Y]*$B1[Y],
       $P1[Y]*$B1[X] - $P1[X]*$B1[Y] );
@B1= ( $B1[X]*$B1[X] + $B1[Y]*$B1[Y], 0 );

# You can now find the closest point on the line:
# (let $t=0 represent A and $t=1 represent B)
my $t= $P1[X]/$B1[X];
my @I= ( (1-$t)*$A[X] + $t*$B[X],
         (1-$t)*$A[Y] + $t*$B[Y] );

# And/or, find the length of the line segment
# and the distance from the point to the line:
my $len= sqrt( $B1[X] );
# Add abs() if you don't want to know
# which side of the line the point is on:
my $dist= $P1[Y]/$len;

# Might as well compute the area of our triangle:
my $area= $len*abs($dist)/2;

print "I=( $I[X], $I[Y] ) t=$t\n";
print "dist=$dist len=$len area=$area\n";

##</code><code>##

use Algorithm::Loops 'NextPermute';
my @dig= ( 1..9 );
do {
    my $s= my $v= join "", reverse @dig;
    chop($s)   while  $s  &&  0 == $s % length($s);
    warn $v, $/   if  ! $s;
} while(  NextPermute(@dig)  );

##</code><code>##

sub READLINEX {
    my $self= shift;
    my $svBuf= \$self->{BUFFER};
    my $delim= $self->{INPUT_REGEX};
    my $len= $self->{READLEN} || 4096;
    my $margin= $self->{READMARGIN} || 128;
    while(  $$svBuf !~ /$delim/
        ||  length($$svBuf)-$margin < $+[0]
    ) {
        $pos= length($$svBuf);
        $self->READ( $$svBuf, $pos, $len )
            or  last;
    }
    $pos=  $$svBuf =~ /$delim/  ?  $+[0]  :  length($$svBuf);
    return substr( $$svBuf, 0, $pos, "" );
}

##</code><code>##

BEGIN {
    require UNIVERSAL;
    *isa= \&UNIVERSAL::isa;
}
sub Compare {
    my( $ctx )= 3==@_ ? pop(@_) : {};
    my( $x, $y )= \( @_ );
    return 0   if  defined($$x) != defined($$y);
    return 0   if  ref($$x) ne ref($$y);
    return $$x eq $$y   if  ! ref($$x);
    return 1
        if  $$x == $$y
        ||  $ctx->{0+$$x,0+$$y}
        ||  $ctx->{0+$$y,0+$$x}++;
    return Compare($$$x,$$$y,$ctx)
        if  isa($$x,'SCALAR')  ||  isa($$x,'REF');
    if(  isa($$x,'ARRAY')  ) {
        return 0   if  @$$x != @$$y;
        for my $idx (  0..$#$$x  ) {
            return 0
                if  ! Compare($$x->[$idx],$$y->[$idx],$ctx);
        }
        return 1;
    }
    if(  isa($$x,'HASH')  ) {
        return 0   if  keys %$$x != keys %$$y;
        for my $key (  keys %$$x  ) {
            return 0
                unless  exists $$y->{$key}
                    &&  Compare($$x->{$key},$$y->{$key},$ctx);
        }
        return 1;
    }
    require Carp;
    Carp::croak( "Unsupported data type (",ref($$x),")" );
}

##</code><code>##

while(  $pattern =~ m<      # Tokenize the potential regex
      \G                    # Don't let it skip bits
        (                   # Return what we find
          \\x..             # A hexidecimal character
        | \\0[0-7]{0,3}     # An octal character
        | \\\D              # A boring escaped character
        | [^\[\{]           # Not '[' nor '{' so treat as a token   #}
        | \{(?=\D)          # Literal but unescaped '{'             #}
        | \{\d+,?\d*}       # Bounded repetitions
        | \[                # '[' starts a character class
            \^?             #  '^' can go in front of the literal ']'
            \]?             #   ']' at start is taken literally
            (?:             #     Inside, there can be some subtokens
              [^\]]         #       Not '[' so isn't a subtoken
            | \[(?=[^.=:])  #       '[' but not '[.', '[=', nor '[:'
            | \[            #       Must be '[' of '[.', '[=', or '[:'
                [^\]]*      #       Anything but the closing ']'
              \]            #       ']' closes out subtoken
            )*              #     Any number of subtokens
          \]                # ']' closes out the character class
        | (.)               # Found something invalid (sets $2)
        )
    >xsg
) {
Strange *+?{} on zero-length expression

##</code><code>##

sub fletch {
  my( $str )= @_;
  my( $sum1, $sum2 );
    for my $ch (  unpack "C*", $str  ) {
        $sum1 += $ch;
        $sum1 -= 255   if  255 < $sum1;
        $sum2 += $sum1;
        $sum2 -= 255   if  255 < $sum2;
    }
    return  pack "C*", $sum2, $sum1;
}

##</code><code>##

BEGIN {
    my $countFile= "/path/to/count/file";
    my $fh= do { local(COUNT); \*COUNT };
    open $fh, ">> $countFile" or die "Can't append to $countFile: $!\n";
    my $byte= "\x80" | pack "C", 0x7f & $$;

    sub getCounter {
        my $start= tell($fh);
        print $fh $byte;
        my $end= tell($fh);
        return  $start   if  $start+1 == $end;
        seek($fh,$start,0);
        my $buf;
        read( $fh, $buf, $end-$start );
        my $offset= index($buf,$byte);
        return $start + $offset   if  -1 == index($buf,$byte,$offset);
        seek( $fh, $start+$offset, 0 );
        my $lock;
        my $new;
        while(  1  ) {
            $lock= fileLock->new( $fh, $start+$offset, 1 );
            read( $fh, $new, 1 );
            if(  $new eq $byte  ) {
                $new &= "\x7f";
                seek( $fh, $start+$offset, 0 );
                write( $fh, $new );
                return $start+$offset;
            }
            $offset= index($buf,$byte,$offset);
            die "Impossible!"   if  $offset < 0;
        }
    }
}

##</code><code>##

package Win32::SelectablePipe;
use strict;

use Socket;
use POSIX ();
use vars qw( @EXPORT @EXPORT_OK );

BEGIN {
    require Exporter;
    @EXPORT= qw( pipe );
    @EXPORT_OK= qw( FIONBIO EAGAIN );
    *import= \&Exporter::import;
}

sub SO_OPENTYPE { 0x7008 }

sub POSIX::FIONBIO { ( 0x80000000 | (4<<16) | (unpack('c','f')<<8) | 126 ) }
# 0x8004667E

sub POSIX::EAGAIN  { 10035 }
sub POSIX::EISCONN { 10056 }


sub pipe {
    my( $one, $two )= @_;
    my( $server )= do { local(*SERVER); *SERVER };
    if(  2 != @_  ) {
        require Carp;
        Carp::croak( "Win32::SelectablePipe usage: pipe(*ONE,*TWO)" );
    }
    {
        my $pkg= caller;
        for my $handle (  $one, $two  ) {
            if(  ! ref($handle)
             &&  "GLOB" ne ref(\$handle)
             &&  $handle !~ /'|::/  ) {
                $handle= "$pkg::$handle"
            }
        }
    }
    my $tcp= getprotobyname('tcp');
    socket( $server, PF_INET, SOCK_STREAM, $tcp )
        or  die "Can't create TCP socket ($server): $!";
    socket( $two, PF_INET, SOCK_STREAM, $tcp )
        or  die "Can't create TCP socket ($two): $!";
    my $local= gethostbyname('localhost')
        or  die "Can't find localhost: $!";
    my $addr= sockaddr_in( 0, $local )
        or  die "Can't build localhost address: $!";
    bind( $server, $addr )
        or  die "Can't bind socket ($server) to localhost address: ",0+$!;
    bind( $two, $addr )
        or  die "Can't bind socket ($two) to localhost address: ",0+$!;
    listen( $server, 1 )
        or  die "Can't listen on socket ($server): ",0+$!;
    $addr= getsockname( $server )
        or  die "Can't get socket ($server) address: ",0+$!;
    {
        my $true= 1;
        ioctl( $two, POSIX::FIONBIO(), \$true )
            or die "Can't ioctl socket ($two) to non-blocking: ", 0+$!;
    }
    if(  connect( $two, $addr )  ) {
        warn "Strange, connect() succeeded?";
    } elsif(  $! != POSIX::EAGAIN  ) {
        die "Can't non-blockingly connect: ", 0+$!;
    }
    accept( $one, $server ) or  die "Can't accept: ", 0+$!;
    sleep( 1 );
    die "Can't connect: ", 0+$!;
      if  ! connect( $two, $addr )  &&  $! != POSIX::EISCONN;
    close( $server );
    return 1;
}


# Total *HACK* to allow winsock connect() to work on non-blocking sockets
# Culprit is in perl source /win32/win32sck.c function set_socktype. We
# undo the result of this function. See MSDN support on overlapped I/O
# for info: http://support.microsoft.com/support/kb/articles/Q181/6/11.ASP
#BEGIN {
#  my $sock = gensym();
#  socket( $sock, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
#    or die "ERROR - can't create socket\n";
#  setsockopt( $sock, SOL_SOCKET, SO_OPENTYPE, 0 )
#    or die "PORTABLE::BEGIN ERROR - Can't setsockopt to overlapped: $!\n";
#  close $sock;
#}

1;

##</code><code>##

    my ($line,$file)= ( 3+__LINE__, __FILE__ );
    my $func = qq(
#line $line "$file"
        sub $tagname { 
            shift if \$_[0] && 

##</code><code>##

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html lang="de" xmlns="http://www.w3.org/1999/xhtml" xml:lang="de">
<head>
<meta http-equiv="content-type" content="text/html; charset=iso-8859-1" />
<title>Titel</title>
</head>
<body>
<b>If you see this as rendered HTML your browser sucks</b>
<div><a href="a">a link</a></div>
<img src="abc.tif">
<script type="text/javascript"><!--
alert("and if you see this box, your browser sucks even more ;-)");
--></script>
</body>
</html>