Wednesday, March 21, 2012

Perl automation



Chapter 3. Preface
3.1. Objectives
All tests successful.
Files=10, Tests=2078, 50 wallclock secs
  • Why and when to test ?
  • Learn about the tools Perl provides for automated testing
  • Use the test framework provided by Perl

Chapter 4. Manual testing

4.1. Manual testing

Before we dig in into the world of automated testing we should first see that we are speaking about the same thing.

4.2. Web site testing

·         You type in a URL
·         see if the site comes up correctly,
·         click on the link to the registration form,
·         Fill in the fields (you'll have to play with this and fill in the fields with good values, bad values, find the edge cases etc.)
·         Check if you get back the correct response page.
·         Maybe check if the database contains the correct information

4.3. CLI testing

Here you have a device like a router, or some other box connected to the network. Normally you would telnet to it and then interactively test the various commands to see if they work. In addition you might be able to fetch the raw configuration information where you can validate if the configuration values were written correctly.
Going even further after you configured the device somehow you can test it if the new behavior of the device really can be observed: You connect other devices and ping this box or try to send packets and see if they get to the correct location.
·         Telnet to device
·         Use SNMP to monitor/configure the device
·         Prepare external entities on 2 or more sides of the device
·         Send packets
·         Check if the packets were received correctly

4.4. Database testing
This can be considered as part of any application as there is some kind of a database used by every application. In the simple case the 'database' might be a flat file but it can also be some csv file or xml file or an RDBMS that you can access using SQL. In this case you would like to test what are the consequences on the database of certain operations of the application?
  • Prepare a database
  • Execute some code
  • Check if the database was updated correctly
4.5. GUI testing
  • Launch the application
  • Find various controls
  • Type in values/check if they show up correctly
  • Push buttons
  • Check if results are correct

Chapter 5. Basic Testing Framework in Perl
5.1. Testing a simple command line tool
First we'll talk about a simple application with simple tests and from there you'll be able to move on to test more complex applications. I have a new calculator program called "mycalc". It expects a mathematical expression on the command line and prints the result on the screen. e.g.:
Example 5-1. mycalc on the command line
> mycalc 3 + 4 
7
Let's look at it first an then write a couple of tests for it.

5.2. Calculator test

Example 5-2. examples/intro/t01_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
system "./mycalc 1  + 1";
print "\n";
system "./mycalc 2 + 2";
print "\n";
system "./mycalc 2 + 2 + 2";
print "\n";
Output:
Example 5-3. examples/intro/t01_calc.out
2
4
4
5.3. Error !
Did you notice the bad answer ?
The third line should have been 6.

5.4. Calculator test with expected results

So we should write the expected value next to the correct one:
Example 5-4. examples/intro/t02_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
system "./mycalc 1  + 1";
print " 2\n";
system "./mycalc 2 + 2";
print " 4\n";
system "./mycalc 2 + 2 + 2";
print " 6\n";
Output:
Example 5-5. examples/intro/t02_calc.out
2 2
4 4
4 6
Now it is better.

5.5. More difficult output

But what if the expected output is:
This is the expected output of my program that should be checked.
This is the expected output of my program that should be checked.
Yes, in this case they are actually the same. What if you had 300 such line pairs ? And what if 3000 ?
It would be probably much better if our testing program already compared the expected value with the actual results and would only print OK or NOT OK depending on success or failures.
OK
OK
NOT OK

5.6. Print only ok/not ok

Example 5-6. examples/intro/t03_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
my $result;
 
$result = `./mycalc 1  + 1`;
if ( $result == 2 ) {
    print "ok\n";
}
else {
    print "not ok\n";
}
 
$result = `./mycalc 2 + 2`;
if ( $result == 4 ) {
    print "ok\n";
}
else {
    print "not ok\n";
}
 
$result = `./mycalc 2 + 2 + 2`;
if ( $result == 6 ) {
    print "ok\n";
}
else {
    print "not ok\n";
}
 
# We replaced the "system" calls with backtick in order to catch the STDOUT
# It is extreamly verbose and we are repeating the same code a lot of times
Output:
Example 5-7. examples/intro/t03_calc.out
ok
ok
not ok

5.7. Write the ok function

Example 5-8. examples/intro/t04_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
ok(`./mycalc 1  + 1` == 2);
ok(`./mycalc 2 + 2` == 4);
ok(`./mycalc 2 + 2 + 2` == 6);
 
sub ok {
    my ($ok) = @_;
    print $ok ? "ok\n" : "not ok\n";
}
Output:
Example 5-9. examples/intro/t04_calc.out
ok
ok
not ok
But why reinvent the wheel ?
Besides, if there are lots of tests, we would need some way to easily recognise which test(s) fail. So we should put a counter on our tests.

5.8. Introducing Test::Simple

Example 5-10. examples/intro/t05_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
# tell how many tests you are going to write. This is our "plan"
use Test::Simple tests => 3;
 
# the ok function of Test::Simple prints "ok" or "not ok"
ok `./mycalc 1 + 1` == 2;
ok `./mycalc 2 + 2` == 4;
ok `./mycalc 2 + 2 + 2` == 6;
Output:
Example 5-11. examples/intro/t05_calc.out
1..3
ok 1
ok 2
not ok 3
#   Failed test in t05_calc.t at line 11.
# Looks like you failed 1 test of 3.
It is more verbose, it has a couple of additional useful piece of information: 1..3 says how many tests we were planning then we get the tests numbered and we even get a small explanation when the test fails.

5.9. Add names to the tests

So Test::Simple makes our life a bit more simple in that we don't have to write our testing expression. In addition this new "ok" function can actually do some more favour. It can get two arguments. The first one indicates success or failure of the test and the second one is the name of the test. When running a test with these additional names they get printed on the same line where the "ok" or "not ok" is printed. In case of lots of tests it will make it easier to locate the test and if the names were written carefully they can provide an immediate hint what went wrong. Sometimes you won't even need to look at the test script itself, right from this comment you'll know where to look for the bug.
Example 5-12. examples/intro/t09_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::Simple tests => 3;
 
ok `./mycalc 1 + 1` == 2,     'small sum: 1+1';
ok `./mycalc 2 + 2` == 4,     'small sum: 2+2';
ok `./mycalc 2 + 2 + 2` == 6, 'two operators: 2+2+2';
Output:
Example 5-13. examples/intro/t09_calc.out
1..3
ok 1 - small sum: 1+1
ok 2 - small sum: 2+2
not ok 3 - two operators: 2+2+2
#   Failed test 'two operators: 2+2+2'
#   in t09_calc.t at line 9.
# Looks like you failed 1 test of 3.

5.10. Enlarge our test suit

Example 5-14. examples/intro/t10_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
my %tests = (
    '1 + 1'     => 2,
    '2 + 2'     => 4,
    '2 + 2 + 2' => 6,
    '1+1'       => 2,
    '0+ -1'     => -1,
    '0-1'       => -1,
    '-1+1'      => 0,
);
 
use Test::Simple tests => 7;
 
foreach my $t ( keys %tests ) {
    ok( `./mycalc $t` == $tests{$t}, $t );
}
Example 5-15. examples/intro/t10_calc.out
1..7
ok 1 - 0-1
ok 2 - 1 + 1
ok 3 - -1+1
ok 4 - 0+ -1
ok 5 - 1+1
not ok 6 - 2 + 2 + 2
#   Failed test '2 + 2 + 2'
#   in t10_calc.t at line 18.
ok 7 - 2 + 2
# Looks like you failed 1 test of 7.
There is a small problem though. When you add a new test to the hash, you also have to remember to update the tests => 7 line.
There are a number of solution to this problem

5.11. Load Test::Simple at run time

Example 5-16. examples/intro/t11_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
my %tests = (
    '1 + 1'     => 2,
    '2 + 2'     => 4,
    '2 + 2 + 2' => 6,
    '1+1'       => 2,
    '0+ -1'     => -1,
    '0-1'       => -1,
    '-1+1'      => 0,
);
 
require Test::Simple;
import Test::Simple tests => scalar keys %tests;
 
foreach my $t ( keys %tests ) {
    ok( `./mycalc $t` == $tests{$t}, $t );
}

5.12. Forget about your "plan", use "no_plan"

Example 5-17. examples/intro/t12_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
my %tests = (
    '1 + 1'     => 2,
    '2 + 2'     => 4,
    '2 + 2 + 2' => 6,
    '1+1'       => 2,
    '0+ -1'     => -1,
    '0-1'       => -1,
    '-1+1'      => 0,
);
 
use Test::Simple "no_plan";
 
foreach my $t ( keys %tests ) {
    ok( `./mycalc $t` == $tests{$t}, $t );
}
Example 5-18. examples/intro/t12_calc.out
ok 1 - 0-1
ok 2 - 1 + 1
ok 3 - -1+1
ok 4 - 0+ -1
ok 5 - 1+1
not ok 6 - 2 + 2 + 2
#   Failed test '2 + 2 + 2'
#   in t12_calc.t at line 18.
ok 7 - 2 + 2
1..7
# Looks like you failed 1 test of 7.
The 1..7 is now at the end.

5.13. Put the test cases in an external file

Example 5-19. examples/intro/t13_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::Simple "no_plan";
 
open my $fh, "<", "calc.txt" or die $!;
 
while ( my $line = <$fh> ) {
    chomp $line;
    next if $line =~ /^\s*$/;
    next if $line =~ /^#/;
 
    my ( $exp, $res ) = split /\s*=\s*/, $line;
 
    ok( `./mycalc $exp` == $res, $exp );
}
Example 5-20. examples/intro/calc.txt
# +
1 + 1      = 2
2 + 2      = 4
2 + 2 + 2  = 6
1+1        = 2
0+ -1      = -1
 
# -
0-1        = -1
 
# mixed
-1+1       = 0
Example 5-21. examples/intro/t13_calc.out
ok 1 - 1 + 1
ok 2 - 2 + 2
not ok 3 - 2 + 2 + 2
#   Failed test '2 + 2 + 2'
#   in t13_calc.t at line 16.
ok 4 - 1+1
ok 5 - 0+ -1
ok 6 - 0-1
ok 7 - -1+1
1..7
# Looks like you failed 1 test of 7.

5.14. Harness

This is a module that can analyse the ok / not ok printouts with the numbers. In particular it can analyse the output of Test::Simple, Test::More and all the Test::Builder based modules.
Example 5-22. examples/harness.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::Harness qw(runtests);
 
runtests @ARGV;
Run the previous test file using Test::Harness
$ perl ../harness.pl t13_calc.t
Example 5-23. examples/intro/t13_calc.harness.out
t13_calc....
#   Failed test '2 + 2 + 2'
#   in t13_calc.t at line 16.
# Looks like you failed 1 test of 7.
dubious
               Test returned status 1 (wstat 256, 0x100)
DIED. FAILED test 3
               Failed 1/7 tests, 85.71% okay
Failed Test Stat Wstat Total Fail  List of Failed
-------------------------------------------------------------------------------
t13_calc.t     1   256     7    1  3
Failed 1/1 test scripts. 1/7 subtests failed.
Files=1, Tests=7,  1 wallclock secs ( 0.12 cusr +  0.05 csys =  0.17 CPU)
Failed 1/1 test programs. 1/7 subtests failed.

5.15. Move external call into function

Example 5-24. examples/intro/t14_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::Simple "no_plan";
 
open my $fh, "<", "calc.txt" or die $!;
 
while ( my $line = <$fh> ) {
    chomp $line;
    next if $line =~ /^\s*(#.*)?$/;
 
    my ( $exp, $res ) = split /\s*=\s*/, $line;
 
    ok( mycalc($exp) == $res, $exp );
}
 
sub mycalc {
    return `./mycalc @_`;
}
See the mycalc() function.

We could have also implemented this in a module called Mycalc.
In that case we would just write use Mycalc; and test the exported function.
use MyCalc;
use Test::Simple tests => 1;
ok(mycalc('2 + 3') == 5);

5.16. Exercises: MyCalc

There is a module called MyCalc in the examples/intro directory.
Read its documentation using "perldoc MyCalc".

Write at least 5 tests for each function of the module.

5.17. Solution: MyCalc

Example 5-25. examples/intro/mycalc_test.t
#!/usr/bin/perl 
use strict;
use warnings;
 
use Test::Simple tests => 5+2*3;
 
use MyCalc;
 
# tests, one by one
ok(add(1, 1) ==  2);
ok(add(1, -1) == 0);
ok(sum(1) == 1);
ok(sum() == 0);
ok(sum(1, 1, 1, 1) == 4);
 
 
# tests listed in an array
my @tests = (
    {
        func => 'add',
        in   => [2, 3],
        out  => 5,
    },
    {
        func => 'sum',
        in   => [1, 2, 3],
        out  => 6,
    },
);
 
 
foreach my $t (@tests) {
    if ($t->{func} eq 'add') {
        ok(add( @{ $t->{in} } ) == $t->{out}, "add @{ $t->{in} }");
    }
    if ($t->{func} eq 'sum') {
        ok(sum( @{ $t->{in} } ) == $t->{out}, "sum @{ $t->{in} }");
    }
}
 
# The same but                   Danger! Danger! Danger!
# Using symbolic references here!
foreach my $t (@tests) {
    no strict 'refs'; 
 
    ok(&{ $t->{func} }( @{ $t->{in} } ) == $t->{out}, "$t->{func} @{ $t->{in} }");
 
    # the same with helper variables:
    my $func = $t->{func};
    my @in   = @{ $t->{in} };
    ok(&$func(@in) == $t->{out}, "$func @in");
 
}

5.18. Test::Simple

This is all very nice and Simple.


What if you want More ?

Chapter 6. Test::More

6.1. Moving over to Test::More

Test::Simple is really a very simple module. Its sole exported function is the "ok" function.

Test::More has the same "ok" function - so it is a drop-in replacement - but it also has lots of
other functions and tools:
·         ok
·         is
·         isnt
·         diag
·         like
·         cmp_ok
·         is_deeply
·         SKIP
·         TODO

6.2. Test::More ok( trueness, name);

A drop-in replacement of Test::Simple.
Example 6-1. examples/intro/t21_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 3;
 
ok `./mycalc 1 + 1` == 2,     '1+1';
ok `./mycalc 2 + 2` == 4,     '2+2';
ok `./mycalc 2 + 2 + 2` == 6, '2+2+2';
Result
 
$ perl t6_calc.t 
1..3
ok 1 - 1+1
ok 2 - 2+2
not ok 3 - 2+2+2
#     Failed test (t6_calc.t at line 7)
# Looks like you failed 1 tests of 3.

6.3. Test::More is( value, expected_value, name);

It would be much better to see the expected value and the actually received value. This usually helps in locating the problem.
Example 6-2. examples/intro/t22_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 3;
 
is `./mycalc 1 + 1`,     2, '1+1';
is `./mycalc 2 + 2`,     4, '2+2';
is `./mycalc 2 + 2 + 2`, 6, '2+2+2';
Result
 
$ perl t7_calc.t 
1..3
ok 1 - 1+1
ok 2 - 2+2
not ok 3 - 2+2+2
#     Failed test (t7_calc.t at line 7)
#          got: '4'
#     expected: '6'
# Looks like you failed 1 tests of 3.
See, in this case we can already guess that it cannot add 3 values.
compares using eq

6.4. diag(just_a_message );

diag prints out a message along with the rest of the output.
Use it for whatever extra output in order to ensure that your printouts will not interfere with future changes in the test environment modules (such as Test::Harness).
diag "We are going to test the Foo-Bar device now";
# We are going to test the Foo-Bar device now

6.5. like(value, qr/expected regex/, name);

It is especially important when you don't want or can't realisticly expect an exact match with the result.
compares with =~
Example 6-3. examples/intro/like.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 2;
 
like( foo(), qr/\d+/, "there are some digits in the result" );
like( bar(), qr/\d+/, "there are some digits in the result" );
 
sub foo {
    return "This is a long text with a number 42 in it";
}
sub bar {
    return "This is another string with no number in it";
}
$ perl like.t
1..2
ok 1 - there are some digits in the result
not ok 2 - there are some digits in the result
#   Failed test 'there are some digits in the result'
#   in like.t at line 7.
#                   'This is another string with no number in it'
#     doesn't match '(?-xism:\d+)'
# Looks like you failed 1 test of 2.

6.6. cmp_ok( this, op, that, name);

compares with anything
Example 6-4. examples/intro/cmp_ok.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 2;
 
my $start = time;
wait_for_input_with_timeout(3);
my $end = time;
 
cmp_ok $end - $start, ">=", 2, "process was waiting at least 2 secs";
cmp_ok $end - $start, "<=", 3, "process was waiting at most 3 secs";
 
sub wait_for_input_with_timeout {
    sleep rand shift;
}
$ perl cmp_ok.t 
not ok 1 - process was waiting enough
#     Failed test (cmp_ok.t at line 7)
#     '0'
#         >=
#     '2'
ok 2 - process was waiting enough
1..2
# Looks like you failed 1 tests of 2.

6.7. is_deeply( complex_structure, expected_complex structure, name);

Compare two Perl data structures:
Example 6-5. examples/intro/is_deeply.t
#!/usr/bin/perl 
use strict;
use warnings;
 
use Test::More tests => 3;
 
my %expected = (
    bugs     => 3,
    errors   => 6,
    failures => 8,
    warnings => 1,
);
 
 
my %a = fetch_data_from_bug_tracking_system(0);
is_deeply( \%a, \%expected, "Query 0" );
 
my %b = fetch_data_from_bug_tracking_system(1);
is_deeply( \%b, \%expected, "Query 1" );
 
my %c = fetch_data_from_bug_tracking_system(2);
is_deeply( \%c, \%expected, "Query 2" );
 
 
sub fetch_data_from_bug_tracking_system {
    my @sets = (
        {   bugs     => 3,
            errors   => 6,
            failures => 8,
            warnings => 1,
        },
        {   bugs     => 3,
            errors   => 9,
            failures => 8,
            warnings => 1,
        },
        {   bogs     => 3,
            erors    => 9,
            failures => 8,
            warnings => 1,
        },
    );
    my $h = $sets[shift];
    return %$h;
}
Example 6-6. examples/intro/is_deeply.out
1..3
ok 1 - Query 0
not ok 2 - Query 1
#   Failed test 'Query 1'
#   in is_deeply.t at line 19.
#     Structures begin differing at:
#          $got->{errors} = '9'
#     $expected->{errors} = '6'
not ok 3 - Query 2
#   Failed test 'Query 2'
#   in is_deeply.t at line 22.
#     Structures begin differing at:
#          $got->{errors} = Does not exist
#     $expected->{errors} = '6'
# Looks like you failed 2 tests of 3.

6.8. TODO

Example 6-7. examples/intro/t23_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 3;
 
is `./mycalc 1 + 1`, 2, '1+1';
is `./mycalc 2 + 2`, 4, '2+2';
 
TODO: {
    local $TODO = "Once we learn how to add 3 values";
    is `./mycalc 2 + 2 + 2`, 6, '2+2+2';
}
Results:
 
1..3
ok 1 - 1+1
ok 2 - 2+2
not ok 3 - 2+2+2 # TODO Once we learn how to add 3 values
#     Failed (TODO) test (t8_calc.t at line 10)
#          got: '4'
#     expected: '6'
 
This will be more interesting once we start to use Test::Harness

6.9. TODO with Harness

$ perl t8_calc.t 
1..3
ok 1 - 1+1
ok 2 - 2+2
not ok 3 - 2+2+2 # TODO Once we learn how to add 3 values
#     Failed (TODO) test (t8_calc.t at line 10)
#          got: '4'
#     expected: '6'
$ perl ../harness.pl t8_calc.t 
t8_calc....ok                                                                
All tests successful.
Files=1, Tests=3,  0 wallclock secs ( 0.04 cusr +  0.01 csys =  0.05 CPU)

6.10. Platform dependent tests

Example 6-8. examples/intro/without_skip.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More "no_plan";
 
like( `/sbin/ifconfig`, qr/eth0/ );
like( `ipconfig`,       qr/Windows IP Configuration/ );
$ perl without_skip.t 
ok 1
not ok 2
#     Failed test (without_skip.t at line 5)
#                   undef
#     doesn't match '(?-xism:Windows IP Configuration)'
1..2
# Looks like you failed 1 tests of 2.

6.11. SKIP some tests

Example 6-9. examples/intro/skip.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 2;
 
like( `/sbin/ifconfig`, qr/eth0/ );
 
SKIP: {
    skip "Windows related tests", 1 if $^O !~ /Win/i;
    like( `ipconfig`, qr/Windows IP Configuration/ );
}
$ perl skip.t 
ok 1
ok 2 # skip Windows related tests
1..2

6.12. My own test functions

After writing lots of tests, you'll start to re-factor your code and create functions for specific parts of the test:
You will have some code like this:
use Test::More tests => 2;
is(my_test(2, '+', 3), 5);
is(my_test(4, '+', 4), 10);
 
 
sub my_test {
   my ($x, $op, $z) = @_;
 
   # do stuff
 
   return $result;
}

6.13. My own test functions - improved

It would be better if we could eliminate the multiple occurance of is
use Test::More tests => 2;
my_test(2, '+', 3, 5);
my_test(4, '+', 4, 10);
 
 
sub my_test {
   my ($x, $op, $z, $expected) = @_;
 
   # do stuff
 
   is($result, $expected);
}

6.14. Create a test module

You need the above my_test subroutine in several of your test files. So you create a module for this. 
use Test::More tests => 2;
use Test::MyTest "my_test";
my_test(2, '+', 3, 5);
my_test(4, '+', 4, 10);
package Test::MyTest;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(my_test);
 
sub my_test {
   my ($x, $op, $z, $expected) = @_;
 
   # do stuff
 
   is($result, $expected);
}
Not good !
We need the is function from the Test::More package. so we'll have to use it in our module as well but Test::More needs a "plan".
6.15. Test::Builder
Example 6-10. examples/intro/Test/MyTest.pm
package Test::MyTest;
use strict;
use warnings;


use base 'Exporter';
our @EXPORT_OK = qw(my_test);

use Test::Builder;

my $Test = Test::Builder->new;


sub my_test {
    my ($x, $op, $y, $expected) = @_;
   
    my $result;
    if ($op eq '+') {
        $result = $x + $y;
    } else {
        die "Not yet implemented";
    }


    $Test->is_num($result, $expected);
}


1;
Test modules created using Test::Builder all work nicely together. Among other things, they don't get confused with the counting of the tests.
Test::Simple, Test::More, Test::Exception, Test::Differences all use Test::Builder as a back-end.

6.16. Number of tests
The importance of the plan
It is always good to have a plan when you start working even if you are going to change your plans within a short time. If for nothing else if you use some version control you'll be able to see your progress. (What do you mean you don't have version control ?) Checking if the right number of tests were successfully executed is a test in itself. Some things that can go wrong if you don't check it:
  • Test script dies before running all the tests.
  • Test script dies after running all the tests.
  • You run too many tests - in itself it is not a problem but later when for some reason your test script stops after the correct number of test you won't notice the missing tests.
It is always good to have some plan.

6.17. Early Abnormal Exit

Example 6-11. examples/intro/early-abnormal-exit.t
#!/usr/bin/perl 
use strict;
use warnings;
 
# example of tests where the script dies before running all the tests
 
use Test::More tests => 4;
 
is `./mycalc 1 + 1`, 2, '1+1';
is `./mycalc 2 + 2`, 4, '2+2';
exit;
is `./mycalc 3 + 3`, 6, '3+3';
is `./mycalc 4 + 4`, 8, '4+4';
Directly:
1..4
ok 1 - 1+1
ok 2 - 2+2
# Looks like you planned 4 tests but only ran 2.
With Harness:
early-abnormal-exit....ok 2/4# Looks like you planned 4 tests but only ran 2.
early-abnormal-exit....dubious                                               
    Test returned status 2 (wstat 512, 0x200)
DIED. FAILED tests 3-4
    Failed 2/4 tests, 50.00% okay
Failed Test           Stat Wstat Total Fail  Failed  List of Failed
----------------------------
early-abnormal-exit.t    2   512     4    4 100.00%  3-4
Failed 1/1 test scripts, 0.00% okay. 2/4 subtests failed, 50.00% okay.

6.18. Less than planned tests - Early Normal Exit

Example 6-12. examples/intro/early-normal-exit.t
#!/usr/bin/perl
use strict;
use warnings;
 
# example of too few tests (less than planned)
 
use Test::More tests => 4;
 
is `./mycalc 1 + 1`, 2, '1+1';
is `./mycalc 2 + 2`, 4, '2+2';
is `./mycalc 3 + 3`, 6, '3+3';
Directly:
1..4
ok 1 - 1+1
ok 2 - 2+2
ok 3 - 3+3
# Looks like you planned 4 tests but only ran 3.
With Harness:
early-normal-exit....ok 2/4# Looks like you planned 4 tests but only ran 3.  
early-normal-exit....dubious                                                 
        Test returned status 1 (wstat 256, 0x100)
DIED. FAILED test 4
        Failed 1/4 tests, 75.00% okay
Failed Test         Stat Wstat Total Fail  Failed  List of Failed
-----------------------------
early-normal-exit.t    1   256     4    2  50.00%  4
Failed 1/1 test scripts, 0.00% okay. 1/4 subtests failed, 75.00% okay.

6.19. More tests than planned

Example 6-13. examples/intro/too-many-tests.t
#!/usr/bin/perl
use strict;
use warnings;
 
# example of too many tests (more than planned)
 
use Test::More tests => 2;
 
is( `./mycalc 1 + 1`, 2, '1+1' );
is( `./mycalc 2 + 2`, 4, '2+2' );
is( `./mycalc 3 + 3`, 6, '3+3' );
Directly:
1..2
ok 1 - 1+1
ok 2 - 2+2
ok 3 - 3+3
# Looks like you planned 2 tests but ran 1 extra.
With Harness:
too-many-tests....ok 3/2# Looks like you planned 2 tests but ran 1 extra.    
too-many-tests....dubious                                                    
        Test returned status 1 (wstat 256, 0x100)
DIED. FAILED test 3
        Failed 1/2 tests, 50.00% okay
Failed Test      Stat Wstat Total Fail  Failed  List of Failed
-------------------------------
too-many-tests.t    1   256     2    1  50.00%  3
Failed 1/1 test scripts, 0.00% okay. -1/2 subtests failed, 150.00% okay.

6.20. Multiply

Example 6-14. examples/intro/t24_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 1;
 
is `./mycalc 2 * 2`, 4, '2*2';
Results
$ perl t10_calc.t 
1..1
Bareword found where operator expected at (eval 1) line 1, near "2 IE"
        (Missing operator before IE?)
not ok 1 - 2*2
#     Failed test (t10_calc.t at line 5)
#          got: ''
#     expected: '4'
# Looks like you failed 1 tests of 1.

6.21. Error in the test

User error

When you find a problem it is not always the problem in the application you are testing.
If it was a human who did the work we would call it a "user error" but in our case the
user is a program itself. As the developer of the application can make errors the
person who writes the tests can also make errors.

6.22. Multiply - fixed

Example 6-15. examples/intro/t25_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 1;
 
is `./mycalc "2 * 2"`, 4, '2*2';
Results
$ perl t25_calc.t 
1..1
ok 1 - 2*2

6.23. Multiple expected values

Someone asked me this question:
Q: Is it possible instead of is(foo(), 42) to have a fixed set of expected values ?
A: With is there is no such option but you have a number of solutions anyway.
Example 6-16. examples/intro/multiple_choice.t
#!/usr/bin/perl
use strict;
use warnings;
 
# run this script several times to see the (random) error message
 
use Test::More tests => 2;
 
like( foo(), qr/^(23|42|68)$/ );
ok( grep { foo() eq $_ } ( 23, 42, 68 ), "name" );
 
sub foo {
    return ( ( 23, 42, 68, 100, 200 )[ rand(5) ] );
}
$ perl multiple_choice.t 
not ok 1
#     Failed test (multiple_choice.t at line 4)
#                   '100'
#     doesn't match '(?-xism:^(23|42|68)$)'
not ok 2
#     Failed test (multiple_choice.t at line 5)
1..2
# Looks like you failed 2 tests of 2.
 
$ perl multiple_choice.t 
ok 1
ok 2
1..2

6.24. Exercises

* take the ifconfig/ipconfig test script and fix it so
  there will be a skip block on the ifconfig part as well.

* create a test function is_any that will get
  a scalar and and a reference to an array and
  check if the scalar is one of the values in
  the array.
  write test script that uses this function.

* create a test module that exports the is_any function.
  Write test script that uses this module.

* Change the test script you wrote for MyCalc.pm
  to use the 'is' function of Test::More.

Chapter 7. Command line application

7.1. bc - An arbitrary precision calculator language

It is much more than a calculator, it is a language. Luckily we don't need to learn the whole language in order to to do simple calculations. Normally you execute 'bc' from the command line and then you type in your calculations. Pressing ENTER will do the calculation.

7.2. Normal operation

> bc
bc 1.06
Copyright 1991-1994, 1997, 1998, 2000 Free Software Foundation, Inc.
This is free software with ABSOLUTELY NO WARRANTY.
For details type `warranty'. 
23+7
30
quit
> 
Try it ....

7.3. Expect.pm

·         Provides a way to describe user behaviour in a command line environment
·         Can send information as if it was typed in the keyboard
·         Can wait for some Expect-ed value and based on this value do something
·         Originally an extension of Tcl
·         Ported to Perl
·         Can be used in environments such as:
o    Command line application like bc
o    Telnet to another box and type in things
o    Anything usually a person would do on the command line.

7.4. Simple computation - adding two values

Example 7-1. examples/bc/bc1.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Expect;
 
my $e = Expect->new;
$e->raw_pty(1);
$e->spawn("bc") or die "Cannot run bc\n";
$e->expect(1, "warranty") or die "no warranty\n";
$e->send("23+7\n");
$e->expect(1, 30) or die "no sum\n";
print "Success\n";
·         raw_pty turns off echo
·         spawn starts the external program
·         expect(timeout, regex) return undef if failed
·         timeout is in seconds, 0 means check once, undef means wait forever
·         send - as if the user was typing at the keyboard

7.5. Results

>perl examples/bc/bc1.pl
bc 1.06
Copyright 1991-1994, 1997, 1998, 2000 Free Software Foundation, Inc.
This is free software with ABSOLUTELY NO WARRANTY.
For details type `warranty'. 
30
Success

7.6. Simple computation - separate send commands

Instead of calling send once, we will call it now 4 times
Example 7-2. examples/bc/bc2.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Expect;
 
my $e = Expect->new;
$e->raw_pty(1);
$e->spawn("bc") or die "Cannot run bc\n";
$e->expect(1, "warranty") or die "no warranty\n";
$e->send("23");
$e->send("+");
$e->send("7");
$e->send("\n");
$e->expect(1, 30) or die "no sum\n";
print "Success\n";

7.7. Simple computation - is it really working ?

The same computation but we expect the wrong value ...
This is not that clever but I could not find a real bug in bc to show here as an example and I'd like to show what happens when the computation fails.
Example 7-3. examples/bc/bc3.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Expect;
 
my $e = Expect->new;
$e->raw_pty(1);
$e->spawn("bc") or die "Cannot run bc\n";
$e->expect(1, "warranty") or die "no warranty\n";
$e->send("23+7\n");
$e->expect(1, 29) or die "no sum\n";
print "Success\n";

7.8. Results

The same computation but we expect the wrong value ... and fail
>perl examples/bc/bc3.pl
bc 1.06
Copyright 1991-1994, 1997, 1998, 2000 Free Software Foundation, Inc.
This is free software with ABSOLUTELY NO WARRANTY.
For details type `warranty'. 
30
no sum

7.9. Reduce output

We don't want to see all the output bc generates and then try to look for the correct responses or the error messages. We'd prefer just see ok or not ok
Example 7-4. examples/bc/bc4.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Expect;
use Test::More qw(no_plan);
 
$Expect::Log_Stdout = 0;
 
my $e = Expect->new;
$e->raw_pty(1);
$e->spawn("bc") or die "Cannot run bc\n";
$e->expect(1, "warranty") or die "no warranty\n";
$e->send("23+7\n");
ok($e->expect(1, 30));
·         $Expect::Log_Stdout = 0; - turn off the printing to the screen

7.10. Output

>perl examples/bc/bc4.pl
ok 1
1..1

7.11. More than one test

We can then setup lot's of tests and run them through one invocation of bc.
Example 7-5. examples/bc/bc5.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Expect;
use Test::More qw(no_plan);
$Expect::Log_Stdout = 0;
 
my @sets = (
    [23+7,     30],
    ['23+7',   30],
    ['11+1',   10],
    ['2*21',   42],
);
 
my $e = Expect->new;
$e->spawn("bc") or die "Could not start bc\n";
$e->expect(undef, "warranty") or die "no warranty\n";
 
foreach my $set (@sets) {
    $e->send("$$set[0]\n");
    ok($e->expect(1, $$set[1]), $$set[0]);
}
$e->send("quit\n");

7.12. Output

>perl examples/bc/bc5.pl
#     You named your test '30'.  You shouldn't use numbers for your test names.
#     Very confusing.
ok 1 - 30
ok 2 - 23+7
not ok 3 - 11+1
#     Failed test (examples/bc/bc5.pl at line 20)
ok 4 - 2*21
1..4
# Looks like you failed 1 tests of 4.

7.13. External test file

Separating the test cases from the code.
Example 7-6. examples/bc/bc5a.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Expect;
use Test::More qw(no_plan);
$Expect::Log_Stdout = 0;
 
 
open my $fh, "<", "bc_input.txt" or die "Could not open bc_input.txt";
 
my @sets;
while (my $line = <$fh>) {
    chomp $line;
    push @sets, [split /\s*,\s*/, $line];
}
 
my $e = Expect->new;
$e->spawn("bc") or die "Could not start bc\n";
$e->expect(undef, "warranty") or die "no warranty\n";
 
foreach my $set (@sets) {
    $e->send("$$set[0]\n");
    ok($e->expect(1, $$set[1]), $$set[0]);
}
$e->send("quit\n");
7.14. Random regression tests
The idea that we don't have time to manually setup hundreds of tests and calculate our expectations
so instead we compare some random tests to the results of a previous run.

We can log the results of each operation in a file and compare
the resulting files to some previous execution.
  • Create a set of random operations
  • Because we don't have time to check all the results we only check if there were no error messages, but in general we don't care about the correctness of the results
  • Record the tests and the results
  • Run the tests again with the a version (now they are not random any more) and check if any of the results has changed. If something changed it indicates that either earlier or now we have a problem
  • Investigate the differences and include the problematic tests in the manual test suit
  • Either save the new results as the new expectation or discard it and discard the current version of the application
  •  
·         7.15. Random and regression testing
·         Example 7-7. examples/bc/bc6.pl
·         #!/usr/bin/perl
·         use strict;
·         use warnings;
·          
·         use File::Compare;
·         use Expect;
·         $Expect::Log_Stdout = 0;
·          
·         if (not @ARGV or $ARGV[0] ne "random" and $ARGV[0] ne "regress") {
·             die "Usage: $0 [random|regress]\n";
·         }
·         if ($ARGV[0] eq "regress" and not -e "tests.txt") {
·             die "Cannot run regression before running random tests!\n";
·         }
·          
·          
·         if ($ARGV[0] eq 'random') {
·             my $e = Expect->new;
·             $e->raw_pty(1);
·             $e->log_file("random.log", "w");
·             $e->spawn("bc") or die "Could not start bc\n";
·             $e->expect(1, "warranty") or die "no warranty\n";
·          
·             open my ($test_file), ">tests.txt" or die "Cannot open tests file for writing\n";
·          
·             foreach (1..3) {
·                 my ($a, $b) = (rand, rand);
·                 my $op = qw(+ * - /)[int rand 4];
·                 my $line = "$a $op $b\n";
·                 print $test_file $line;
·          
·                 $e->send($line);
·                 $e->expect(1,[qr/\d+/]);
·             }
·          
·             $e->send("quit\n");
·         }
·          
·         if ($ARGV[0] eq 'regress') {
·             my $e = Expect->new;
·             $e->raw_pty(1);
·             $e->log_file("regress.log", "w");
·             $e->spawn("bc") or die "Could not start bc\n";
·             $e->expect(1, "warranty") or die "no warranty\n";
·             
·             open my ($test_file), "tests.txt" or die "Cannot open tests file for reading\n";
·             while (my $line = <$test_file>) {
·                 $e->send($line);
·                 $e->expect(1, [qr/\d+/]);
·             }
·          
·             $e->send("quit\n");
·          
·             $e->log_file(undef);                     # close the log file
·          
·             if (compare("random.log", "regress.log")) {
·                 print "Regression failed\n";
·             } else {
·                 print "Regression successful\n";
·             }
·         }
·          
·         # Two parts
·         # - random tests
·         # - regression tests
·         #
·         #
·         # run random tests
·         # save test cases in a test cases file
·         # save all the results in a log file
·         #
·         #
·         # run all the tests from the test cases file and log results to a new log file
·         # compare original log with new log and complain if they are not the same.
·         #
·        
·         7.16. Random and regression testing - slight improvement
·         Example 7-8. examples/bc/bc7_diff.pl
·         #!/usr/bin/perl
·         use strict;
·         use warnings;
·          
·         use Text::Diff;          # instead of File::Compare
·          
·          
·         # and diff instead of compare
·         if (my $diff = diff ("random.log", "regress.log")) {
·             print "Regression failed\n\n";
·             print $diff;
·         } else {
·             print "Regression successful\n";
·         }
·        

7.17. Results

 
~/work/training/testing/examples/bc>perl bc7.pl regress
Regression failed
 
--- random.log  Mon Apr 19 23:09:51 2004
+++ regress.log Mon Apr 19 23:38:54 2004
@@ -3,5 +3,5 @@
 This is free software with ABSOLUTELY NO WARRANTY.
 For details type `warranty'. 
 1
-.9114942335378392
+.8114942335378392
 .8404963860314223

7.18. Recording session

A simple example how to "record" a session for later analysing and changing into a real script.
Example 7-9. examples/expect/record.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Expect;
 
my $exp = Expect->spawn("bash") or die "Cannot spawn bash child\n";
 
$exp->log_file($ARGV[0] || "record.log");
 
#$exp->raw_pty(1);
 
$exp->interact();
7.19. Capturing both STDOUT and STDERR
  • Write out the expected STDIN to a file called "in"
  • Run the app system "$app < in >out 2>err";
  • read in the out and err files an examine them

7.20. Capturing both STDOUT and STDERR manually

Example 7-10. examples/io/capture.pl
#!/usr/bin/perl -w
use strict;
 
use Test::More tests => 2;
 
 
my $app = "./examples/io/application.pl";
 
my @in = ('10', '21', 'hello', '3x');
my $in = join "\n", @in;
 
my @expected_out = ('20', '42');
my @expected_err = (
                               "The input 'hello' contains no numeric values", 
                               "The input '3x' contains no numeric values",
               );
 
{
               open my $fh, ">", "/tmp/in" or die $!;
               print $fh $in;
}
 
system "$app < /tmp/in > /tmp/out 2> /tmp/err";
 
{
               open my $fh, "<", "/tmp/out" or die $!;
               my @out = <$fh>;
               chomp @out;
               is_deeply(\@out, \@expected_out, "Output");
}             
{
               open my $fh, "<", "/tmp/err" or die $!;
               my @err = <$fh>;
               chomp @err;
               is_deeply(\@err, \@expected_err, "Error");
}            

7.21. Capturing both STDOUT and STDERR using IPC::Run3

Example 7-11. examples/io/capture_ipc.pl
#!/usr/bin/perl -w
use strict;
 
use Test::More tests => 2;
use IPC::Run3;
 
my $app = "./examples/io/application.pl";
 
my @in = ('10', '21', 'hello', '3x');
my $in = join "\n", @in;
 
my @expected_out = ('20', '42');
my @expected_err = (
                               "The input 'hello' contains no numeric values", 
                               "The input '3x' contains no numeric values",
               );
 
{
               my $out;
               my $err;
               run3 [$app], \$in, \$out, \$err;
 
               my $expected_out = join("\n", @expected_out) . "\n";
               is($out, $expected_out, "IPC Output");
               my $expected_err = join("\n", @expected_err) . "\n";
               is($err, $expected_err, "IPC Error");
}

Chapter 8. Networking devices

8.1. Introduction - pick the right abstraction level

When trying to connect some network device using Perl you have a number of choices.
See the full stack of HTTP connections:
·         built in socket function and the Socket module
·         IO::Socket::INET using IO::Socket
·         Net::Telnet, Net::FTP, Net::SSH (wrapping ssh), Net::SSH::Perl, Net::*
·         LWP::Simple, LWP
·         WWW::Mechanize
·         WWW::GMail
At the lowest level you can use the built in socket function.

Using the Socket library provides several extra functions
and constants that will make your code cleaner and more portable.

See also perlipc

8.2. Socket level programming using Socket.pm

Example 8-1. examples/network/socket.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Socket qw(:DEFAULT :crlf);
 
# Using the built in "socket" function with various helper variables
# and functions from the standard Socket.pm module
 
# get the protocol id (on Linux from /etc/protocols)
my $protocol_id     = getprotobyname('tcp');  
 
# build C structure in_addr from hostip
# if hostname is given it tries to resolve hostname to ip first (and returns
# undef if not successful)
#my $host = '127.0.0.1';
my $host = 'localhost';
#my $host = '66.249.85.99';
#my $host = 'www.google.com';
my $host_struct = inet_aton($host);  
# inet_ntoa($host_struct) returns the resolved ip address
 
my $port   = 80;
 
socket(my $socket, PF_INET, SOCK_STREAM, $protocol_id) or die $!;
my $sockaddr_in = pack_sockaddr_in($port, $host_struct);
 
connect($socket, $sockaddr_in) or die $!;
 
# turn off buffering on the socket
{
    my $old = select($socket);
    $| = 1;
    select($old);
}
 
print $socket "GET /$CRLF";
while (my $line = <$socket>) {
    print $line;
}

8.3. Socket level programming using IO::Socket

Example 8-2. examples/network/io_socket.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use IO::Socket;
 
# IO::Socket is a higher level abstraction
# Hides many of the ugly part we had to know in case of the socket() function.
# Provides an OOP interface.
 
#my $host = '127.0.0.1';
my $host = 'localhost';
#my $host = 'www.google.com';
#my $host = '209.85.135.103';
#my $host = 'www.perl.org.il';
 
my $port = 80;
my $CRLF = "\015\012";
 
my $socket = IO::Socket::INET->new(
            PeerAddr => $host,
            PeerPort => $port,
            Proto    => 'tcp',
        ) or die $!;
 
$socket->send("GET /$CRLF") or die $!;
 
my $SIZE = 100;
my $data = '';
while ($socket->read($data, $SIZE, length $data) == $SIZE) {};
print $data;

8.4. Newline

\n   is a newline on our current system (is NOT always ASCII LF)
\r   is (is NOT always ASCII CR)
use  \015\012   to say CR+LF on networking applications

8.5. Net::Telnet

Example 8-3. examples/telnet/telnet.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Net::Telnet ();
my $t = Net::Telnet->new();
 
$t->open('localhost');
$t->login('smoke', '123456');
my @lines = $t->cmd("who");
print @lines;
print "\n";
 
print "Who am i: ", $t->cmd("whoami"), "\n\n";

8.6. Net::Telnet for HTTP

Example 8-4. examples/telnet/telnet_http.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Net::Telnet ();
my $t = Net::Telnet->new(
                               Timeout => 10,
                               Host    => 'localhost',
                               Port    => 80,
               );
 
$t->print("GET /\n") or die $!;
while (my $line = $t->getline) {
               print $line;
}

8.7. Net::Telnet configure VLAN

Example 8-5. examples/telnet/configure_vlan.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Net::Telnet;
 
open my $out, ">>", "out.log" or die $!;
my $t = Net::Telnet->new(
                               Timeout    => 2,
                               #Prompt     => '/>/',
                               input_log  => "input.log",
);
 
$t->open("172.30.40.146");
 
$t->waitfor('/User:.*$/');
$t->print("admin");
 
$t->waitfor('/Password:/');
$t->print("");
 
$t->waitfor('/>/');
$t->prompt('/\(Switching\) >/');
my @lines = $t->cmd("show vlan 5");
 
 
if (grep /VLAN ID: 5/, @lines) {
               print "VLAN is already configured\n";
               print "Please remove it manually and rerun the program\n";
               exit;
               #$t->cmd("logout");
}
 
$t->print("enable");
$t->waitfor('/Password:/');
$t->prompt('/\(Switching\) #/');
$t->print("");
 
$t->prompt('/\(Switching\) \(Vlan\) #/');
@lines = $t->cmd("vlan database");
@lines = $t->cmd("vlan 5");
#print @lines;
#if (grep /VLAN already/, @lines) {
#             print "QQ 1\n";
#}
@lines = $t->cmd("vlan 5000");
#print @lines;
 
@lines = $t->cmd("vlan 5");
#print @lines;
#if (grep /VLAN already/, @lines) {
#             print "QQ 2\n";
#}
 
#@lines = $t->cmd("no vlan 5");
$t->prompt('/\(Switching\) #/');
$t->cmd("exit");
 
 
 
$t->prompt('/--More-- or \(q\)uit/');
@lines = $t->cmd("show ?");
 
$t->output_record_separator("");
push @lines, $t->cmd(" ");
 
 
$t->prompt('/\(Switching\) #show/');
push @lines, $t->cmd(" ");
#print @lines;
 
$t->output_record_separator("\n");
$t->prompt('/\(Switching\) #/');
@lines = $t->cmd(" vlan 5");  # show was left on the promt line !
#print @lines;
 
@lines = $t->cmd("show vlan 7");
#print @lines;
 
@lines = $t->cmd("show slot");
#print @lines;
print $out @lines;
 
 
 
$t->prompt('/\(Switching\) \(Vlan\) #/');
@lines = $t->cmd("vlan database");
@lines = $t->cmd("no vlan 5");
$t->prompt('/\(Switching\) #/');
 
 
$t->cmd("exit");
print "done: $_\n";
print $out "done: $_\n";
8.8. ftp using Net::FTP
Example 8-6. examples/network/upload.pl
#!/usr/bin/perl
use strict;
use warnings;

use Net::FTP;
use File::Basename qw(dirname);
use File::Spec;
my $DEBUG = 1;

if (not @ARGV) {
    print "Usage:\n";
    print "       $0 FILE [FILES]\n";
    exit;
}

my $ftp = Net::FTP->new('192.168.1.100') or die $!;
$ftp->login('gabor', 'the password of gabor') or die $!;
my $pwd = $ftp->pwd;


foreach my $file (@ARGV) {
    my $dir  = dirname $file;
    $ftp->cwd($pwd);
    $ftp->cwd($dir);
    $ftp->put($file);
}

8.9. ssh using Net::SSH

Wrapping the external ssh command. Therefore working only in UNIX/Linux.
See also Net::SSH::Perl.
Example 8-7. examples/network/ssh.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Net::SSH qw(sshopen2);
use IO::File;
my $output = IO::File->new;
my $input  = IO::File->new;
 
sshopen2("localhost", $output, $input) or die $!;
 
print $input "set\n";
print $input "echo DONE\n";
print $input "who\n";
print $input "echo DONE\n";
print $input "date\n";
print $input "echo DONE\n";
print $input "cat README\n";
print $input "exit\n";
 
my @out = <$output>;
 
my $c=0;
my @section;
while (my $line = shift @out) {
    if ($line =~ /^DONE$/) {
        $c++;
        next;
    }
    push @{$section[$c]}, $line;
}
foreach my $sect (@section) {
    print @$sect;
    print "--------------------\n";
}

8.10. LWP::Simple

Example 8-8. examples/network/lwp_simple.pl
#!/usr/bin/perl
use strict;
use warnings;
 
my $url = 'http://localhost/';
if (defined $ARGV[0]) {
    $url = $ARGV[0];
}
 
use LWP::Simple qw(get);
 
my $page = get($url);
if (defined $page) {
    print $page;
} else {
    print "Could not fetch $url\n";
}

8.11. LWP

Example 8-9. examples/network/lwp.pl
#!/usr/bin/perl
use strict;
use warnings;
 
my $url = 'http://localhost/';
if (defined $ARGV[0]) {
    $url = $ARGV[0];
}
use LWP::UserAgent;
my $ua = LWP::UserAgent->new;
$ua->agent("Internet Explorer/17.1");
my $req = HTTP::Request->new(GET => $url);
 
my $res = $ua->request($req);
 
if ($res->is_success) {
    print $res->content;
} else {
    print $res->status_line, "\n";
}

8.12. WWW::Mechanize

Example 8-10. examples/network/mechanize.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use WWW::Mechanize;
my $w = WWW::Mechanize->new();
$w->get('http://www.google.com/');
$w->submit_form(
    fields => {
        q => 'perl israel'
    },
);
$w->follow_link( n => 5 );
print $w->title;

8.13. WWW::GMail

Example 8-11. examples/network/gmail.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use WWW::GMail;
 
my $w = WWW::GMail->new(
    username => "USERNAME",
    password => "PASSWORD",
);
 
my $ret = $w->login();
if ($ret == -1) {
    die "password incorrect\n";
} elsif ($ret == 0) {
    die "unable to login $w->{error}\n";
}
 
my @messages = $w->get_message_list('inbox');
foreach my $msg (@messages) {
    print "Subject: $msg->[6]\n";
}

Chapter 9. Servers

9.1. Net::Server

We are going to use the Net::Server module to create various server processes.

9.2. Skeleton Server

First we create a skeleton server that does not do anything.
Example 9-1. examples/server/skeleton_server.pl
#!/usr/bin/perl -T
use strict;
use warnings;
 
use lib 'lib';
use SkeletonServer;
 
SkeletonServer->run(port => 8000);
Example 9-2. examples/server/lib/SkeletonServer.pm
package SkeletonServer;
use warnings;
use strict;
 
use base 'Net::Server';
 
sub process_request {
               # do your stuff
}
 
 
1;

9.3. Simple Echo Server

The Simple Echo Server lets you telnet to it and echos back every word you type.
Example 9-3. examples/server/simple_echo_server.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use lib 'lib';
use SimpleEchoServer;
 
SimpleEchoServer->run(port => 8000);
Example 9-4. examples/server/lib/SimpleEchoServer.pm
package SimpleEchoServer;
use warnings;
use strict;
 
use base 'Net::Server';
my $EOL   = "\r\n";
 
sub process_request {
    my $self = shift;
    while( my $line = <STDIN> ) {
        $line =~ s/\r?\n$//;
        print qq(You said "$line"$EOL);
        last if $line eq "bye";
    }
}
 
1;

9.4. Echo Server

The Echo Server lets you telnet to it and echos back every word you type just
like the Simple Echo Serever but once connected you have 5 seconds between
every two line you type or it prints Timeout and closes the connection.
Prints a message both to the client and the console (STDERR) of the server.
Example 9-5. examples/server/echo_server.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use lib 'lib';
use EchoServer;
 
EchoServer->run(port => 8000);
Example 9-6. examples/server/lib/EchoServer.pm
package EchoServer;
use warnings;
use strict;
 
use base 'Net::Server';
use English qw( -no_match_vars ) ;
 
my $timeout = 5; # give the user 5 seconds to type a line
my $EOL   = "\r\n";
 
sub process_request {
    my $self = shift;
    eval {
 
        local $SIG{ALRM} = sub { die "Timeout\n" };
 
        alarm($timeout);
        while( my $line = <STDIN> ) {
            alarm($timeout);
            $line =~ s/\r?\n$//;
            print qq(You said "$line"$EOL);
            last if $line eq "bye";
        }
    };
    alarm(0);
 
    
    if ( $EVAL_ERROR ) {
        if ( $EVAL_ERROR eq "Timeout\n" ) {
            print "Timed Out. Disconnecting...$EOL";
            print STDERR "Client timed Out.\n";
        } else {
            print "Unknown internal error. Disconnecting...$EOL";
            print STDERR "Unknown internal error: $EVAL_ERROR\n";
        }
    } else {
        print STDERR "User said bye\n";
    }
    return;
}
 
 
 
1;

9.5. Complex network servers

There are many other optiong to build a network server.
Besides providing more complex interaction with the single server one can
configure it to be able to handle multiple clients at the same time.

Just replace "use base 'Net::Server';"
by "use base 'Net::Server::PreFork';" and you have a preforking
web server.

Chapter 10. Command Line Interface

10.1. Introduction

We have a device that has a Command Line Interface (CLI).
Normally you would telnet to it and type in commands.

Let's see what can we do with Net::Telnet.

In order to do that first we need to see how the device behaves
when we access it manually.

Use the local telnet command to access the device and try
some basic commands. (eg. type "help")

We supply an example system that shows a partially faulty system.
In order to run the daemon by yourself you need to install
Net::Server and Class::Accessor,
$ cd examples/server
  and then type
$ perl cli_daemon.pl

When accessing it using a telnet client you can use the built in
username: admin and password: nimda.

10.2. Connect to the device

Setting both Dump_log and Input_log in the constructor of Net::Telnet
will allow us to see what is really going on on the connection.

We also add a call to wait for something that is likely won't show up
in the output. Depending on where the demo application (the daemon)
is running you might need to change the $hostname variable.
Example 10-1. examples/cli/cli_01.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Net::Telnet;
 
my $port = 8000;
my $hostname = 'localhost';
 
my $telnet = Net::Telnet->new(
                        Port      => $port,
                        Host      => $hostname,
                        Dump_log  => 'dump.log',
                        Input_log => 'input.log',
                    );
print "opened\n";
 
{
    my ($prematch, $match) = $telnet->waitfor('/not likely to show up/');
}
 
print "after wait\n";
Running the script we notice that after printing "opened" it waits
quite a lot of time and it never prints "after wait".

This happend because waitfor was waiting for a string that never
showed up. Hence it gave up waiting after the built-in timeout
period. Once it reached the timeout it called the default errmode()
function which is the "die" function. So the script never reached
the second print() and did not have a chance to print anything.

10.3. Reduce timeout

- Reduce the timeout
- Wait for a string we know will show up
- After seeing Username: we should type in 'admin', the username
Example 10-2. examples/cli/cli_02.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use Net::Telnet;
 
my $port = 8000;
my $hostname = 'localhost';
 
my $telnet = Net::Telnet->new(
                        Port      => $port,
                        Host      => $hostname,
                        Dump_log  => 'dump.log',
                        Input_log => 'input.log',
                        Timeout   => 1,
                    );
print "opened\n";
 
{
    my ($prematch, $match) = $telnet->waitfor('/Username:.*$/');
    if ($prematch =~ /Welcome/) {
        print "welcome printed\n";
    }
    $telnet->print('admin');
}
 
print "after wait\n";

10.4. Exercise: Telnet

* Manually check out what does this server do.
* Turn the two example clients scripts into test using Test::More.
* Continoue and write more tests for this telnet server.

10.5. Our test script

Example 10-3. examples/cli/cli.t
#!/usr/bin/perl -w
use strict;
 
use Test::More tests => 21;
use Net::Telnet;
my $port = 8000;
 
my $pid;
if (not @ARGV) {
    $pid = start_server();
    sleep 1;
    diag "Server started (pid: $pid)";
}
 
END {
    if ($pid) {
        stop_server($pid);
    }
}
 
 
 
my $telnet = _new('telnet');
ok(1, "opened (telnet)");
 
 
{
    my ($prematch, $match) = $telnet->waitfor('/Username:.*$/');
    like $prematch, qr/Welcome/, 'welcome printed (telnet)';
    $telnet->print('admin');
}
 
{
    my ($prematch, $match) = $telnet->waitfor('/Password:.*$/');
    is $prematch, '', 'empty prematch (telnet)';
    $telnet->print('nimda');
}
 
{
    my ($prematch, $match) = $telnet->waitfor('/\w+>/');
    is $prematch, '', 'empty prematch (telnet)';
    is $match, 'cli>', 'prompt is correct (telnet)';
}
 
{
    my @resp = $telnet->cmd('');
    is @resp, 1, '1 line in response to "" (telnet)';
    is $resp[0], '', 'ENTER (telnet)';
}
 
 
my $other = _new('other');
ok(1, 'opened (other)');
{
    my ($prematch, $match) = $other->waitfor('/Username:.*$/');
    like $prematch, qr/Welcome/, "welcome printed (other)";
 
    $other->print('admin');
}
 
{
    my ($prematch, $match) = $other->waitfor('/Password:.*$/');
    is $prematch, '', 'empty prematch (other)';
    $other->print('bad password');
}
 
#{
#    my ($prematch, $match) = $telnet->waitfor('/\w+>/');
#    is $prematch, '', 'empty prematch';
#    is $match, 'cli>', 'prompt is correct';
#} #error should not accept the password
 
 
 
{
    my @resp = $telnet->cmd('working?');
    is @resp, 1, "one line in response (telnet)";
    like $resp[0], qr/Invalid command: 'working\?'/, 'invalid command (telnet)';
}
 
{
    my @resp = $telnet->cmd('help');
    is @resp, 7, '7 lines in response to "help" (telnet)';
    like $resp[0], qr/help\s+-\s+this help/, 'invalid command (telnet)';
    # TODO: test more lines of the help?
}
 
TODO: {
    my @resp;
    eval {
        @resp = $telnet->cmd('?');
    };
    local $TODO = "? does not work: $@" if $@;
    is @resp, 7, '7 line in respons "?" (telnet)';
    push @resp, '' if $@; # to avoid warning on undef;
    like $resp[0], qr/help\s+-\s+this help/, 'invalid command (telnet)';
    # TODO: test more lines of the help?
 
    $telnet->buffer_empty;
}
 
{
    my @resp = $telnet->cmd('');
    is @resp, 1, '1 line in response to "" (telnet)';
    is $resp[0], '', 'ENTER (telnet)';
}
 
 
 
# TODO: how to catch the final Goodbye?
{
    my ($prematch, $match) = $telnet->waitfor('/.*$/');
    $telnet->print('exit');
    is($prematch, '', 'prematch is empty of "exit" (telnet)');
    is($match, '', 'match is empty "exit" (telnet)');
#    is $telnet->lastline, '';
    ok(1, 'done (telnet)');
    #my @resp = $telnet->cmd('exit');
    #is @resp, 1, "one line in respons";
    #like $resp[0], qr/Good bye/, 'Goodbye';
}    
 
exit;
# print enable
# waifor Password:
 
########################################## 
 
sub start_server {
    my $pid = fork();
    if (not defined $pid) {
        die "Canot fork\n";
    }
 
    if ($pid) { # parent
        return $pid;
    } else {    # child
        exec "$^X cli_daemon.pl --port $port --stderr"; 
    }
}
sub stop_server {
    my ($pid) = @_;
    diag "killing $pid";
    kill 3, $pid;
}
 
 
sub _new {
    my $t = Net::Telnet->new(
                        Port     => $port,
                        Prompt   => '/^.*>\s*$/m',
                        Host     => 'localhost',
                        Dump_log => "dump.log",
                        Timeout  => 1,
                    );
    return $t;
}
 
# TODO:
# enable mode, change password of regular user, 
# change password of enabled user 
# BUG: not cannot set password longer than 5 characters
# show config (in regular mode)
# set config (in enabled mode)
 
 
 
Chapter 11. Testing networking devices
11.1. Elements
  • Do some hardware setup, connect some wires
  • Access the administrative interface to configure the device
  • Configure devices on all sides of our box
  • Run test
  • Check results

Chapter 11. Testing networking devices
11.1. Elements
  • Do some hardware setup, connect some wires
  • Access the administrative interface to configure the device
  • Configure devices on all sides of our box
  • Run test
  • Check results

11.2. Hardware setup

We cannot yet fully automate this part.

11.3. Access the administrative interface

·         CLI - Command Line Interface (telnet)
·         SNMP
·         Web server with web GUI
·         Proprietary protocol with a Java Applet loaded from the box
·         Propriatery protocol with some locally installed GUI

11.4. Configure devices on all sides of our box

·         Traffic generators (e.g. SmartBits can be configured using Tcl,
·         Web/ftp/... servers
·         Use Telnet/SSH

11.5. Run tests

Still requires the same telnet connection to the various elements in your test setup.

11.6. Check results
  • Parse log files
  • Compute throughput
  • Compare files copied


11.7. Expect.pm

As we saw earlier Expect.pm with some low level networking protocol can be used to
access any device that can be connected via some cable.

Or without a cable.

But you might not want to implement the whole protocol, or you might not
have a command line tool that can access the device remotely.
Or you don't want to use it as you'd like to test that separately.


You can use the built-in telnet/ssh/ftp/tftp clinets in your Unix/Linux machine.

11.9. Networking

·         Net::*
·         Net::Telnet
·         Net::FTP
·         Net::SSH::Perl
·         Net::SNMP
·         SNMP::*
·         TFTP
·         IO::* low level I/O modules

11.10. Network devices

·         Cisco::*
·         Net::Telnet::Cisco

11.11. Devices connected to Serial or Parallel port

·         Device::*
·         Device::SerialPort
·         Win32::SerialPort
·         Device::Modem
·         Device::Gsm
·         Device::ParallelPort

11.12. X10 protocol

·         ControlX10::CM11 (AC power line)
·         ControlX10::CM17 Firecracker (RF)

Chapter 12. Web Applications

12.1. What can be tested ?

·         Fetching pages
·         Check if the HTML is correct
·         Check if elements of a page are in place
·         Follow links
·         Fill in forms and check if the results are correct
·         White box: Check if the changes also took place in the backend, in the database.

12.1. What can be tested ?

·         Fetching pages
·         Check if the HTML is correct
·         Check if elements of a page are in place
·         Follow links
·         Fill in forms and check if the results are correct
·         White box: Check if the changes also took place in the backend, in the database.

12.2. Tools

·         LWP (libwww-perl) and LWP::Simple http://search.cpan.org/dist/libwww-perl/
·         WWW::Mechanize - based on the LWP library http://search.cpan.org/dist/WWW-Mechanize/
·         Test::WWW::Mechanize http://search.cpan.org/dist/Test-WWW-Mechanize/
·         HTML::Lint http://search.cpan.org/dist/HTML-Lint/
·         Test::HTML::Lint http://search.cpan.org/dist/Test-HTML-Lint/
·         Test::HTML::Tidy http://search.cpan.org/dist/Test-HTML-Tidy/

12.3. Small test HTTP server

We are using a small portable HTTP server built using HTTP::Daemon
which is part of libwww-perl for the examples.

You can also run it by typing

$ perl examples/www/server/server.pl

or type the following to get help

$ perl examples/www/server/server.pl --help

12.4. Fetching a static page

Example 12-1. examples/www/static.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 1;
use LWP::Simple qw(get);
 
my $home = get 'http://test_server/';
ok $home, 'There is a response';
Fetch a page and check if there is response at all.
$ perl static.t          
ok 1 - There is a response
1..1

12.5. Fetching a not-existing static page

Example 12-2. examples/www/static_bad.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 1;
use LWP::Simple;
 
my $home = get 'http://test_server:8080/xx';
ok $home, 'There is a response';
Fetch a page and check if there is response.
$ perl static_bad.t 
not ok 1 - There is a response
#     Failed test (static_bad.t at line 10)
1..1
# Looks like you failed 1 tests of 1.

12.6. Checking good HTML

Example 12-3. examples/www/static_lint.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 2;
use Test::HTML::Lint;
use LWP::Simple qw(get);
 
 
my $home = get 'http://test_server/';
ok $home, 'There is a response';
html_ok $home, 'HTML OK';
HTML::Lint
Test::HTML::Lint
$ perl static_lint.t 
ok 1 - There is a response
ok 2 - HTML OK
1..2

12.7. Checking bad HTML

Example 12-4. examples/www/static_lint_bad.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 2;
use Test::HTML::Lint;
use LWP::Simple qw(get);
 
my $html = get 'http://test_server/bad.html';
ok $html, 'There is a response';
html_ok $html, 'HTML OK';
$ perl static_lint_bad.t 
not ok 1
#     Failed test (static_lint_bad.t at line 10)
# Errors:
#  (3:13) </a> with no opening <a>
#  (8:1) <h1> at (3:1) is never closed
1..1
# Looks like you failed 1 tests of 1.

12.8. What is this bad HTML ?

Example 12-5. examples/www/server/html/bad.html
<html>
<body>
<h1>Bad HTML</a>
<p>
In the above line there is a typo
</p>
<a href=http://www.perl.org.il>link without alt tag and quotes</a>
</body>
</html>
12.9. HTML::Tidy and Test::HTML::Tidy
Example 12-6. examples/www/static_tidy.t
#!/usr/bin/perl
use strict;
use warnings;

use Test::More tests => 2;
use Test::HTML::Tidy;
use LWP::Simple qw(get);


my $home = get 'http://test_server/';
ok $home, 'There is a response';
html_tidy_ok $home, 'HTML OK';
$ perl examples/www/static_tidy.t
1..2
ok 1 - There is a response
not ok 2 - HTML OK
#   Failed test 'HTML OK'
#   in examples/www/static_tidy.t at line 11.
# Messages: HTML OK
# examples/www/static_tidy.t (1:1) Warning: missing <!DOCTYPE> declaration
# Looks like you failed 1 test of 2.

12.10. Test using W3C validator

http://validate.w3c.org/

- Module to access that web site.
- Module to access the same service installed on a local web server.
- Module to access the validating code without a web server.

12.11. LWP::Simple and LWP

LWP::Simple is, well, simple.

LWP on the other hand enables you to do a lot of things
·         Setting the User Agent
·         Support for cookies
·         Authentication
·         Proxy Servers
·         Parse HTML
·         Write robots
But is it not simple.

12.12. WWW::Mechanize

Is simple, and very powerful

12.13. Web based Calculator

Example 12-7. examples/www/web_calc.t
#!/usr/bin/perl
use strict;
use warnings;
 
use Test::More tests => 14;
use WWW::Mechanize;
use Test::HTML::Tidy;
 
my $SERVER = 'http://test_server:8080';
 
my $url  = "$SERVER/calculator.html";
my $mech = WWW::Mechanize->new;
$mech->get($url);
is   $mech->status, 200, 'main page fetched';
like $mech->content, qr{Calculator}, 'start page ok';
 
html_tidy_ok $mech->content, "html is tidy";
 
my @forms = $mech->forms;
is @forms, 1, 'there is one form on this page';
 
 
 
# Shall we check if all the parts of the form are there? 
is $forms[0]->action, "$SERVER/cgi/cgi_sum.pl", "action URL is correct";
my @inputs = $forms[0]->inputs;
is @inputs, 3, "there are 3 input fields on this form";
{
    my $a = $forms[0]->find_input('a');
    isa_ok $a, 'HTML::Form::TextInput';
 
    my $b = $forms[0]->find_input('b');
    isa_ok $b, 'HTML::Form::TextInput';
 
    my $s = $forms[0]->find_input('submit');
    isa_ok $s, 'HTML::Form::SubmitInput';
}
 
# Shall we check the name of the form ?
 
 
$mech->submit_form(
    fields => {
       a => 23,
       b => 19,
    },
);
like $mech->content, qr{<h1 align="center">42</h1>}, 'get 42';
 
html_tidy_ok $mech->content, "result html is tidy";
$mech->back;
 
my @comps = (
   [23, 19, 42],
   [1,   2,  3],
   [1,   -1, 2],
);
 
foreach my $c (@comps) {
   $mech->submit_form(
      fields => {
       a => $c->[0],
       b => $c->[1],
      },
   );
   like $mech->content, 
        qr{<h1 align="center">$c->[2]</h1>},
        "$c->[0]+$c->[1]=$c->[2]";
 
   $mech->back;
}

12.14. More things to test

- Check if you can assess restricted pages without logging in
- or after logging out or after timeout expired
- loging, check good/bad passwords
- Upon unsuccessful login, see if the return page does NOT contain the
  password

12.15. Test page with JavaScript

- No single JavaScript engine, certainly there won't be those used in versions
  of IE
- There are several Open Source implementations
- Test only the data as it was sent
- Use a real browser (e.g. driven by Win32::IE::Mechanize)

Chapter 13. Database access using Perl DBI

13.1. Architecture of a DBI Application

 
             |<- Scope of DBI ->|
                  .-.   .--------------.   .-------------.
  .-------.       | |---| XYZ Driver   |---| XYZ Engine  |
  | Perl  |       | |   `--------------'   `-------------'
  | script|  |A|  |D|   .--------------.   .-------------.
  | using |--|P|--|B|---|Oracle Driver |---|Oracle Engine|
  | DBI   |  |I|  |I|   `--------------'   `-------------'
  | API   |       | |...
  |methods|       | |... Other drivers
  `-------'       | |...
                  `-'
 
 
Taken from the DBI documentation.
Any number of databases at the same time
Probably every RDBMS has its own DBD
And even things like CSV files, Sprite and Google
13.2. Create Sample Database
Run examples/dbi/create_sample.pl
in order to create the sample database

13.3. Connect to database

Example 13-1. examples/dbi/connect.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use DBI;
 
my $dbfile = "sample.db";
 
my $dsn = "dbi:SQLite:dbname=$dbfile";
my $dbh = DBI->connect($dsn);
 
 
Connecting to other databases:

my $dsn = "DBI:mysql:database=$database;host=$hostname;port=$port";
my $dbh = DBI->connect($dsn, $user, $password);

13.4. SELECT with one result

Example 13-2. examples/dbi/select.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use DBI;
 
my $dbfile = "sample.db";
 
my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile");
 
 
my $sth = $dbh->prepare('SELECT COUNT(*) FROM users');
$sth->execute;
 
my ($count) = $sth->fetchrow_array();
 
print "There are $count number of rows.\n";

13.5. SELECT with more results

Example 13-3. examples/dbi/select_name.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use DBI;
 
my $dbfile = "sample.db";
 
my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile");
 
 
my $sth = $dbh->prepare('SELECT fname, lname FROM users');
$sth->execute;
 
while (my @row = $sth->fetchrow_array()) {
    print "$row[0] $row[1]\n";
}
13.6. SELECT, prepare with placeholders
Example 13-4. examples/dbi/select_with_placeholders.pl
#!/usr/bin/perl
use strict;
use warnings;

use DBI;

my $dbfile = "sample.db";

my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile");

my $sth = $dbh->prepare('SELECT fname, lname FROM users WHERE id <= ?');
$sth->execute(1);

while (my @row = $sth->fetchrow_array()) {
    print "$row[0] $row[1]\n";
}

13.7. SELECT, using hashref

Example 13-5. examples/dbi/select_hashref.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use DBI;
 
my $dbfile = "sample.db";
 
my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile");
 
my $sth = $dbh->prepare('SELECT fname, lname FROM users WHERE id <= ?');
$sth->execute(1);
 
while (my $h = $sth->fetchrow_hashref('NAME_lc')) {
    print "$h->{fname}  $h->{lname}\n";
}

13.8. INSERT

Example 13-6. examples/dbi/insert.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use DBI;
 
my $dbfile = "sample.db";
 
my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile");
 
my ($fname, $lname, $email, $pw) = qw(Moose Foobar moose@foobar.com really?);
 
 
$dbh->do('INSERT INTO users (fname, lname, email, pw) VALUES (?, ?, ?, ?)',
            undef, 
            $fname, $lname, $email, $pw);
We might need to insert some data when preparing a test case.

13.9. Sample database

Example 13-7. examples/dbi/create_sample.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use DBI;
 
my $dbfile = "sample.db";
 
unlink $dbfile;
 
my $dbh = DBI->connect("dbi:SQLite:dbname=sample.db");
 
my $schema;
{
    open my $fh, '<', 'examples/dbi/sample.sql' or die;
    local $/ = undef;
    $schema = <$fh>;
}
foreach my $sql (split /;/, $schema) {
    next if $sql !~ /\S/; # skip empty entries
    $dbh->do($sql);
}
$dbh->disconnect;
 
Example 13-8. examples/dbi/sample.sql
CREATE TABLE users (
    id    INTEGER PRIMARY KEY,
    fname VARCHAR(100), 
    lname VARCHAR(100), 
    email VARCHAR(100) UNIQUE NOT NULL,
    pw    VARCHAR(20) NOT NULL
);
 
INSERT INTO users (fname, lname, email, pw)
        VALUES    ('Foo', 'Bar', 'foo@bar.com', 'secret');
INSERT INTO users (fname, lname, email, pw) 
        VALUES    ('Peti', 'Bar', 'peti@bar.com', 'real secret');

13.10. Other methods

Transactions:
  begin_work
  commit
  rollback

disconnect

13.11. Attributes

my $dsn = "dbi:SQLite:dbname=$dbfile";
my $dbh = DBI->connect($dsn, $username, $password, \%attributes);

PrintError  => 1
RaiseError  => 1
AutoCommit  => 1
FetchHashKeyName => NAME_lc   NAME_uc

TraceLevel  (see Debugging and Trace levels later)

13.12. Error handling

- Set the attributes PrintError and RaiseError
- Check for returned undef (or empty lists)
- Check $h->err   and $h->errstr
  (aka. $DBI::err and $DBI::errstr)

  err    - Native DB engine error code
  errstr - Native DB engine error string

$sth = $dbh->prepare($statement)   or die $dbh->errstr;
$rv  = $sth->execute(@bind_values) or die $sth->errstr;

fetchrow_array (and others) return undef when no more row or if
they encounter an error. Use RaiseError or check $sth->err
13.13. Debugging (Trace levels)

$dbh->trace()
$sth->trace()
DBI->trace()
TraceLevel attribute

Can be used like this:

DBI->trace(1);
DBI->trace(1, '/tmp/dbitrace.log');

The trace level can be 0 (off) .. 15 (usually 1-4 is more than enough)

In CGI scripts add the following:
BEGIN { $ENV{DBI_TRACE}='1=/tmp/dbitrace.log'; }

Chapter 14. Database access using Class::DBI

14.1. Class::DBI

Use SQL Database without writing SQL

14.2. INSERT using Class::DBI

Example 14-1. examples/cdbi/insert.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use MyUsers;
 
my $u = MyUsers->create({
        fname => 'Morgo', 
        email => 'morgo@torpek.hu',
        pw    => 'hapci',
});

14.3. SELECT using Class::DBI

Example 14-2. examples/cdbi/select.pl
#!/usr/bin/perl
use strict;
use warnings;
 
use MyUsers;
 
my @users = MyUsers->search(fname => 'Morgo');
foreach my $user (@users) {
               print $user->email,"\n";
}
14.4. MyDBI and MyUsers
Example 14-3. examples/cdbi/MyDBI.pm
package MyDBI;
use base 'Class::DBI';
MyDBI->set_db('Main', 'dbi:SQLite:dbname=site.db');


1;
Example 14-4. examples/cdbi/MyUsers.pm
package MyUsers;
use base 'MyDBI';
MyUsers->table('users');
MyUsers->columns(All => qw/fname lname email pw/);

1;


Posted by at

No comments:

Post a Comment

Subscribe to: Post Comments (Atom)