#!/usr/bin/perl

use strict;

# mixed string with ISO 8859-1 und UTF-8:
my $test_string = "Das Å (auch \"bolle-Å\" genannt, was soviel bedeute
+t wie \"Kringel-Å\") ist mit der ".
    force_utf8("dänischen Rechtschreibreform von 1948 eingeführt worde
+n.");

print "Source: $test_string\n";
print "UTF   : ".force_utf8($test_string)."\n";
print "ISO   : ".force_latin($test_string)."\n";

sub force_utf8 {
    my $string = shift;
    
    $string =~ s/([\xc0-\xdf][\x80-\xbf]{1}|[\xe0-\xef][\x80-\xbf]{2}|
+[\xf0-\xf7][\x80-\xbf]{3}|[\x80-\xff])/&encode_char_utf8($1)/ge;
    
    return $string;
    
}

sub force_latin {
    my $string = shift;
    
    $string =~ s/([\xc0-\xdf][\x80-\xbf]{1}|[\xe0-\xef][\x80-\xbf]{2}|
+[\xf0-\xf7][\x80-\xbf]{3}|[\x80-\xff])/&decode_char_utf8($1)/ge;
    
    return $string;
    
}
     
sub encode_char_utf8 {
    my $char = shift;

    if($char =~ /^([\xc0-\xdf][\x80-\xbf]{1}|[\xe0-\xef][\x80-\xbf]{2}
+|[\xf0-\xf7][\x80-\xbf]{3})$/) {
        return $char;
    }
        
    my $value = ord($char);
    
    return chr(($value>>6) | 0xc0).chr(0x80 | ($value & 0x3f));
}

sub decode_char_utf8 {
    my $char = shift;
        
    if($char =~ /^([\xe0-\xef][\x80-\xbf]{2}|[\xf0-\xf7][\x80-\xbf]{3}
+)$/) {
        return '';
    } elsif($char =~ /^([\xc0-\xdf])([\x80-\xbf])$/) {
    
        my $value = ((ord($1) & 0x1f)<<6)+(ord($2) & 0x3f);
    
        if($value<256) {
            return chr($value);
        } else {
            return '';
        }
        
    } else {
        return $char;
    }
    
}
[download]

sub human_size {
    my $val = shift;
    # 2**10 (binary) multiplier by default
    my $multiplier = @_ ? shift : 1024;

    my $magnitude = 0;
    my @suffixes = qw/B KB MB GB TB PB EB/;

    my $rval;

    while (($rval = sprintf("%.2f",$val)) >= $multiplier) {
        $val /= $multiplier;
        $magnitude++;
    }

    # Use Perl's numeric conversion to remove trailing zeros
    # in the fraction and the decimal point if unnecessary
    $rval = 0 + $rval;

    if(wantarray) {
        ($rval, $magnitude, $suffixes[$magnitude]);
    } else {
        "$rval $suffixes[$magnitude]";
    }
}


##
## Example code below
##


# read value from the command line

my $val = shift;

# Scalar context example

printf "Size: %s\n", scalar human_size($val);

# List context example

my @fancy_suffixes = map "${_}bytes", '', qw/kilo mega giga tera peta 
+exa/;

my ($hval, $mag, $sfx) = human_size($val, 10**3);

$hval .= ' decimal' if $mag; # omit for values < 1KB
$hval = "$hval $fancy_suffixes[$mag] ($sfx)";

print "Size: $hval\n";
[download]

#!/usr/bin/perl
use warnings;
use strict;
use Tk;
use Finance::YahooQuote;

# mouse left click to quit 

my @check = qw(BA BNI BASFY.PK); # stocks to check

# order of information sent by yahoo
my @h = ("Symbol","Name","Last","Trade Date","Trade Time","Change","% 
+Change",
     "Volume","Avg. Daily Volume","Bid","Ask","Prev. Close","Open",
     "Day's Range","52-Week Range","EPS","P/E Ratio","Div. Pay Date",
     "Div/Share","Div. Yield","Mkt. Cap","Exchange");

my %stocks;

my $mw = new MainWindow;
$mw->geometry('-0-0');  # lower right corner, my toolbar is at the top
+ :-)
$mw->overrideredirect(1); # show on all desktops

foreach my $stock (@check){
  $stocks{$stock}{'info'}= '              ';
  $stocks{$stock}{'lab'} = $mw->Label(-textvariable=>\$stocks{$stock}{
+'info'}, 
                    #-width => 45,
                    -justify => 'left',
                    -anchor => 'nw',
                    -height=>1,
                    -padx=>0,
                    -pady=>0,
                    -bg=>'black', 
                    -fg=>'yellow')->pack(-expand=>1,-fill=>'x',-pady=>
+0,-padx=>0);

}

#set update time... don't overload server
my $id = Tk::After->new($mw,30000,'repeat',\&refresh); #30 seconds

refresh();

$mw->bind('<ButtonPress-1>', sub{ Tk::exit });

MainLoop;

sub refresh{
 my @q = getquote(@check);

 foreach $a (@q) {
     $stocks{$$a[0]}{'info'} = $$a[2].' '.$$a[0].' '.$$a[5]."\n";
  }

}
[download]

use strict;
use warnings;

my @array1 = qw( four five six );
my @array = qw( one two three );
push( @array, \@array1 );

my $string = "four";
my %hash   = (
    'first' => 'one',
    'second' => 'two',
    'third'  => 'three',
    'fourth' => \@array,
);

#print_r( @array );

print_r( \%hash );

sub print_r {
    package print_r;
    our $level;
    our @level_index;
    if ( ! defined $level ) { $level = 0 };
    if ( ! defined @level_index ) { $level_index[$level] = 0 };

    for ( @_ ) {
        my $element = $_;
        my $index   = $level_index[$level];

        print "\t" x $level . "[$index] => ";

        if ( ref($element) eq 'ARRAY' ) {
            my $array = $_;

            $level_index[++$level] = 0;

            print "(Array)\n";

            for ( @$array ) {
                main::print_r( $_ );
            }
            --$level if ( $level > 0 );
        } elsif ( ref($element) eq 'HASH' ) {
            my $hash = $_;

            print "(Hash)\n";

            ++$level;

            for ( keys %$hash ) {
                $level_index[$level] = $_;
                main::print_r( $$hash{$_} );
            }
        } else {
            print "$element\n";
        }

        $level_index[$level]++;
    }
} # End print_r
[download]

#!/usr/bin/perl

use strict;
use warnings;
use HTML::Entities;

# random selection of cp1252 goodies
my $str = join('',
  chr(0x80), chr(0x81), chr(0x91), chr(0x92),
  chr(0x93), chr(0x94), chr(0x95), chr(0x96),
);
my $original = $str;

# delete any chars not assigned
$str =~ tr/\x81\x8D\x8F\x90\x9D//d;

# replace the rest
$str =~ tr{\x80\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8E\x91\x9
+2\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9E\x9F}
          {\x{20AC}\x{201A}\x{0192}\x{201E}\x{2026}\x{2020}\x{2021}\x{
+02C6}\x{2030}\x{0160}\x{2039}\x{0152}\x{017D}\x{2018}\x{2019}\x{201C}
+\x{201D}\x{2022}\x{2013}\x{2014}\x{02DC}\x{2122}\x{0161}\x{203A}\x{01
+53}\x{017E}\x{0178}/};

# check what happened without trying to print wide chars
my $encoded = encode_entities($str);
$str =~ s/(.)/sprintf( "\\x{%x}", ord($1))/eg;

print qq{original: $original\n};
print qq{hex: $str\n};
print qq{encoded: $encoded\n};

print qq{done\n};


__DATA__
80    0x20AC
81
82    0x201A
83    0x0192
84    0x201E
85    0x2026
86    0x2020
87    0x2021
88    0x02C6
89    0x2030
8A    0x0160
8B    0x2039
8C    0x0152
8D
8E    0x017D
8F
90
91    0x2018
92    0x2019
93    0x201C
94    0x201D
95    0x2022
96    0x2013
97    0x2014
98    0x02DC
99    0x2122
9A    0x0161
9B    0x203A
9C    0x0153
9D
9E    0x017E
9F    0x0178
[download]

#!/usr/bin/perl -w
#
# Compile and test the current perl source tree from anywhere
# in the tree.
#
# This program can be called from any point in a fairly typical
# perl source tree (like the ones created by h2xs)
#
# It will try to find the toplevel Makefile.PL and run it to
# create a Makefile in the same directory if needed
# then runs "make test" and fixes  error messages so they can
# be used immediately by whatever system you have in place for
# editing the offending files. (that would be Emacs in my case)
#
# it translates error messages to the actual source files (for
# instance, "$path/blib/lib/Something/Else.pm" can be translated to
# "$path/lib/Something/Else.pm" or "$path/Else/Else.pm" - whichever
# exists)
#
# put this script in your PATH somewhere as "perl-test"
#
# ---------------------------------------------------------------
#
# emacs configuration:
#
# use
#
# M-x compile RET (or equivalent key chord)
# to run perl-test instead of "make -k"
#
# or if you're using mode-compile, add the following to your .emacs fi
+le:
#
#  ;; use perl-test script to compile & test perl modules
#  ;; using mode-compile
#     (setq perl-command "perl-test")
#     (setq perl-dbg-flags "")
#
# ---------------------------------------------------------------
#
# (c) 2007 Joost Diepenmaat, joost@zeekat.nl
#
# This program is free software; you can redistribute it and/or modify
+ it under
# the same terms as Perl itself.
#
# See http://www.perl.com/perl/misc/Artistic.html
#
#


use strict;
use Cwd;

my $dir = getcwd;

# find the top-level Makefile.PL
while ((! -f "Makefile.PL") || (-f "../Makefile.PL")) {
  chdir "..";
  my $newdir = getcwd;
  die "No Makefile.PL found!" if ($newdir eq $dir);
  $dir = $newdir;
}

if (!-f "Makefile") {
  system("perl Makefile.PL") and die "Error running Makefile.PL";
}

open MAKE,"make test 2>&1|" or die "Can't make test: $!";
while (<MAKE>) {
  # create absolute paths
  s/( at )([^\/].*?)( line \d+\.)$/$1$dir\/$2$3/;
  # resolve blib files
  s/( at )(.*?\bblib\/.*?)( line \d+\.)$/"$1".blibtonormal($2)."$3"/e;
  print;
}
close MAKE;
exit $? >> 8;  # pass on exit code from make command


sub blibtonormal {
  my ($blib) = @_;
  my $norm = $blib;
  $norm =~ s/.*\bblib\///;
  return $norm if (-f $norm);
  if ($norm =~ /\/([^\/]+)\.(pm|xs)$/) {
    my $test = "$dir/$1/$1.$2";
    return $test if -f $test;
  }
  return $blib;  # can't figure it out - just leave it
}
[download]

#!/usr/bin/perl
use warnings;
use strict;
use Gtk2 '-init';
use Gnome2::Canvas;
use constant TRUE=>1;
use constant FALSE=>0;

my $ts ;

if($ARGV[0]){
    open (FH,"< $ARGV[0]");
    read( FH, $ts, -s FH );                    
    close FH;
}else{
  while(<DATA>){ $ts .= $_ }
}

$ts =~ tr[\x0a\x0d][  ]d; #strip newlines

my $width = 650;
my $height = 60;

my $window = Gtk2::Window->new();

my $canvas = Gnome2::Canvas->new_aa();
my $black = Gtk2::Gdk::Color->new (0x0000,0x0000,0x0000);
$canvas->modify_bg('normal',$black);
$window->add($canvas);

$window->signal_connect('destroy'=>\&_closeapp);

$window->set_default_size($width,$height);

my $root   = $canvas->root;

my $markup = "<span  foreground= '#00FF00' size='50000' 
              weight = 'ultralight'><i><u> $ts </u></i></span>";

my $text = Gnome2::Canvas::Item->new($root, 'Gnome2::Canvas::Text',
              #text => $markup,
              markup => $markup,
              fill_color => 'green',  
              anchor => 'w',
              justification => 'left',
              x=>0, 
              x_offset=> -$width/3,
              y=>30);

$text->raise_to_top();
$window->show_all();

my $timer = Glib::Timeout->add(1000/24, \&timer);

my ($x1, $y1, $x2, $y2) = $text->get_bounds;
print "$x2\n";
my $right_bound = $x2 + $width;

Gtk2->main();

sub timer {
        $text->move( -20, 0 ); 
        my ($x1, $y1, $x2, $y2) = $text->get_bounds;
        print "$x2\n";
        if($x2 < -40){
             $text->move( $right_bound + 60, 0 );
        
            }
        
        return 1;
}

sub _closeapp{
    Gtk2->main_quit();
    return 0;
}

__DATA__
This article is Copyright 1990-2004 by Steve Summit.  Content from the
book _C Programming FAQs: Frequently Asked Questions_ is made availabl
+e
here by permission of the author and the publisher as a service to the
community.  It is intended to complement the use of the published text
and is protected by international copyright laws.  The on-line content
may be accessed freely for personal use but may not be republished
without permission.
__END__
[download]

 tail -n +5 Sculptie.pgm | perl -nle 'BEGIN{$l=$c=0;} $c++ unless($_);
+if(++$l==127){$l=0;print $c; $c=0;}' > Sculptie.zr

#!/usr/bin/perl

# Use: rot.pl < Sculptie.zr > Sculptie.ppm

#4 * atan2 1, 1;

my $step= 4*atan2(1,1)/128;
my $i=0;
my $a=$step*255;
my @r,$j,$k,$z,$zi;

while(<>) {
  chomp;
  $r[$i++]=$_;
}
$z=$i;
$z--;
print "P3\n256 256 255\n";

for($j=$z;$j>-1;$j--) {
  $a=$step*255;
  for($i=0;$i<256;$i++) {
    my $x=127+int($r[$j]*cos($a));
    my $y=127+int($r[$j]*sin($a));
    print "$x $y $j\n";
    $a-=$step;
  }
}
[download]

# argument: short integer to convert to two bytes
# return: two bytes
sub short_to_bytes
{
    local @_ = unpack("C*",pack("L",shift));
    (shift, shift);
}

# argument: two bytes to convert into an integer
# return: short integer
sub bytes_to_short
{

    my $res = 0;
    $res |= $bytes[1] & 0xFF;
    $res <<= 8;
    $res |= $bytes[0] & 0xFF;
    return $res;
}
[download]

Update: I fixed the code to actually use the iterator this time :)

Read the SQL text file and send each batch to the database using Perl. In this case, we aren’t performing any real parsing of the SQL itself, we are simply retrieving the individual SQL batches. I’m using Rintaro Ishizaki’s Iterator::Simple Perl module so we can very easily get the next SQL batch.

package dbS::Sybase::Parse::SQL_File;

use warnings;
use strict;

use Iterator::Simple qw(iterator);

BEGIN {
    use Exporter ();

    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
    $VERSION = 1.0.0;

    @ISA = qw(Exporter);
    @EXPORT_OK = qw(&batch);
}

our $FH;

#############################

sub batch {
 my $file = shift;

 open ($FH, "<", $file)
   or die ("unable to open sql file\n");

 iterator {
   my $query = "";

   while (my $line = <$FH>) {
     chomp $line;
     last if ($line =~ m/^go\s*$/i);
     $query .= $line . " ";
   }

   return $query;
 }
}

1;
[download]

1. SQL batches end with a go (case insensitive)
2. SQL code is valid
3. security of the SQL text file is handled by the operating system (we're not going to worry about SQL injection attacks at this level)

use dbS::Sybase::Parse::SQL_File qw(open_file next_batch);

....

if ( my $batch = dbS::Sybase::Parse::SQL_File::batch("SQL/SNAP.sql") )
+ {
  print "-"x40 . "\n";
  print " Performing IGOR\n";
  print "-"x40 . "\n";

  while ( my $sql_batch = $batch->next ) {
     dbh_do($local_dbh, $sql_batch);
  }
}
[download]

Granted, we could have performed this without the iterator, but this is just the first revision. I expect to be adding a lot more to it (e.g. T-SQL verifier) so that I can hide the complexity behind the iterator.