Home

Search this site:
 

Horshack’s
very
own site

 

This is Bavaria, Germany!
You will find links to Perl,
bootdisks for system administration,
a lot of Linux,
Windows administration
and some personal belongings.

Using Perl, little solutions for daily problems

Here are my examplescripts ordered by themes:

Sending email

Internetservices

Struggeling with dates

Textmanipulation & Misc

Databases

Filesystem

Perlish informations

Misc Win32 things

Misc misc misc


How to let IIS know that a perlscript is a perlscript
and how to execute it

  1. Create a virtual cgi-Directory in Microsoft Internet Service-manager
  2. Set access to this directory to "Execute" only, not Read
  3. Open Registryeditor and go to HKLM/System/CurrentControlSet/Services/W3SVC/Parameters/Script Map and create a new entry of the type "string" which looks like this:
    .pl  --->   e:\programme\perl\bin\perl.exe "%s" "%s"
    
  4. Create a little Perl-script in your cgi-directory like this:
    print "Content-Type: text/html\n\n";
    print "Hello, you made it run";
    

There is a nice place to see this at http://www.geocities.com/SiliconValley/Park/8312/perlis.htm
You can find an FAQ for IIS and related things at http://www.15Seconds.com/faq/

Changing UTF-8 umlauts to ISO-8859-1

You get UTF8-characters when transferring data via XML. You recognize strange double-characters in your documents.

use Encode;
my $your_string = get_string_from_xml();
Encode::from_to(
    $your_string,
    'utf8', 'iso-8859-1');
}

Changing Umlauts to HTML-Code

You have to change codes when gettings Latin1-text to be shown in a browser:

use HTML::Entities;
my $with_german_umlauts = 'Räder, Rübensack, weiß';
print encode_entities($with_german_umlauts) . "\n";
# gives: Räder, Rübensack, weiß
sub umlautstring2html {
    # change umlauts in a string into the right codes of HTML
    # defined in ISO 8879, only what I need for the moment
    my ($x) = @_;

    # german Umlaute
    $x =~ s/ä/\ä/g;
    $x =~ s/ö/\ö/g;
    $x =~ s/ü/\ü/g;
    $x =~ s/Ä/\Ä/g;
    $x =~ s/Ö/\Ö/g;
    $x =~ s/Ü/\Ü/g;
    $x =~ s/ß/\ß/g;

    # french
    $x =~ s/ò/\&\\#242;/g;
    $x =~ s/ó/\&\\#243;/g;
    $x =~ s/ô/\&\\#244;/g;

    #
    $x =~ s/\&/\&/g;    # Ampersand
    $x =~ s/\>/\>/g;     # >
    $x =~ s/\</\&lt;/g;     # <
    $x =~ s/©/\&#169;/g;    # Copyright
    return $x;
}

Reading fixed length records from a file

When you get data from your bank they often use fixed length records. You usually

# file: fixread.pl
#
( $FALSE, $TRUE ) = ( 0, 1 );
$debug = $FALSE;

# Take this file to see this program run
# just delete ## at each line and write this
# to the file "accounts.txt":
##ThisIsTheHeaderFromYourBank.Band:Bank Of America
##1234567890Richard Lippmann 76250000
##2345454660Astrid Windigman 76250000
##9999911111Robert Cowers    76250000
# Description of fixed length data:
# header: 50 bytes
# 10 bytes account-number
# 19 bytes account-ame
# 8 bytes bank-id
# _fqn means "fully qualified name"
$input_fqn = "accounts.txt";

#
$recordlength = 38;

# Define record for unpack
# A=ASCII, A10 10 Bytes Ascii
# A10A19: 10 Bytes Ascii, then 19 Bytes ASCII and so on
$template = "A10A19A8";

# begin with filehandling
open( FH, $input_fqn ) || die "Could not open $input_fqn\\n";

# overjump header with seek, the header is not interesting for me
seek( FH, 50, 0 );
until ( eof(FH) ) {

    # read a $recordlength bytes,
    # result of reading the file is in $record
    # result of read is the number of bytes read
    read( FH, $record, $recordlength ) == $recordlength
      or die "wrong recordlength\\n";
    print "Record is $record\\n--\\n" if $debug;

    #
    # seperate fields according to the template
    @fields = unpack( $template, $record );

    #
    print "=== Record is ===\\n";
    print "account-nr is: $fields[0]<--\n";
    print "account-name is: $fields[1]<--\n";
    print "bank-id is : $fields[2]<--\n";
}
close FH;
print "End of $0\\n";

Reading a password from keyboard without showing it

A module is doing the deal:

#!/usr/bin/perl
use strict;
use warnings;
use Term::ReadKey;

print "Password:";
ReadMode 'noecho';
my $password = ReadLine(0);
print "\n";
chomp($password);
ReadMode 'normal';

Detecting wether a file has been changed with Digest::MD5 checksums

A subroutine checks creates the digital fingerprints of the file:

use strict;
use Digest::MD5;
my $fi = 'e:\temp\x.log';
unlink $fi;
foreach my $i ( 1 .. 10 ) {
    open( FI, ">>$fi" );
    print FI $i;
    close FI;
    printf "Checksum is: %s\n", &file_checksum($fi);
}
exit;

sub file_checksum {
    my ($file) = @_;
    if ( -e $file ) {
        open( FILE, $file );
        binmode(FILE);
        my $ctx = Digest::MD5->new;
        $ctx->addfile(*FILE);
        close FILE;
        return $ctx->b64digest;
    }
    else {
        return 0;
    }
}

dos2unix with Perl

perl -i -pe 'tr/\015//d' yourprogram.pl

How to cut a URL

#!/usr/bin/perl
use strict;
use warnings;
use URI::URL;

my $url = 'http://lena.franken.de/users/lisa/horshack/index.html';

my $u = URI::URL->new($url);
printf "host ist %s\\n", $u->host();    # gives "lena.franken.de"

How to recognize a version number from a module

You need this when developing modules which change frequently and have new routines which are available the first time with a certain version number.

package Customer::Remote;
use strict;
use warnings;

# Return version of this *.pm
# In your own module "use mymodul.pm 1.03;"
# sub-version-number is with two numbers (x.xx)
use Exporter;
our $VERSION = '0.03';

our @EXPORT      = qw();
our @EXPORT_OK   = qw();
our %EXPORT_TAGS = ();

...

Call the module with:

use Customer::Remote 1.01;

If the module version is smaller the programm dies.

Machinename, memoryinformation,
processorinformation, os & servicepack

use Win32::AdminMisc;
use Win32::NetAdmin;

print "--- network\n";
my $machine = Win32::NodeName;
print "nodename: $machine\n";

print "--- ram\n";
my %mem = Win32::AdminMisc::GetMemoryInfo();
print "ramtotal: $mem{RAMTotal}\n";
print "pagetotal: $mem{PageTotal}\n";

print "--- processor\n";
my %processor = Win32::AdminMisc::GetProcessorInfo();
print "processortype: $processor{ProcessorType}\n";

print "--- os\n";
my %os = Win32::AdminMisc::GetWinVersion();
print "platform: $os{Platform}\n";
print "major: $os{Major}\n";

# $os{CSD} is "Service Pack 3"
$os{ServicePack} = $os{CSD};
$os{ServicePack} =~ s/^(.*) (\d+)$/$2/;
print "sp: $os{ServicePack}\n";

Output is something like this:

--- network
nodename: LISA
--- ram
ramtotal: 133615616
pagetotal: 265822208
--- processor
processortype: 586
--- os
platform: Win32_NT
major: 4
sp: 4

How much space is left on all harddrives?

This is nice for executing in a loginscript and writing the data into a logfile and getting alarmed if drivespace gets low.

# free space on drives
use Win32::AdminMisc;
use Win32::NetAdmin;

printf "# %s;%s;%s\n", "date", "computername", "drivespace";
printf "%s;%s;%s\n", heute(), $ENV{'computername'}, drivespace();

sub heute {
    my ( $sek, $min, $std, $mtag, $mon, $jahr, $wtag, $jtag, $isdt ) =
      localtime(time);
    return sprintf( "%02d.%02d.%04d", $mtag, 1 + $mon, 1900 + $jahr );
}

sub drivespace {
    my $info;

    # which drives are available, possible parameters are:
    # DRIVE_REMOTE
    # DRIVE_FIXED
    # DRIVE_CDROM
    # DRIVE_REMOVABLE
    my @drives = Win32::AdminMisc::GetDrives(DRIVE_FIXED);
    foreach my $drive ( sort @drives ) {
        my ( $total, $free ) = Win32::AdminMisc::GetDriveSpace($drive);
        $drive =~ s/:\\\\$//;
        $free  = int( $free /  ( 1024 * 1024 ) );
        $total = int( $total / ( 1024 * 1024 ) );
        my $prozent = int( 100 * $free / $total );
        push( @info,
"drive=$drive free=${free}MB total=${total}MB percentfree=${prozent}%"
        );
    }
    return join( ",", @info );
}

You get this as result:

D:\daten\perl\misc> perl D:\daten\perl\misc\free_drivespace2.pl
# date;computername;drivespace
17.09.2000;LISA;drive=C free=194MB total=297MB prozentfrei=65%,drive=D free=654MB total=2008MB percentfree=32%

Profiler

A profiler show how much time your code spends in each subroutine. Needed if code needs to long to execute and you don't know where it needs that long time.

NYTProfiler

Install it:

perl -MCPAN -eshell
> install Devel::NYTProf

Use it in your program:

#!/usr/bin/perl -d:NYTProf
...

Output is written to file nytprof.out which nobody wants to read. You have to format it with a helperprogram:

www-data> nytprofhtml
[... html-file are written to new directory ./nytprof]

Maybe you need this directive in your apache-config to view the file in your web-browser:

Alias /cgi-bin/xxxx/nytprof /var/www/ap1/cgi-bin/xxxx/nytprof
<Directory "/var/www/ap1/cgi-bin/xxxx/nytprof">
    Options Indexes FollowSymLinks
</Directory>

Getting a value from SNMP

#!/usr/bin/perl
use strict;
use warnings;
use Net::SNMP;

my ( $session, $error ) = Net::SNMP->session(
    -hostname  => 'somehost.local',
    -version   => 1,
    -community => 'public'
);

if ( !defined $session ) {
    printf "ERROR: %s.\n", $error;
    exit 1;
}

my $oid = '1.3.6.1.2.1.2.2.1.10.3';

my $result = $session->get_request( -varbindlist => [$oid], );

if ( !defined $result ) {
    printf "ERROR: %s.\n", $session->error();
    $session->close();
}

printf "result = %s\n", $result->{$oid};
Impressum