├── .gitignore ├── 01_intro.odp ├── 01_intro └── hello.pl ├── 01_intro_bg.odp ├── 02_scalar_data_types.odp ├── 02_scalar_data_types ├── 02_defined.pl ├── 02_numeric_abs.pl ├── 02_numeric_hex.pl ├── 02_numeric_oct.pl ├── 02_ref.pl ├── 02_scalar_data_types_01.pl ├── 02_scalar_data_types_02.pl ├── 02_scalar_data_types_03.pl ├── 02_string_chomp.pl ├── 02_string_chop.pl ├── 02_string_length.pl ├── 02_string_uc_lc.pl └── 02_undef.pl ├── 02_scalar_data_types_bg.odp ├── 03_list_and_arrays.odp ├── 03_list_and_arrays ├── 03_list_and_arrays_foreach.pl ├── 03_list_and_arrays_grep.pl ├── 03_list_and_arrays_interpolate.pl ├── 03_list_and_arrays_join.pl ├── 03_list_and_arrays_map.pl ├── 03_list_and_arrays_pop.pl ├── 03_list_and_arrays_push.pl ├── 03_list_and_arrays_qw.pl ├── 03_list_and_arrays_range.pl ├── 03_list_and_arrays_shift.pl ├── 03_list_and_arrays_splice.pl ├── 03_list_and_arrays_unshift.pl └── 03_list_and_arrays_vars.pl ├── 03_list_and_arrays_bg.odp ├── 04_hashes.odp ├── 04_hashes ├── 04_hash_defined.pl ├── 04_hash_delete.pl ├── 04_hash_each.pl ├── 04_hash_exists.pl ├── 04_hash_keys.pl ├── 04_hash_representation.pl └── 04_hash_values.pl ├── 04_hashes_bg.odp ├── 05_syntax.odp ├── 05_syntax ├── 05_syntax_and.pl ├── 05_syntax_auto_inc.pl ├── 05_syntax_comments.pl ├── 05_syntax_compound.pl ├── 05_syntax_compound_continue.pl ├── 05_syntax_compound_labels.pl ├── 05_syntax_conditional.pl ├── 05_syntax_conditional_sfx.pl ├── 05_syntax_continue.pl ├── 05_syntax_errors.pl ├── 05_syntax_for.pl ├── 05_syntax_foreach.pl ├── 05_syntax_last.pl ├── 05_syntax_local.pl ├── 05_syntax_my.pl ├── 05_syntax_next.pl ├── 05_syntax_not.pl ├── 05_syntax_or.pl ├── 05_syntax_our.pl ├── 05_syntax_redo.pl ├── 05_syntax_simple.pl ├── 05_syntax_sub.pl ├── 05_syntax_ternary.pl ├── 05_syntax_while.pl └── declarations.pl ├── 05_syntax_bg.odp ├── 06_io.odp ├── 06_io ├── calc.pl ├── cp.pl ├── crud.pl ├── directories.pl ├── errors.txt ├── file.txt ├── filetests.txt ├── line_input.pl ├── line_input2.pl ├── open.pl ├── perlio.pl ├── readwrite.pl ├── readwrite2.pl ├── readwrite3.pl ├── stdout.pl ├── sum.pl └── test.txt ├── 06_io_bg.odp ├── 07_subroutines.odp ├── 07_subs ├── caller.pl ├── caller2.pl ├── local.pl ├── my.pl ├── our.pl ├── return.pl ├── state.pl ├── sub.pl ├── sub_args.pl └── wantarray.pl ├── 08_references.odp ├── 08_refs ├── interpolation.pl ├── test.txt └── using.pl ├── 09_regex.odp ├── 09_regex ├── alternation.pl ├── ch_classess.pl ├── ch_classess2.pl ├── extracting.pl ├── grouping.pl ├── repetitions.pl ├── simple.pl ├── simple2.pl ├── simple3.pl ├── simple4.pl ├── simple5.pl └── simple6.pl ├── 10_oop.odp ├── 10_oop ├── Examle-Class │ ├── Build.PL │ ├── Changes │ ├── MANIFEST │ ├── README │ ├── ignore.txt │ ├── lib │ │ └── Examle │ │ │ └── Class.pm │ └── t │ │ ├── 00-load.t │ │ ├── boilerplate.t │ │ ├── manifest.t │ │ ├── pod-coverage.t │ │ └── pod.t ├── bless.pl ├── ref.pl ├── require.pl ├── tie.pl ├── tied.pl ├── use.pl └── using_modules.pl ├── 11_dbi.odp ├── 12_p_and_t ├── creating_threads.pl ├── deadlock.pl ├── io-socket-server-threaded.pl ├── io-socket-tcp-server-fork.pl ├── lock.pl ├── pipes.pl ├── queues.pl ├── race_conditions.pl ├── semaphores.pl ├── sharing_data.pl ├── threads_management.pl ├── threads_management2.pl └── threads_management3.pl ├── 12_processes_and_threads.odp ├── 13_net.odp ├── 13_net ├── MyMech.pm ├── io-socket-tcp-client.pl ├── io-socket-tcp-server-nofork.pl ├── io-socket-tcp-server.pl ├── io-socket-udp-client.pl ├── io-socket-udp-server.pl ├── io-socket-uds-client.pl ├── io-socket-uds-server.pl ├── smtp.pl ├── socket-tcp-client.pl ├── socket-tcp-server.pl └── www_mech.pl ├── 14_sysadmin.odp ├── 14_sysadmin ├── filesed.txt ├── original.txt └── sed.pl ├── Linus ├── Linus~ ├── README.md ├── img ├── 180px-Multithreaded_process.svg.png ├── btv.png ├── cgi-ex-recipes.png ├── com-process.gif ├── com-thread.gif └── using_ppm.png └── lib └── Data └── Table.pm /.gitignore: -------------------------------------------------------------------------------- 1 | blib/ 2 | .build/ 3 | _build/ 4 | cover_db/ 5 | inc/ 6 | Build 7 | Build.bat 8 | .last_cover_stats 9 | Makefile 10 | Makefile.old 11 | MANIFEST.bak 12 | META.yml 13 | MYMETA.yml 14 | nytprof.out 15 | pm_to_blib 16 | -------------------------------------------------------------------------------- /01_intro.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/01_intro.odp -------------------------------------------------------------------------------- /01_intro/hello.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use warnings; 3 | use strict; 4 | use utf8; 5 | print 'Hi'.$/; -------------------------------------------------------------------------------- /01_intro_bg.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/01_intro_bg.odp -------------------------------------------------------------------------------- /02_scalar_data_types.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/02_scalar_data_types.odp -------------------------------------------------------------------------------- /02_scalar_data_types/02_defined.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | #use diagnostics; 3 | $\ = $/; 4 | my $data; 5 | print $data if defined($data); 6 | $data = 0; 7 | print defined($data); 8 | print $data if defined($data); 9 | undef $data; 10 | print defined($data); 11 | $_ = 2; 12 | print defined; -------------------------------------------------------------------------------- /02_scalar_data_types/02_numeric_abs.pl: -------------------------------------------------------------------------------- 1 | #abs 2 | my $answer = -22; 3 | print abs $answer; 4 | print abs "$answer"; -------------------------------------------------------------------------------- /02_scalar_data_types/02_numeric_hex.pl: -------------------------------------------------------------------------------- 1 | #hex 2 | print(hex '0xBf', $/); 3 | print(hex 'bF', $/); -------------------------------------------------------------------------------- /02_scalar_data_types/02_numeric_oct.pl: -------------------------------------------------------------------------------- 1 | #oct 2 | print( oct 0b10, $/); 3 | print( oct '0xBf', $/); 4 | print( oct '07', $/); 5 | print( oct '0777', $/); -------------------------------------------------------------------------------- /02_scalar_data_types/02_ref.pl: -------------------------------------------------------------------------------- 1 | use Data::Dumper; 2 | my %hash = (me =>'you' ); 3 | my @array = ('we',\%hash,['them']); 4 | my $scalar = \@array; 5 | print ref $scalar, $/; 6 | print $scalar,$/; 7 | print Dumper($scalar); -------------------------------------------------------------------------------- /02_scalar_data_types/02_scalar_data_types_01.pl: -------------------------------------------------------------------------------- 1 | #Perl Scalars 2 | use strict; use warnings; 3 | my $animal = "camel"; 4 | my $answer = 22; 5 | print "Me: Hello $animal! How old are you?\n"; 6 | print "$animal: $answer.$/"; 7 | print '-'x 20, $/; 8 | print 'Named reference: ',${animal},$/; 9 | $Other::animal = 'llama'; 10 | print "From package 'Other': $Other::animal\n"; 11 | print 'Perl version: ',$], $/; -------------------------------------------------------------------------------- /02_scalar_data_types/02_scalar_data_types_02.pl: -------------------------------------------------------------------------------- 1 | my @animals = ("camel", "llama", "пиле"); 2 | my @numbers = (23, 42, 69); 3 | my @mixed = ("camel", 42, 1.23); 4 | print @animals .$/;#what the...;) scalar context 5 | print "@animals" . $/;#interpolated array 6 | print "@animals @numbers" . $/;#interpolated arrays 7 | print @animals, @numbers, $/;#list context -------------------------------------------------------------------------------- /02_scalar_data_types/02_scalar_data_types_03.pl: -------------------------------------------------------------------------------- 1 | #Perl Hashes 2 | my %fruit_colors = ( 3 | apple => "red", 4 | banana => "yellow", 5 | ); 6 | print 7 | map { "$_ => $fruit_colors{$_}\n" } 8 | sort 9 | keys %fruit_colors; 10 | print "%fruit_colors\n"; #hashes can NOT be interpolated -------------------------------------------------------------------------------- /02_scalar_data_types/02_string_chomp.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | #chomp 3 | #binmode(STDOUT, ':encoding(cp866)');#on win32 4 | use utf8; 5 | binmode(STDOUT, ':utf8'); 6 | my ($bob_latin, $bob_cyr) = ("bob\n", "боб$/"); 7 | print( $bob_latin, $bob_cyr, $/ ); 8 | print( chomp($bob_latin,$bob_cyr) , $/ ); 9 | print( $bob_latin, $bob_cyr, $/ ); -------------------------------------------------------------------------------- /02_scalar_data_types/02_string_chop.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -C 2 | #chop 3 | #binmode(STDOUT, ':encoding(cp866)');#on win32 4 | use utf8; 5 | binmode(STDOUT, ':utf8'); 6 | 7 | my ($bob_latin, $bob_cyr) = ('bob', 'боб'); 8 | print( chop($bob_latin) , $/, chop($bob_cyr) , $/); -------------------------------------------------------------------------------- /02_scalar_data_types/02_string_length.pl: -------------------------------------------------------------------------------- 1 | #length 2 | use utf8; 3 | 4 | print( length 'kniga' , $/); 5 | use bytes; 6 | print( length 'книга', $/); 7 | no bytes; 8 | print( length 'книга', $/); -------------------------------------------------------------------------------- /02_scalar_data_types/02_string_uc_lc.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -C 2 | #uc/lc 3 | #binmode(STDOUT, ':encoding(cp866)');#on win32 4 | use utf8; 5 | binmode(STDOUT, ':utf8'); 6 | my ($lcstr, $ucstr) = ("BOB\n", "боб$/"); 7 | print( lc $lcstr, uc($ucstr), $/ ); -------------------------------------------------------------------------------- /02_scalar_data_types/02_undef.pl: -------------------------------------------------------------------------------- 1 | #use strict; use warnings; use diagnostics; 2 | my $name; 3 | print $name ,$/; 4 | $name ="Larry"; 5 | print $name ,$/; 6 | undef $name ; 7 | print $name ,$/; -------------------------------------------------------------------------------- /02_scalar_data_types_bg.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/02_scalar_data_types_bg.odp -------------------------------------------------------------------------------- /03_list_and_arrays.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/03_list_and_arrays.odp -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_foreach.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | $\ =$/; 4 | my @fruits = qw ( apples oranges lemons pears ); 5 | foreach my $fruit (@fruits) { 6 | print "fruit is '$fruit'\n"; 7 | #try $_ also 8 | } -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_grep.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -C 2 | use utf8;use strict;use warnings; 3 | if( $^O =~ /Win32/ ){ 4 | binmode(STDOUT, ':encoding(cp866)'); 5 | } 6 | elsif( $ENV{LANG} =~ /UTF-8/ and $^O=~/linux/i ){ 7 | binmode(STDOUT, ':utf8'); 8 | } 9 | $, = ' ', $\ = $/; 10 | 11 | #Example starts here 12 | my @nums = (0x410 .. 0x44f); 13 | my @chars = grep( 14 | ($_ >= 0x410 and $_ < 0x430), @nums 15 | ); 16 | map($_ = chr, @chars);#modify inplace $_ 17 | print @chars; 18 | 19 | #grep for 'а' 20 | if( my $times = grep { chr($_) =~ /а/i } @nums ){ 21 | print "'а' codes found: 22 | $times times in the list." 23 | } 24 | -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_interpolate.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | $\ = $/; 4 | my @numbers = (1, 4.5, 15, 32 ); 5 | my @family = ('me', 'you', 'us'); 6 | 7 | print "Do $family[1] have $numbers[2] leva?"; 8 | print "Sorry, I do have $family[0] only."; 9 | $"=', '; 10 | print "O... @family... who cares!"; -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_join.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | $\ =$/; 4 | my @fields = qw ( id name position ); 5 | my $SQL = 'SELECT ' 6 | . join(", ", @fields) 7 | . ' from empoyees'; 8 | print $SQL; 9 | -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_map.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use utf8;use strict;use warnings; 3 | if( $^O =~ /Win32/ ){ 4 | binmode(STDOUT, ':encoding(cp866)'); 5 | } 6 | elsif( $ENV{LANG} =~ /UTF-8/ and $^O=~/linux/i ){ 7 | binmode(STDOUT, ':utf8'); 8 | } 9 | $, = ' ', $\ = $/; 10 | 11 | #Example starts here 12 | my @nums = (0x410 .. 0x44f); 13 | my @chars = map(chr , @nums); 14 | print @chars; 15 | 16 | print '-' x 20; 17 | my @names = qw(Цвети Пешо Иван); 18 | my @mapped = map {$_ if $_ eq 'Пешо'} @names; 19 | print @mapped; -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_pop.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Data::Dumper; $\ =$/; 4 | my @names = qw ( Цвети Бети Пешо ); 5 | my $last_name = pop(@names); 6 | print "popped = $last_name"; 7 | print Dumper \@names; -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_push.pl: -------------------------------------------------------------------------------- 1 | use Data::Dumper; 2 | $\ =$/; 3 | my @family = qw ( me you us ); 4 | print scalar @family;#get the number of elements 5 | print push(@family, qw ( him her )); 6 | print Dumper \@family; 7 | -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_qw.pl: -------------------------------------------------------------------------------- 1 | $\=$/; #$OUTPUT_RECORD_SEPARATOR is set to "\n" 2 | $,=$/; #$OUTPUT_FIELD_SEPARATOR is set to "\n" 3 | print qw (me you us); 4 | print ('me', 'you', 'us');# the same as above 5 | $me = qw (me you us); 6 | print $me; # prints 'us' -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_range.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use utf8; use strict; use warnings; 3 | use utf8;use strict;use warnings; 4 | if( $^O =~ /Win32/ ){ 5 | binmode(STDOUT, ':encoding(cp866)'); 6 | } 7 | elsif( $ENV{LANG} =~ /UTF-8/ and $^O=~/linux/i ){ 8 | binmode(STDOUT, ':utf8'); 9 | } 10 | $, = $\ = $/; 11 | 12 | #Example starts here 13 | 14 | my @nums = (0x410 .. 0x44f); 15 | print chr($nums[$_]) foreach(0..14); 16 | #print a slice 17 | print @nums[0..14],$/; 18 | #print a character map table from slice 19 | print ' dec | hex | char', '-' x 19; 20 | print map { 21 | $_.' | ' 22 | . sprintf('0x%x',$_).' | '.chr($_) 23 | . "\n" . '-' x 19 24 | } @nums[0..14]; 25 | -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_shift.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Data::Dumper; 4 | $\ =$/; 5 | my @names = qw ( Цвети Бети Пешо ); 6 | my $last_name = shift(@names); 7 | warn "shifted = $last_name"; 8 | print Dumper \@names; -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_splice.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | $\ =$/; 4 | my @words = qw ( Is there any body ? ); 5 | splice(@words, 4, 0, 'out','there'); 6 | # | | |______| 7 | # |__|___|_start from index 8 | # |___|__how many to remove 9 | # |____what to place there 10 | print join(" ", @words); 11 | 12 | splice(@words, 4, 1 ); 13 | # | | |______| 14 | # |__|___|_start from index 15 | # |___|__how many to remove 16 | # |____what to place there 17 | print join(" ", @words); -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_unshift.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Data::Dumper; 4 | $\ =$/; 5 | my @names = qw ( Цвети Бети Пешо ); 6 | print 'elements:', scalar @names; 7 | print 'elements:', unshift(@names,qw/Део Иво/); 8 | print Dumper \@names; -------------------------------------------------------------------------------- /03_list_and_arrays/03_list_and_arrays_vars.pl: -------------------------------------------------------------------------------- 1 | #$, = $\ =$/; 2 | my @numbers = (1, 4.5, 15, 32 ); 3 | my @family = ('me', 'you', 'us'); 4 | print '@family:', @family,$/; 5 | $family[3] = 'he'; 6 | print '@family:', @family,$/; 7 | my @things = (@numbers, @family);#flattened 8 | printf @things; 9 | print '-----------------'; 10 | my @predators = qw/leopard tiger panther/; 11 | my @slices = (1..3, A..D); 12 | print $/; 13 | print @numbers,@family,@things,@slices,@predators; -------------------------------------------------------------------------------- /03_list_and_arrays_bg.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/03_list_and_arrays_bg.odp -------------------------------------------------------------------------------- /04_hashes.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/04_hashes.odp -------------------------------------------------------------------------------- /04_hashes/04_hash_defined.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Data::Dumper; 4 | $\ =$/; 5 | my %f_colors = ('apple', 'red', 'banana', 'yellow'); 6 | my @f_colors = %f_colors; 7 | 8 | defined $f_colors[0] 9 | and print $f_colors[0] .' defined'; 10 | 11 | defined $f_colors{'apple'} and 12 | print ' and is '.$f_colors{'apple'}; 13 | 14 | print 'Opss..'.$f_colors[0].' is '.$f_colors{$f_colors[0]}; 15 | 16 | defined $f_colors{'pear'} 17 | and print ' and is '. $f_colors{'pear'} 18 | or print ' wow ...'.Dumper(\%f_colors); 19 | -------------------------------------------------------------------------------- /04_hashes/04_hash_delete.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Data::Dumper; $, = ' | ';$\ =$/; 4 | my %f_colors = ('apple', 'red', 'banana', 'yellow'); 5 | my @f_colors = %f_colors; 6 | push @f_colors,('pear','yellow'); 7 | %f_colors = @f_colors; 8 | print Dumper \@f_colors; 9 | print Dumper \%f_colors; 10 | print delete $f_colors[-1]; 11 | print delete @f_colors{qw(apple banana)}; 12 | print 'after delete:'; 13 | print Dumper \%f_colors; 14 | print Dumper \@f_colors; 15 | -------------------------------------------------------------------------------- /04_hashes/04_hash_each.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | while ( my ($key,$value) = each %ENV ) { 4 | print "$key => $value\n"; 5 | } -------------------------------------------------------------------------------- /04_hashes/04_hash_exists.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | my %f_colors = ('apple', 'red', 'banana', 'yellow'); 4 | my @f_colors = %f_colors; 5 | exists $f_colors[0] and 6 | print $f_colors[0] .' exists'; 7 | exists $f_colors{'apple'} and 8 | print ' and is '.$f_colors{'apple'}; 9 | print 'Ops..'.$f_colors[0].' is '.$f_colors{$f_colors[0]}; -------------------------------------------------------------------------------- /04_hashes/04_hash_keys.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | #sorted by key 4 | foreach my $key (sort(keys %ENV)) { 5 | print $key, ' => ', $ENV{$key}, "\n"; 6 | } -------------------------------------------------------------------------------- /04_hashes/04_hash_representation.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Data::Dumper; $\ =$/; 4 | my %fruit_colors = ('apple', 'red', 'banana', 'yellow'); 5 | print Dumper(\%fruit_colors); 6 | my @fruit_colors = %fruit_colors; 7 | print Dumper(\@fruit_colors); 8 | %fruit_colors = @fruit_colors; 9 | $fruit_colors{pear} = 'yellow';#add a key/value pair 10 | print Dumper(\%fruit_colors); -------------------------------------------------------------------------------- /04_hashes/04_hash_values.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | #sorted by value 4 | foreach my $value (sort(values %ENV)) { 5 | print $value, "\n"; 6 | } -------------------------------------------------------------------------------- /04_hashes_bg.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/04_hashes_bg.odp -------------------------------------------------------------------------------- /05_syntax.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/05_syntax.odp -------------------------------------------------------------------------------- /05_syntax/05_syntax_and.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/;$|++; 2 | my ($me,$you) = qw(me you); 3 | print 'We are here:'.($me && $you) if ($me && $you); 4 | print 'We are here:'.($me and $you) if ($me and $you); 5 | undef $me; 6 | print 'We are here:' if ($me and $you) or die 'Someone'; -------------------------------------------------------------------------------- /05_syntax/05_syntax_auto_inc.pl: -------------------------------------------------------------------------------- 1 | use strict;use warnings; $\ = $/; 2 | print -2**4;#-16 3 | my $a = 2; 4 | print $a++; 5 | print ++$a; 6 | print $a--; 7 | print --$a; -------------------------------------------------------------------------------- /05_syntax/05_syntax_comments.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | $\ = $/; 3 | my $simple = 'A simple statement.#not a comment.'; 4 | print $simple;#this is a comment 5 | $simple =~ s#a##ig; 6 | print $simple; 7 | $simple =~ s/#//ig; 8 | print $simple; 9 | =pod 10 | I like to use POD for multiline comments 11 | but it is much more than that. 12 | =cut 13 | print $0 . ' finished.'; -------------------------------------------------------------------------------- /05_syntax/05_syntax_compound.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | 3 | unless( open(FH,$0)){ 4 | die 'I do not exist on disk!'. $^E 5 | } 6 | else { 7 | local $\ = undef;#slurp mode 8 | my $c=1; 9 | print "$0: ", sprintf('%02d',$c++), " $_" while ; 10 | } 11 | print $/.'---'; 12 | my $hashref = {me=>1,you=>2,he=>3}; 13 | exists $hashref->{she} 14 | and print 'she: '.$hashref->{she} 15 | or print 'she does not exists.' 16 | and print sort values %$hashref; 17 | -------------------------------------------------------------------------------- /05_syntax/05_syntax_compound_continue.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | my $c = 0; 3 | while ($c <= 10){ 4 | print $c; 5 | } 6 | continue { 7 | $c++; 8 | print $c - 1 . ' incremented by 1:'; 9 | }; -------------------------------------------------------------------------------- /05_syntax/05_syntax_compound_labels.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | print 'LABELS:'; 3 | A_LABEL: for my $m (1..10){ 4 | ANOTHER: for my $s(0..10) { 5 | last A_LABEL if $m > 4;#comment and try it again 6 | last if $s > 4 and print '---'; 7 | print sprintf('%1$02d.%2$02d',$m,$s) ; 8 | } 9 | 10 | } -------------------------------------------------------------------------------- /05_syntax/05_syntax_conditional.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | unless( open(FH,$0)){ 3 | die 'I do not exist on disk!'. $^E 4 | } 5 | else { 6 | local $\ ; 7 | my $c=1; 8 | print "$0: ", sprintf('%02d',$c++), " $_" while ; 9 | } 10 | print $/.'---'; #$,=$/; 11 | my $hashref = {me=>1,you=>2,he=>3}; 12 | 13 | if ( exists $hashref->{she} ) { 14 | print 'she:'.$hashref->{she}; 15 | } 16 | else { 17 | print 'she does not exists.'; 18 | print sort values %$hashref; 19 | } 20 | ### -------------------------------------------------------------------------------- /05_syntax/05_syntax_conditional_sfx.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | { 3 | my $c=1; 4 | local $\ = undef; 5 | do { 6 | print "$0: ", sprintf('%02d',$c++), " $_" 7 | while 8 | } if open(FH,$0) or die 'I do not exist on disk!'. $^E; 9 | } 10 | print $/.'---'; 11 | my $hashref = {me=>1,you=>2,he=>3}; 12 | print 'she:'.$hashref->{she} if ( exists $hashref->{she} ); 13 | do { 14 | print 'she does not exists.'; 15 | print sort values %$hashref; 16 | } unless exists $hashref->{she}; 17 | ### -------------------------------------------------------------------------------- /05_syntax/05_syntax_continue.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | my ($c,$reached_10) = (1,); 3 | while ($c) { 4 | print '- ' x $c, $c; 5 | } continue { 6 | last if ($c == 1 and $reached_10); 7 | $c-- if $reached_10; 8 | $c++ if $c < 10 and not $reached_10; 9 | $reached_10++ if $c == 10; 10 | } 11 | -------------------------------------------------------------------------------- /05_syntax/05_syntax_errors.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;$|++; 2 | warn 'Default variable is undefined' unless $_; 3 | eval ' a syntax error or any failure'; 4 | if($@){ 5 | warn 'You spoiled everything'; 6 | } 7 | 8 | #... 9 | use Carp qw(cluck croak confess); 10 | other_place(); 11 | 12 | croak "We're outta here!"; 13 | 14 | sub here { 15 | $ARGV[0] ||= 'try'; 16 | if ($ARGV[0] =~ /try/){ 17 | cluck "\nThis is how we got here!" 18 | } 19 | elsif ($ARGV[0] =~ /die/){ 20 | confess "\nNothing to live for!"; 21 | } 22 | } 23 | sub there { here; } 24 | sub other_place { there } -------------------------------------------------------------------------------- /05_syntax/05_syntax_for.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | 3 | for (my $i = 1; $i < 10; $i++) { 4 | print sprintf('%02d',$i); 5 | } 6 | 7 | #print sprintf('%02d',$i); 8 | #Global symbol "$i" requires... 9 | 10 | print '---'; 11 | my $i = 1; 12 | while ($i < 10) { 13 | print sprintf('%02d',$i); 14 | } continue { 15 | $i++; 16 | } 17 | print sprintf('%02d',$i); -------------------------------------------------------------------------------- /05_syntax/05_syntax_foreach.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $, = $/; 2 | my @pets = qw|Goldy Amelia Jako|; 3 | my $favorite = 'Puffy';; 4 | foreach $favorite(@pets) { 5 | print 'My favourite pet is:' . $favorite; 6 | } 7 | print '---', 8 | 'My favourite pet is:' . $favorite, 9 | '---'; 10 | for $favorite(@pets) { 11 | print 'My favourite pet is:' . $favorite; 12 | } 13 | print '---', 14 | 'My favourite pet is:' . $favorite, 15 | '---'; 16 | unshift @pets,$favorite; 17 | for (@pets) { 18 | print 'My favourite pet is:' . $_; 19 | } 20 | print '---', 21 | 'My favourite pet is:' . $favorite, 22 | '---'; -------------------------------------------------------------------------------- /05_syntax/05_syntax_last.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $, = $/; 2 | my $c = 1; 3 | while (){ 4 | last unless /perl/; 5 | chomp and print "$c: $_"; 6 | $c++; 7 | } 8 | __DATA__ 9 | This section of a perl file 10 | can be used by the perl program 11 | above in the same file to store 12 | and use some textual data 13 | perl rocks!!! 14 | -------------------------------------------------------------------------------- /05_syntax/05_syntax_local.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | use English;#use nice English names for ugly punctuation variables 3 | 4 | { 5 | local $^O = 'Win32'; 6 | local $OUTPUT_RECORD_SEPARATOR = "\n-----\n";#$\ 7 | local $OUTPUT_FIELD_SEPARATOR = ': ';#$, 8 | print 'We run on', $OSNAME; 9 | 10 | open my $fh, $PROGRAM_NAME or die $OS_ERROR;#$0 $! 11 | local $INPUT_RECORD_SEPARATOR ; #$/ enable localized slurp mode 12 | my $content = <$fh>; 13 | close $fh; 14 | print $content; 15 | #my $^O = 'Solaris';#Can't use global $^O in "my"... 16 | } 17 | print 'We run on ', $OSNAME; -------------------------------------------------------------------------------- /05_syntax/05_syntax_my.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | $\ = $, = $/; 3 | my $dog = 'Puffy'; 4 | { 5 | my $dog = 'Betty'; 6 | print 'My dog is named ' . $dog; 7 | } 8 | print 'My dog is named ' . $dog; 9 | my ($fish, $cat, $parrot) = qw|Goldy Amelia Jako|; 10 | print $fish, $cat, $parrot; 11 | #print $lizard; 12 | #Global symbol "$lizard" requires explicit package name... -------------------------------------------------------------------------------- /05_syntax/05_syntax_next.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; $\ = $, = $/; 3 | my $c = 1; 4 | while (){ 5 | next unless /perl/; 6 | chomp and print "$c: $_"; 7 | $c++; 8 | } 9 | __DATA__ 10 | This section of a perl file 11 | can be used by the perl program 12 | above in the same file to store 13 | and use some textual data 14 | perl rocks!!! 15 | Will the above line print if we remove this one? -------------------------------------------------------------------------------- /05_syntax/05_syntax_not.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | use Config; 3 | print 'Do my perl uses old threads?'; 4 | print 'No' if !$Config{use5005threads}; 5 | print 'I do not have extras' if !$Config{extras}; 6 | print 'I do not have mail' if not $Config{mail}; 7 | -------------------------------------------------------------------------------- /05_syntax/05_syntax_or.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | $|++;# enable $OUTPUT_AUTOFLUSH 3 | my ($me,$you) = qw(me you); 4 | print 'Somebody is here:'.($me || $you) if ($me || $you); 5 | print 'Somebody is here:'.($me or $you) if ($me or $you); 6 | ($me,$you) = ('me', undef);#undef 'me' and try again 7 | print 'Somebody is here:'.($me or $you) 8 | if ($me or $you) or die 'Nooo..'; 9 | ($me,$you) = (undef, 'you'); 10 | print 'Somebody is here:'.($me or $you) 11 | if ($me or $you) or die 'no one'; -------------------------------------------------------------------------------- /05_syntax/05_syntax_our.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ =$/; 2 | { 3 | package GoodDogs; 4 | print 'We are in package ' . __PACKAGE__; 5 | our $dog = 'Puffy'; 6 | { 7 | print 'Our dog is named ' . $dog; 8 | my $dog = 'Betty'; 9 | print 'My dog is named ' . $dog; 10 | } 11 | print 'My dog is named ' . $dog; 12 | 13 | package BadDogs; 14 | print $/.'We are in package ' . __PACKAGE__; 15 | print 'Previous dog is named ' . $dog; 16 | print 'Your dog is named ' . $GoodDogs::dog; 17 | our $dog = 'Bobby'; 18 | print 'Our dog is named ' . $dog; 19 | } -------------------------------------------------------------------------------- /05_syntax/05_syntax_redo.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $, = $/; 2 | my ($c, $redone) = (1,0); 3 | while (){ 4 | chomp; print "$c: $_"; $c++; 5 | if (/perl/ and not $redone) { 6 | $redone++; 7 | redo; 8 | } 9 | elsif($_ =~ /perl/ and $redone) { 10 | $redone--; 11 | next; 12 | } 13 | 14 | } 15 | __DATA__ 16 | This section of a perl file 17 | can be used by the perl program 18 | above in the same file to store 19 | and use some textual data 20 | perl rocks!!! 21 | -------------------------------------------------------------------------------- /05_syntax/05_syntax_simple.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | $\ = $/; 4 | my $simple = 'A simple statement.'; 5 | print 1,$simple; 6 | eval { print 2,$simple }; 7 | do { print 3,$simple }; 8 | do { 9 | $_++; 10 | print 4,$simple ,' ',$_,'+2' 11 | }; -------------------------------------------------------------------------------- /05_syntax/05_syntax_sub.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | sub hope; 3 | sub syntax($) { 4 | print "This is 'Syntax' slide ". $_[0] ."\n"; 5 | } 6 | syntax $ARGV[0]; 7 | #syntax();#Not enough arguments for... 8 | hope; 9 | hope(); 10 | &hope; 11 | nope(); 12 | #nope;#Bareword "nope" not allowed... 13 | sub hope { print "I hope you like Perl!\n"; } 14 | sub nope { print "I am a dangerous Bareword.\n" } 15 | my $code_ref = sub { print 'I am a closure'.$/ }; 16 | print $code_ref,$/;#CODE(0x817094c) 17 | $code_ref->(); -------------------------------------------------------------------------------- /05_syntax/05_syntax_ternary.pl: -------------------------------------------------------------------------------- 1 | use strict;use warnings; $\ = $/; 2 | sub false{ 1>2 } 3 | sub true { 1<2 } 4 | sub true_false { return true() ? '1<2' : false() } 5 | print true_false(); 6 | 7 | print 1 < 2 ? 'true' : 'false'; -------------------------------------------------------------------------------- /05_syntax/05_syntax_while.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | $|++;# enable $OUTPUT_AUTOFLUSH 3 | my @sufx = qw(th st nd rd th th th th th th th); 4 | my ($i,$c) = (1,0); 5 | while ($i<=10) { 6 | print "This is $i$sufx[$i] iteration"; 7 | sleep 1; 8 | $i++; 9 | } 10 | 11 | do { 12 | print "The \$i became $i"; 13 | } while $i < 10; 14 | 15 | $i = 10; 16 | until ($i<1) { 17 | print "This is $i$sufx[$i] countdown"; 18 | sleep 1; 19 | $i--; 20 | } 21 | 22 | do { 23 | print "\$i became $i"; 24 | $i-- 25 | } until $i < 1; 26 | 27 | print '- ' x $c, $c and $c++ while ($c<=10) ; -------------------------------------------------------------------------------- /05_syntax/declarations.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | our $dog = 'Puffy'; 3 | { 4 | local $\ =$/; 5 | print 'A line-feed is appended.'; 6 | } 7 | 8 | print 'No new line at the end. '; 9 | print 'A line feed is appended.'.$/; #;) 10 | 11 | tell_dogs(); 12 | 13 | sub tell_dogs { 14 | local $\ =$/; 15 | print 'Our dog is named ' . $dog; 16 | my $dog = 'Betty'; 17 | print 'My dog is named ' . $dog; 18 | } 19 | 20 | print $dog;#Puffy 21 | print "\n---\n"; -------------------------------------------------------------------------------- /05_syntax_bg.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/05_syntax_bg.odp -------------------------------------------------------------------------------- /06_io.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/06_io.odp -------------------------------------------------------------------------------- /06_io/calc.pl: -------------------------------------------------------------------------------- 1 | #calc.pl 2 | use strict; use warnings; $\ = $/; 3 | use Getopt::Long; 4 | use Pod::Usage; 5 | use Data::Dumper; 6 | our %opts; 7 | GetOptions (\%opts, 8 | 'action|do=s','params|p=s@','verbose','help|?' ); 9 | 10 | print Dumper(\%opts) if $opts{verbose}; 11 | 12 | pod2usage(2) if $opts{help} or not $opts{action} ; 13 | 14 | if($opts{action} eq 'sum') { 15 | sum() 16 | } 17 | elsif ($opts{action} eq 'subtract') { 18 | subtract(); 19 | } 20 | else { 21 | print 'The action ' . $opts{action} 22 | .' is not implemented.'; 23 | } 24 | 25 | exit; 26 | 27 | sub sum { 28 | my $sum = 0; 29 | for(@{$opts{params}}){ 30 | s/[^\d]+//g;#sanitize input 31 | print 'adding ' . $_ . ' to '. $sum if $sum; 32 | $sum += $_; 33 | print 'Result: ' . $sum 34 | if $_ != $opts{params}->[0]; 35 | } 36 | } 37 | 38 | sub subtract { 39 | my $result = shift @{$opts{params}}; 40 | for(@{$opts{params}}){ 41 | s/[^\d]+//g;#sanitize input 42 | print 'subtracting '.$_ . ' from '. $result if $result; 43 | $result -= $_; 44 | print 'Result: ' . $result 45 | if $_ != $opts{params}->[0]; 46 | } 47 | } 48 | 49 | __END__ 50 | 51 | 52 | =head1 NAME 53 | 54 | calc.pl - Calculations in real time 55 | 56 | =head1 SYNOPSIS 57 | 58 | write SYNOPSIS 59 | 60 | 61 | =head1 OPTIONS 62 | 63 | calc.pl -do sum 64 | 65 | =head1 TODO 66 | 67 | =over 68 | 69 | =item Implement at least one more action 70 | 71 | =item Consult documentation L and L documentation 72 | 73 | =item Write needed documentation for calc.pl 74 | 75 | =back 76 | 77 | =cut 78 | -------------------------------------------------------------------------------- /06_io/cp.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use File::Copy "cp";#alias for 'copy' 3 | cp("file.txt","file2.txt") or die "Copy failed: $!"; -------------------------------------------------------------------------------- /06_io/crud.pl: -------------------------------------------------------------------------------- 1 | #crud.pl 2 | use strict; use warnings; $\ = $/; 3 | use Getopt::Long; 4 | use Pod::Usage; 5 | use Data::Dumper; 6 | our %opts; 7 | our $data_file = '../data/products.csv'; 8 | our $actions = { 9 | 'create' => \&create, 10 | 'read' => \&list, 11 | 'delete' => \&remove, 12 | 'update' => '' 13 | }; 14 | 15 | GetOptions (\%opts, 16 | 'action|do=s', 17 | 'record|r=s', 18 | ,'verbose','help|?' ); 19 | 20 | print Dumper(\%opts) if $opts{verbose}; 21 | 22 | pod2usage(2) if $opts{help} or not $opts{action} ; 23 | 24 | 25 | 26 | (exists $actions->{$opts{action}} 27 | and ref $actions->{$opts{action}} eq 'CODE') 28 | ? $actions->{$opts{action}}() 29 | : print 'The action "' . $opts{action} .'" is not implemented.'; 30 | exit; 31 | 32 | #actions start here 33 | sub create { 34 | unless($opts{record}){ 35 | die 'Please provide record to insert.'; 36 | } 37 | 38 | open(F,'>>',$data_file) or die 'File '.$data_file.'does not exists.' .$/; 39 | #append blindly as last row 40 | print F $opts{record}; 41 | close F; 42 | #print Dumper($table); 43 | } 44 | 45 | sub list { 46 | open F,'<', $data_file or die 'File '.$data_file.'does not exists.' .$/; 47 | my @FILE =; 48 | close F; 49 | print map { 50 | $_ =~ s|\,|\t|g; 51 | $_ =~ s|"||g; 52 | $_; 53 | } @FILE; 54 | 55 | } 56 | 57 | 58 | sub remove { 59 | 60 | } 61 | 62 | __END__ 63 | 64 | 65 | =head1 NAME 66 | 67 | crud.pl Create, Read, Update Delete application 68 | 69 | =head1 SYNOPSIS 70 | 71 | crud.pl -do read 72 | #or 73 | crud.pl -do create -r 'comma,separated,data,record' 74 | 75 | 76 | =head1 TODO 77 | 78 | =over 79 | 80 | =item Implement at least one more action 81 | 82 | =item Consult documentation L and L documentation 83 | 84 | =item Write needed documentation for crud.pl 85 | 86 | =back 87 | 88 | =cut 89 | -------------------------------------------------------------------------------- /06_io/directories.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | my $dirname = 'samples'; 3 | my @files; 4 | if(opendir(DIR,$dirname)){ 5 | @files = readdir DIR; 6 | closedir DIR; 7 | } 8 | else { 9 | mkdir($dirname,0755) or die $!; 10 | for (1..20) { 11 | my $filename = "sample$_.txt"; 12 | open(OUT,'>',$dirname.'/'.$filename) 13 | and print OUT "hello from $filename"; 14 | close OUT; 15 | } 16 | #now we can try to read again 17 | opendir(DIR,$dirname) or die $!; 18 | @files = readdir DIR; 19 | closedir DIR; 20 | } 21 | 22 | foreach (@files){ 23 | next if /^\./; 24 | open(my $IN,'<',$dirname.'/'.$_) or die $!; 25 | read($IN, my $text, -s $dirname.'/'.$_) 26 | or die 'Could not read '.$dirname.'/'.$_. $!;#wow! 27 | print $text.$/; 28 | close $IN; 29 | } 30 | 31 | # TODO:implement the same program using IO::Dir. -------------------------------------------------------------------------------- /06_io/errors.txt: -------------------------------------------------------------------------------- 1 | Go on, enter something 2 | Now enter some number: 3 | Now enter some number: 4 | Enter some string 5 | Enter some string 6 | Enter some string 7 | Enter some string 8 | Oh you tried to kill me. at stdout.pl line 4, line 6. 9 | Oh you tried to kill me. at stdout.pl line 4, line 6. 10 | -------------------------------------------------------------------------------- /06_io/file.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/06_io/file.txt -------------------------------------------------------------------------------- /06_io/filetests.txt: -------------------------------------------------------------------------------- 1 | -r File is readable by effective uid/gid. 2 | -w File is writable by effective uid/gid. 3 | -x File is executable by effective uid/gid. 4 | -o File is owned by effective uid. 5 | 6 | -R File is readable by real uid/gid. 7 | -W File is writable by real uid/gid. 8 | -X File is executable by real uid/gid. 9 | -O File is owned by real uid. 10 | 11 | -e File exists. 12 | -z File has zero size (is empty). 13 | -s File has nonzero size (returns size in bytes). 14 | 15 | -f File is a plain file. 16 | -d File is a directory. 17 | -l File is a symbolic link. 18 | -p File is a named pipe (FIFO), or Filehandle is a pipe. 19 | -S File is a socket. 20 | -b File is a block special file. 21 | -c File is a character special file. 22 | -t Filehandle is opened to a tty. 23 | 24 | -u File has setuid bit set. 25 | -g File has setgid bit set. 26 | -k File has sticky bit set. 27 | 28 | -T File is an ASCII text file (heuristic guess). 29 | -B File is a "binary" file (opposite of -T). 30 | 31 | -M Script start time minus file modification time, in days. 32 | -A Same for access time. 33 | -C Same for inode change time (Unix, may differ for other platforms) 34 | 35 | -------------------------------------------------------------------------------- /06_io/line_input.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; $|++; 2 | #print "ARGUMENTS: @ARGV" and undef @ARGV if @ARGV; 3 | #Can't open.... 4 | print 'Tell me something'; 5 | my $line_input = <>; 6 | if ($line_input eq $/){ 7 | print 'You just pressed "Enter"' 8 | }else { 9 | chomp $line_input; 10 | print 'You wrote:"' . $line_input 11 | .'" and pressed "Enter".'; 12 | } 13 | -------------------------------------------------------------------------------- /06_io/line_input2.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | #Segmentation fault if use 5.010; 3 | $SIG{'INT'} = sub {print 'Oh you tried to kill me. '}; 4 | 5 | print 'Go on, enter something'; 6 | while (my $input = ){ 7 | chomp $input; 8 | print 'Go on, enter something' and next unless $input; 9 | print sprintf( 'You wrote:"%s" and pressed "Enter"', $input); 10 | if($input =~ /\d+/){ 11 | $input =~ s/[^\d]+//g; 12 | print sprintf('%d looks like number.', $input); 13 | print 'Enter some string'; 14 | }else { 15 | printf $/ 16 | .'"%s",Goood. now enter some number:', $input; 17 | } 18 | } -------------------------------------------------------------------------------- /06_io/open.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | open(FILE,'<','test.txt') 3 | or die 'Can\'t open test.txt for reading. '.$!; 4 | open(FILE,'>','test.txt') 5 | or die 'Can\'t open test.txt for wriring. '.$!; 6 | open(FILE,'>>','test.txt') 7 | or die 'Can\'t open test.txt for appending. '.$!; 8 | -------------------------------------------------------------------------------- /06_io/perlio.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | use utf8;#comment this line 3 | if ($^O =~/Win32/) { 4 | require Win32::Locale; 5 | binmode(STDOUT, ":encoding(cp866)") 6 | if(Win32::Locale::get_language() eq 'bg') 7 | } 8 | else{#assume some unix 9 | binmode(STDOUT, ':utf8') if $ENV{LANG} =~/UTF-8/; 10 | } 11 | my ($малки, $големи) = ("BOB\n", "боб$/"); 12 | print lc $малки, uc($големи) ; 13 | print chomp($малки, $големи) ; 14 | print length $малки,'|',length $големи ; 15 | print $малки, $големи ; 16 | -------------------------------------------------------------------------------- /06_io/readwrite.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | my $FH; 3 | my $file = 'test.txt'; 4 | if (open($FH,'<', $file) ) { 5 | local $/; # slurp mode 6 | my $text = <$FH>; 7 | print "Content of $file:\n$text"; 8 | } 9 | else { 10 | open($FH,'>', $file);#create it 11 | print $FH 'Hello!'; 12 | } 13 | close $FH -------------------------------------------------------------------------------- /06_io/readwrite2.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | my $FH; 3 | my $file = 'test.txt'; 4 | if (open($FH,'<', $file) ) { 5 | my @lines = <$FH>; 6 | print "Content of $file:\n"; 7 | print $_ foreach (@lines); 8 | }else { 9 | print 'Creating '. $file.$/; 10 | open($FH,'>', $file); 11 | print $FH $_.':Hello!'.$/ for (1..4); 12 | } 13 | close $FH; -------------------------------------------------------------------------------- /06_io/readwrite3.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use IO::File; 3 | my $file = 'test.txt'; 4 | my $fh = IO::File->new("< $file"); 5 | my @lines; 6 | $fh->binmode;#see binmode in perlfunc 7 | @lines = $fh->getlines; 8 | print "Content of $file:\n"; 9 | print $_ foreach (@lines); 10 | $fh->close; 11 | #TODO: write a program that writes to a file using IO::File -------------------------------------------------------------------------------- /06_io/stdout.pl: -------------------------------------------------------------------------------- 1 | #try it like this: perl stdout.pl > file.txt 2 | #try it like this: perl stdout.pl 2> errors.txt 3 | #try it like this: perl stdout.pl > file.txt 2> errors.txt 4 | 5 | use strict; use warnings; $\ = $/; $|++; 6 | $SIG{'INT'} = sub {warn 'Oh you tried to kill me. '}; 7 | #avoid "Can't open blbla: No such file or.." 8 | print "ARGUMENTS: @ARGV" and undef @ARGV if @ARGV; 9 | 10 | print STDERR 'Go on, enter something'; 11 | while (my $input = ){ 12 | chomp $input; 13 | print STDERR 'Go on, enter something' and next unless $input; 14 | printf STDOUT ( 'You wrote:"%s" and pressed "Enter"'.$/, $input); 15 | if($input =~ /\d+/){ 16 | $input =~ s/[^\d]+//g; 17 | print STDOUT sprintf('%d looks like number.', $input); 18 | print STDERR 'Enter some string'; 19 | }else { 20 | printf STDOUT $/ 21 | .'"%s",Goood.', $input; 22 | print STDERR 'Now enter some number:' 23 | } 24 | } -------------------------------------------------------------------------------- /06_io/sum.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | my $sum = 0; 3 | for(@ARGV){ 4 | s/[\D]+//g; #sanitize input 5 | $_ ||= 0; #be sure we have a number 6 | print 'adding '.$_ . ' to '. $sum if $sum; 7 | $sum += $_; 8 | print 'Result: ' . $sum if $_ != $ARGV[0] 9 | } 10 | -------------------------------------------------------------------------------- /06_io/test.txt: -------------------------------------------------------------------------------- 1 | 1:Hello! 2 | 2:Hello! 3 | 3:Hello! 4 | 4:Hello! 5 | -------------------------------------------------------------------------------- /06_io_bg.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/06_io_bg.odp -------------------------------------------------------------------------------- /07_subroutines.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/07_subroutines.odp -------------------------------------------------------------------------------- /07_subs/caller.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | use Data::Dumper; 3 | sub dump_stacktrace { 4 | print shift || 'Dumping stacktrace:'; 5 | my $call_frame = 1; 6 | local $,=$/; 7 | my %i; 8 | while(($i{package}, $i{filename}, $i{line}, 9 | $i{subroutine}, $i{hasargs}, $i{wantarray}, 10 | $i{evaltext}, $i{is_require}, $i{hints}, 11 | $i{bitmask}, $i{hinthash}) 12 | = caller($call_frame++)){ 13 | print Data::Dumper->Dump( 14 | [\%i],['call '.($call_frame-1)] 15 | ); 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /07_subs/caller2.pl: -------------------------------------------------------------------------------- 1 | package Calling; 2 | use strict; use warnings; $\ = $/; 3 | use subs qw(dump_stacktrace); 4 | require 'caller.pl'; 5 | run(@ARGV); 6 | sub run { 7 | print '"run" called'; 8 | OtherPackage::second(shift); 9 | } 10 | 11 | sub OtherPackage::second { 12 | print '"second" called with arg:', 13 | (shift||'none'); 14 | my @a = ThirdPackage::third(@_); 15 | } 16 | 17 | sub ThirdPackage::third { 18 | print '"third" called'; 19 | dump_stacktrace 'This is the stack trace:'; 20 | } -------------------------------------------------------------------------------- /07_subs/local.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | use English;#use nice English names for ugly punctuation variables 3 | 4 | { 5 | local $^O = 'Win32'; 6 | local $OUTPUT_RECORD_SEPARATOR = "\n-----\n";#$\ 7 | local $OUTPUT_FIELD_SEPARATOR = ': ';#$, 8 | print 'We run on', $OSNAME; 9 | 10 | open my $fh, $PROGRAM_NAME or die $OS_ERROR;#$0 $! 11 | local $INPUT_RECORD_SEPARATOR ; #$/ enable localized slurp mode 12 | my $content = <$fh>; 13 | close $fh; 14 | print $content; 15 | #my $^O = 'Solaris';#Can't use global $^O in "my"... 16 | } 17 | print 'We run on ', $OSNAME; -------------------------------------------------------------------------------- /07_subs/my.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | $\ = $, = $/; 3 | my $dog = 'Puffy'; 4 | { 5 | my $dog = 'Betty'; 6 | print 'My dog is named ' . $dog; 7 | } 8 | print 'My dog is named ' . $dog; 9 | my ($fish, $cat, $parrot) = qw|Goldy Amelia Jako|; 10 | print $fish, $cat, $parrot; 11 | #print $lizard; 12 | #Global symbol "$lizard" requires explicit package name... -------------------------------------------------------------------------------- /07_subs/our.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ =$/; 2 | { 3 | package GoodDogs; 4 | print 'We are in package ' . __PACKAGE__; 5 | our $dog = 'Puffy'; 6 | { 7 | print 'Our dog is named ' . $dog; 8 | my $dog = 'Betty'; 9 | print 'My dog is named ' . $dog; 10 | } 11 | print 'My dog is named ' . $dog; 12 | #}{ 13 | package BadDogs; 14 | print $/.'We are in package ' . __PACKAGE__; 15 | print 'Previous dog is named ' . $dog; 16 | print 'Your dog is named ' . $GoodDogs::dog; 17 | our $dog = 'Bobby'; 18 | print 'Our dog is named ' . $dog; 19 | } 20 | -------------------------------------------------------------------------------- /07_subs/return.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; use diagnostics; $\ = $/; 2 | #prints favorite pet or a list of all pets 3 | my @pets = qw|Goldy Amelia Jako|; 4 | print run($ARGV[0]); 5 | sub run { 6 | my $pref = shift||'';#favorite or list of pets 7 | if($pref) { favorite() } 8 | else { local $,=$/; print pets() } 9 | } 10 | sub favorite { 11 | 'favorite:'.$pets[1] 12 | } 13 | sub pets { 14 | return ('all pets:', @pets) 15 | } -------------------------------------------------------------------------------- /07_subs/state.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use 5.10.0; 3 | #or 5.12.0 etc...; 4 | #or just 5 | #use feature qw(say state); 6 | use strict; 7 | use warnings; 8 | for(1..9){ 9 | stateful($_,$_); 10 | } 11 | sub stateful{ 12 | my $param = shift; 13 | state $once = shift; 14 | say 'we were given ', $param, 15 | ', but we kept first time call param: '.$once; 16 | } 17 | -------------------------------------------------------------------------------- /07_subs/sub.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | 3 | sub hope; 4 | sub syntax($) { 5 | print "This is 'Subroutines' slide " 6 | .($_[0]||1) ."\n"; 7 | } 8 | syntax $ARGV[0]; 9 | syntax();#Not enough arguments for... 10 | hope; 11 | hope(); 12 | &hope; 13 | nope(); 14 | #nope;#Bareword "nope" not allowed... 15 | sub hope { print "I hope you like Perl!\n"; } 16 | sub nope { print "I am a dangerous Bareword.\n" } 17 | my $code_ref = sub { print 'I am a closure'.$/ }; 18 | print $code_ref,$/;#CODE(0x817094c) 19 | #$code_ref->() or 20 | &$code_ref; -------------------------------------------------------------------------------- /07_subs/sub_args.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | sub modify($) { 3 | print "The alias holding " 4 | .($_[0]++) ." will be modifyed\n"; 5 | } 6 | 7 | modify($ARGV[0]); 8 | print $ARGV[0]; 9 | 10 | copy_arg($ARGV[0]); 11 | print $ARGV[0]; 12 | 13 | sub copy_arg { 14 | my ($copy) = @_; 15 | print "The copy holding " 16 | .($copy++) ." will NOT modify \$ARGV[0]\n"; 17 | } -------------------------------------------------------------------------------- /07_subs/wantarray.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | #prints favorite pet or a list of all pets depending on context 3 | my @pets = qw|Goldy Amelia Jako|; 4 | run(); 5 | 6 | sub run { 7 | if(defined $ARGV[0]) { 8 | $ARGV[0] =~ s/[^\d]+//g; #sanitize input 9 | $ARGV[0] ||= 1; #default to scalar context 10 | if($ARGV[0] == 1) { 11 | my $favorite = pets(); #scalar context 12 | } 13 | elsif($ARGV[0] >= 2) { 14 | my @pets = pets() #list context 15 | } 16 | } 17 | else { 18 | pets(); #void context 19 | } 20 | } 21 | 22 | sub pets { 23 | local $,=$/ 24 | print ('all pets:', @pets) if wantarray; #list context 25 | return if not defined wantarray; #void context 26 | print 'favorite:'.$pets[1] if not wantarray; #scalar context 27 | } -------------------------------------------------------------------------------- /08_references.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/08_references.odp -------------------------------------------------------------------------------- /08_refs/interpolation.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | my @pets = qw|Goldy Amelia Jako|; 3 | my $self = { 4 | name =>'Krassi', 5 | family_name => 'Berov', 6 | can => sub { return shift }, 7 | pets => \@pets, 8 | children =>[qw|Maria Pavel Victoria|], 9 | }; 10 | 11 | print <{name} $self->{family_name}. 14 | I can ${\$self->{can}('talk')}. 15 | My first child is $self->{children}[0]. 16 | My last child is $self->{children}[-1]. 17 | I do not have a pet named $self->{pets}[1]. 18 | TXT 19 | 20 | -------------------------------------------------------------------------------- /08_refs/test.txt: -------------------------------------------------------------------------------- 1 | 1:Hello! 2 | 2:Hello! 3 | 3:Hello! 4 | 4:Hello! 5 | -------------------------------------------------------------------------------- /08_refs/using.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; $\ = $/; 2 | use Data::Dumper; 3 | my $self = { 4 | name =>'Krassi', 5 | family_name => 'Berov', 6 | children =>[qw|Maria Pavel Viktoria|], 7 | fthings => { 8 | color => 'blue', 9 | animal => 'leopard', 10 | band => 'Jethro Tull', 11 | languages => ['Bulgarian','French','English'], 12 | } 13 | }; 14 | print "Hello! I am $self->{name} $self->{family_name}.\n" 15 | . 'I have '. scalar @{$self->{children}} . ' children. ' 16 | . "They are named:\n\t" , (join "\n\t", @{$self->{children}}) 17 | . "\n\nI have also some favorite things:"; 18 | 19 | foreach (sort keys %{$self->{fthings}}) { 20 | if(ref $self->{fthings}{$_} eq 'HASH') { 21 | print "I Do not know how to output a HASH reference"; 22 | } 23 | elsif(ref $self->{fthings}{$_} eq 'ARRAY') { 24 | print "\n", ucfirst($_), ":\n", 25 | map( "\t$_ \n", @{$self->{fthings}{$_}} ); 26 | #Note: If the above line is confusing, why and why, if not? 27 | } 28 | else { 29 | print ucfirst($_).":\t" . $self->{fthings}{$_}; 30 | } 31 | } 32 | 33 | my $ftings = $self->{fthings}; 34 | print $ftings; 35 | $ftings->{doing_web} = 'yes'; 36 | #autovivify 37 | push @{$ftings->{web_tools}}, 'Perl','XHTML','CSS','JavaScript'; 38 | 39 | print Data::Dumper->Dump([$self],['self']); 40 | 41 | -------------------------------------------------------------------------------- /09_regex.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/09_regex.odp -------------------------------------------------------------------------------- /09_regex/alternation.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;$\=$/; 2 | my $digits ="here are some digits3434 and then "; 3 | 4 | print 'found "are" or "and"' if $digits =~/are|and/; -------------------------------------------------------------------------------- /09_regex/ch_classess.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;$\=$/; 2 | my $string ='A probably long chunk of text containing strings'; 3 | my $thing = 'ong ung ang enanything'; 4 | my $every = 'iiiiii'; 5 | my $nums = 'I have 4325 Euro'; 6 | my $class = 'dog'; 7 | print 'matched any of a, b or c' 8 | if $string =~ /[abc]/; 9 | print $/,$/; 10 | for($thing, $every, $string){ 11 | print 'ingy brrrings nothing using: ' 12 | .$_ 13 | if /[$class]/ 14 | } 15 | 16 | print $/,$/; 17 | print $nums if $nums =~/[0-9]/; 18 | 19 | -------------------------------------------------------------------------------- /09_regex/ch_classess2.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;$\=$/; 2 | my $digits ="here are some digits3434 and then "; 3 | print 'found digit' if $digits =~/\d/; 4 | print 'found alphanumeric' if $digits =~/\w/; 5 | print 'found space' if $digits =~/\s/; 6 | print 'digit followed by space, followed by letter' 7 | if $digits =~/\d\s[A-z]/; -------------------------------------------------------------------------------- /09_regex/extracting.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;$\=$/; 2 | my $digits ="here are some digits3434 and then678 "; 3 | 4 | print 'found a letter followed by leters or digits":'.$1 5 | if $digits =~/[a-z]([a-z]|\d+)/; 6 | print 'found a letter followed by digits":'.$1 .$2 7 | if $digits =~/([a-z](\d+))/; 8 | print 'found letters followed by digits":'.$1 .$2 9 | if $digits =~/([a-z]+)(\d+)/; -------------------------------------------------------------------------------- /09_regex/grouping.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;$\=$/; 2 | my $digits ="here are some digits3434 and then678 "; 3 | 4 | print 'found a letter followed by leters or digits":'.$1 5 | if $digits =~/[a-z]([a-z]|\d+)/; 6 | print 'found a letter followed by digits":'.$1 7 | if $digits =~/([a-z](\d+))/; 8 | print 'found letters followed by digits":'.$1 9 | if $digits =~/([a-z]+(\d+))/; -------------------------------------------------------------------------------- /09_regex/repetitions.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;$\=$/; 2 | my $digits ="here are some digits3434 and then678 "; 3 | 4 | print 'found some letters followed by leters or digits":'.$1 .$2 5 | if $digits =~/([a-z]{2,})(\w+)/; 6 | 7 | print 'found three letter followed by digits":'.$1 .$2 8 | if $digits =~/([a-z]{3}(\d+))/; 9 | 10 | print 'found up to four letters followed by digits":'.$1 .$2 11 | if $digits =~/([a-z]{1,4})(\d+)/; 12 | 13 | #Greedy 14 | 15 | print 'found as much as possible letters 16 | followed by digits":'.$1 .$2 17 | if $digits =~/([a-z]*)(\d+)/; 18 | -------------------------------------------------------------------------------- /09_regex/simple.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | my $string ='A probably long chunk of text containing strings'; 3 | print "found 'string'\n" if $string =~ /string/; 4 | print "it is not about dogs\n" if $string !~ /dog/; 5 | 6 | my $word = 'string'; my $animal = 'dog'; 7 | print "found '$word'\n" if $string =~ /$word/; 8 | print "it is not about ${animal}s\n" 9 | if $string !~ /$animal/; 10 | 11 | for('dog','string','dog'){ 12 | print "$word\n" if /$word/ 13 | } -------------------------------------------------------------------------------- /09_regex/simple2.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | my $string ='stringify this world of 3 | words and anything'; 4 | 5 | my $word = 'string'; my $animal = 'dog'; 6 | print "found '$word'\n" if $string =~ /$word/; 7 | print "it is not about ${animal}s\n" 8 | if $string !~ /$animal/; 9 | 10 | for('dog','string','dog'){ 11 | print "$word\n" if /$word/ 12 | } -------------------------------------------------------------------------------- /09_regex/simple3.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | my $string ='Stringify this world!'; 3 | my $word = 'string'; my $animal = 'dog'; 4 | print "found '$word'\n" if $string =~ m#$word#; 5 | print "found '$word' in any case\n" 6 | if $string =~ m{$word}i; 7 | print "it is not about ${animal}s\n" 8 | if $string !~ m($animal); 9 | for('dog','string','Dog'){ 10 | local $\=$/; 11 | print if m|$animal| 12 | } -------------------------------------------------------------------------------- /09_regex/simple4.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | my $string ='Stringify this stringy world.'; 3 | my $word = 'string'; 4 | print "found '$word' in any case\n" 5 | if $string =~ m{$word}i; 6 | 7 | #metacharacters 8 | #{ } [ ] ( ) ^ $ . | * + ? \ 9 | print "The string \n'$string'\n contains a DOT\n" 10 | if $string =~ m|\.|; 11 | 12 | -------------------------------------------------------------------------------- /09_regex/simple5.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; 2 | use utf8; 3 | binmode(STDOUT, ':utf8') if $ENV{LANG} =~/UTF-8/; 4 | $\=$/; 5 | my $string ="contains\r\n Then we have some\t\ttabs.б"; 6 | 7 | print 'matched б(\x{431})' 8 | if $string =~ /\x{431}/; 9 | print 'matched б' if $string =~/б/; 10 | print 'matched \r\n' if $string =~/\r\n/; 11 | print 'The string was:"' . $string.'"'; 12 | 13 | 14 | -------------------------------------------------------------------------------- /09_regex/simple6.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;$\=$/; 2 | my $string ='A probably long chunk of text containing strings'; 3 | print 'matched "A"' if $string =~ /^A/; 4 | print 'matched "strings"' if $string =~ /strings$/; 5 | print 'matched "A", matched "strings" and something in between' 6 | if $string =~ /^A.*?strings$/; -------------------------------------------------------------------------------- /10_oop.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/10_oop.odp -------------------------------------------------------------------------------- /10_oop/Examle-Class/Build.PL: -------------------------------------------------------------------------------- 1 | use 5.006; 2 | use strict; 3 | use warnings FATAL => 'all'; 4 | use Module::Build; 5 | 6 | my $builder = Module::Build->new( 7 | module_name => 'Examle::Class', 8 | license => 'Artistic_2_0', 9 | dist_author => q{krasi }, 10 | dist_version_from => 'lib/Examle/Class.pm', 11 | release_status => 'stable', 12 | configure_requires => { 13 | 'Module::Build' => 0, 14 | }, 15 | build_requires => { 16 | 'Test::More' => 0, 17 | }, 18 | requires => { 19 | #'ABC' => 1.6, 20 | #'Foo::Bar::Module' => 5.0401, 21 | }, 22 | add_to_cleanup => [ 'Examle-Class-*' ], 23 | create_makefile_pl => 'traditional', 24 | ); 25 | 26 | $builder->create_build_script(); 27 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/Changes: -------------------------------------------------------------------------------- 1 | Revision history for Examle-Class 2 | 3 | 0.01 Date/time 4 | First version, released on an unsuspecting world. 5 | 6 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/MANIFEST: -------------------------------------------------------------------------------- 1 | Build.PL 2 | Changes 3 | lib/Examle/Class.pm 4 | MANIFEST This list of files 5 | README 6 | t/00-load.t 7 | t/manifest.t 8 | t/pod-coverage.t 9 | t/pod.t 10 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/README: -------------------------------------------------------------------------------- 1 | Examle-Class 2 | 3 | The README is used to introduce the module and provide instructions on 4 | how to install the module, any machine dependencies it may have (for 5 | example C compilers and installed libraries) and any other information 6 | that should be provided before the module is installed. 7 | 8 | A README file is required for CPAN modules since CPAN extracts the README 9 | file from a module distribution so that people browsing the archive 10 | can use it to get an idea of the module's uses. It is usually a good idea 11 | to provide version information here so that people can decide whether 12 | fixes for the module are worth downloading. 13 | 14 | 15 | INSTALLATION 16 | 17 | To install this module, run the following commands: 18 | 19 | perl Build.PL 20 | ./Build 21 | ./Build test 22 | ./Build install 23 | 24 | SUPPORT AND DOCUMENTATION 25 | 26 | After installing, you can find documentation for this module with the 27 | perldoc command. 28 | 29 | perldoc Examle::Class 30 | 31 | You can also look for information at: 32 | 33 | RT, CPAN's request tracker (report bugs here) 34 | http://rt.cpan.org/NoAuth/Bugs.html?Dist=Examle-Class 35 | 36 | AnnoCPAN, Annotated CPAN documentation 37 | http://annocpan.org/dist/Examle-Class 38 | 39 | CPAN Ratings 40 | http://cpanratings.perl.org/d/Examle-Class 41 | 42 | Search CPAN 43 | http://search.cpan.org/dist/Examle-Class/ 44 | 45 | 46 | LICENSE AND COPYRIGHT 47 | 48 | Copyright (C) 2013 krasi 49 | 50 | This program is free software; you can redistribute it and/or modify it 51 | under the terms of the the Artistic License (2.0). You may obtain a 52 | copy of the full license at: 53 | 54 | L 55 | 56 | Any use, modification, and distribution of the Standard or Modified 57 | Versions is governed by this Artistic License. By using, modifying or 58 | distributing the Package, you accept this license. Do not use, modify, 59 | or distribute the Package, if you do not accept this license. 60 | 61 | If your Modified Version has been derived from a Modified Version made 62 | by someone other than you, you are nevertheless required to ensure that 63 | your Modified Version complies with the requirements of this license. 64 | 65 | This license does not grant you the right to use any trademark, service 66 | mark, tradename, or logo of the Copyright Holder. 67 | 68 | This license includes the non-exclusive, worldwide, free-of-charge 69 | patent license to make, have made, use, offer to sell, sell, import and 70 | otherwise transfer the Package with respect to any patent claims 71 | licensable by the Copyright Holder that are necessarily infringed by the 72 | Package. If you institute patent litigation (including a cross-claim or 73 | counterclaim) against any party alleging that the Package constitutes 74 | direct or contributory patent infringement, then this Artistic License 75 | to you shall terminate on the date that such litigation is filed. 76 | 77 | Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER 78 | AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. 79 | THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 80 | PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY 81 | YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR 82 | CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR 83 | CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, 84 | EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 85 | 86 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/ignore.txt: -------------------------------------------------------------------------------- 1 | Makefile 2 | Makefile.old 3 | Build 4 | Build.bat 5 | META.* 6 | MYMETA.* 7 | .build/ 8 | _build/ 9 | cover_db/ 10 | blib/ 11 | inc/ 12 | .lwpcookies 13 | .last_cover_stats 14 | nytprof.out 15 | pod2htm*.tmp 16 | pm_to_blib 17 | Examle-Class-* 18 | Examle-Class-*.tar.gz 19 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/lib/Examle/Class.pm: -------------------------------------------------------------------------------- 1 | package Examle::Class; 2 | 3 | use 5.010; 4 | use strict; 5 | use warnings FATAL => 'all'; 6 | 7 | =head1 NAME 8 | 9 | Examle::Class - An Examle::Class to play with! 10 | 11 | =head1 VERSION 12 | 13 | Version 0.01 14 | 15 | =cut 16 | 17 | our $VERSION = '0.01'; 18 | 19 | 20 | =head1 SYNOPSIS 21 | 22 | Quick summary of what the module does. 23 | 24 | Perhaps a little code snippet. 25 | 26 | use Examle::Class; 27 | 28 | my $foo = Examle::Class->new(); 29 | ... 30 | 31 | =head1 EXPORT 32 | 33 | A list of functions that can be exported. You can delete this section 34 | if you don't export anything, such as for a purely object-oriented module. 35 | 36 | =head1 SUBROUTINES/METHODS 37 | 38 | =head2 function1 39 | 40 | =cut 41 | 42 | sub function1 { 43 | } 44 | 45 | =head2 function2 46 | 47 | =cut 48 | 49 | sub function2 { 50 | } 51 | 52 | =head1 AUTHOR 53 | 54 | krasi, C<< >> 55 | 56 | =head1 BUGS 57 | 58 | Please report any bugs or feature requests to C, or through 59 | the web interface at L. I will be notified, and then you'll 60 | automatically be notified of progress on your bug as I make changes. 61 | 62 | 63 | 64 | 65 | =head1 SUPPORT 66 | 67 | You can find documentation for this module with the perldoc command. 68 | 69 | perldoc Examle::Class 70 | 71 | 72 | You can also look for information at: 73 | 74 | =over 4 75 | 76 | =item * RT: CPAN's request tracker (report bugs here) 77 | 78 | L 79 | 80 | =item * AnnoCPAN: Annotated CPAN documentation 81 | 82 | L 83 | 84 | =item * CPAN Ratings 85 | 86 | L 87 | 88 | =item * Search CPAN 89 | 90 | L 91 | 92 | =back 93 | 94 | 95 | =head1 ACKNOWLEDGEMENTS 96 | 97 | 98 | =head1 LICENSE AND COPYRIGHT 99 | 100 | Copyright 2013 krasi. 101 | 102 | This program is free software; you can redistribute it and/or modify it 103 | under the terms of the the Artistic License (2.0). You may obtain a 104 | copy of the full license at: 105 | 106 | L 107 | 108 | Any use, modification, and distribution of the Standard or Modified 109 | Versions is governed by this Artistic License. By using, modifying or 110 | distributing the Package, you accept this license. Do not use, modify, 111 | or distribute the Package, if you do not accept this license. 112 | 113 | If your Modified Version has been derived from a Modified Version made 114 | by someone other than you, you are nevertheless required to ensure that 115 | your Modified Version complies with the requirements of this license. 116 | 117 | This license does not grant you the right to use any trademark, service 118 | mark, tradename, or logo of the Copyright Holder. 119 | 120 | This license includes the non-exclusive, worldwide, free-of-charge 121 | patent license to make, have made, use, offer to sell, sell, import and 122 | otherwise transfer the Package with respect to any patent claims 123 | licensable by the Copyright Holder that are necessarily infringed by the 124 | Package. If you institute patent litigation (including a cross-claim or 125 | counterclaim) against any party alleging that the Package constitutes 126 | direct or contributory patent infringement, then this Artistic License 127 | to you shall terminate on the date that such litigation is filed. 128 | 129 | Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER 130 | AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. 131 | THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 132 | PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY 133 | YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR 134 | CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR 135 | CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, 136 | EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 137 | 138 | 139 | =cut 140 | 141 | 1; # End of Examle::Class 142 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/t/00-load.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | use 5.006; 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | use Test::More; 6 | 7 | plan tests => 1; 8 | 9 | BEGIN { 10 | use_ok( 'Examle::Class' ) || print "Bail out!\n"; 11 | } 12 | 13 | diag( "Testing Examle::Class $Examle::Class::VERSION, Perl $], $^X" ); 14 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/t/boilerplate.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | use 5.006; 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | use Test::More; 6 | 7 | plan tests => 3; 8 | 9 | sub not_in_file_ok { 10 | my ($filename, %regex) = @_; 11 | open( my $fh, '<', $filename ) 12 | or die "couldn't open $filename for reading: $!"; 13 | 14 | my %violated; 15 | 16 | while (my $line = <$fh>) { 17 | while (my ($desc, $regex) = each %regex) { 18 | if ($line =~ $regex) { 19 | push @{$violated{$desc}||=[]}, $.; 20 | } 21 | } 22 | } 23 | 24 | if (%violated) { 25 | fail("$filename contains boilerplate text"); 26 | diag "$_ appears on lines @{$violated{$_}}" for keys %violated; 27 | } else { 28 | pass("$filename contains no boilerplate text"); 29 | } 30 | } 31 | 32 | sub module_boilerplate_ok { 33 | my ($module) = @_; 34 | not_in_file_ok($module => 35 | 'the great new $MODULENAME' => qr/ - The great new /, 36 | 'boilerplate description' => qr/Quick summary of what the module/, 37 | 'stub function definition' => qr/function[12]/, 38 | ); 39 | } 40 | 41 | TODO: { 42 | local $TODO = "Need to replace the boilerplate text"; 43 | 44 | not_in_file_ok(README => 45 | "The README is used..." => qr/The README is used/, 46 | "'version information here'" => qr/to provide version information/, 47 | ); 48 | 49 | not_in_file_ok(Changes => 50 | "placeholder date/time" => qr(Date/time) 51 | ); 52 | 53 | module_boilerplate_ok('lib/Examle/Class.pm'); 54 | 55 | 56 | } 57 | 58 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/t/manifest.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | use 5.006; 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | use Test::More; 6 | 7 | unless ( $ENV{RELEASE_TESTING} ) { 8 | plan( skip_all => "Author tests not required for installation" ); 9 | } 10 | 11 | my $min_tcm = 0.9; 12 | eval "use Test::CheckManifest $min_tcm"; 13 | plan skip_all => "Test::CheckManifest $min_tcm required" if $@; 14 | 15 | ok_manifest(); 16 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/t/pod-coverage.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | use 5.006; 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | use Test::More; 6 | 7 | # Ensure a recent version of Test::Pod::Coverage 8 | my $min_tpc = 1.08; 9 | eval "use Test::Pod::Coverage $min_tpc"; 10 | plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" 11 | if $@; 12 | 13 | # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, 14 | # but older versions don't recognize some common documentation styles 15 | my $min_pc = 0.18; 16 | eval "use Pod::Coverage $min_pc"; 17 | plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" 18 | if $@; 19 | 20 | all_pod_coverage_ok(); 21 | -------------------------------------------------------------------------------- /10_oop/Examle-Class/t/pod.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | use 5.006; 3 | use strict; 4 | use warnings FATAL => 'all'; 5 | use Test::More; 6 | 7 | # Ensure a recent version of Test::Pod 8 | my $min_tp = 1.22; 9 | eval "use Test::Pod $min_tp"; 10 | plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; 11 | 12 | all_pod_files_ok(); 13 | -------------------------------------------------------------------------------- /10_oop/bless.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;use utf8; $\=$/; 2 | binmode(STDOUT, ':utf8') if $ENV{LANG} =~/UTF-8/; 3 | #create a class/package 4 | { 5 | package Dog; 6 | sub new { 7 | my $class = shift; 8 | my $self = { 9 | name =>'Puffy', 10 | nationality =>'bg_BG', 11 | language =>'Bulgarian', 12 | }; 13 | bless $self, $class; 14 | } 15 | sub language { 16 | $_[0]->{language} = $_[1] if $_[1]; 17 | return $_[0]->{language}; 18 | } 19 | sub name { 20 | return $_[0]->{name} 21 | } 22 | 23 | sub bark { 24 | my $self = shift; 25 | print "\tбау, бау..." 26 | } 27 | } 28 | #our regular script start here 29 | 30 | 31 | my $doggy = Dog->new(); 32 | print 'We are in package: ' . __PACKAGE__ 33 | .$/.'But we have yet another in the same file.' 34 | .$/.'We even made it a class called "'.ref($doggy).'".'; 35 | 36 | print 'Does my new '.ref($doggy).' has a name?'; 37 | print 'Yes, it is ' , $doggy->name, '.' 38 | if $doggy->can('name'); 39 | 40 | print $/.'This is a '.$doggy->language.' barking '.ref($doggy).'.' 41 | if $doggy->{nationality} =~ /bg/i; 42 | 43 | print 'And it barks in Bulgarian' 44 | if $doggy->can('bark'); 45 | print 'Voila:'; 46 | $doggy->bark; 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | -------------------------------------------------------------------------------- /10_oop/ref.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;use utf8; 2 | use Scalar::Util qw(blessed reftype); 3 | $\=$/; 4 | binmode(STDOUT, ':utf8') if $ENV{LANG} =~/UTF-8/; 5 | #create a class/package 6 | { 7 | package Dog; 8 | sub new { 9 | my $class = shift; 10 | my $self = { 11 | name =>'Puffy', 12 | nationality =>'bg_BG', 13 | }; 14 | bless $self, $class; 15 | } 16 | 17 | sub type { __PACKAGE__ } 18 | } 19 | #our regular script start here 20 | my $doggy = Dog->new(); 21 | print 'Hi again 22 | We are in package: ' . __PACKAGE__ 23 | .$/.'But we have yet another in the same file.' 24 | .$/.'We even made it a class called '.$doggy->type.'.'; 25 | 26 | print 'One proove' 27 | if ref $doggy eq 'Dog'; 28 | 29 | print 'Second proove' 30 | if $doggy->isa('Dog'); 31 | print 'Third proove:'. blessed $doggy 32 | if blessed $doggy; 33 | print 'Fourth proove:'. reftype $doggy 34 | if reftype $doggy; 35 | print 'Ops. I lied...' 36 | if reftype $doggy eq 'HASH'; 37 | 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /10_oop/require.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;use utf8; 2 | ;$\=$/; 3 | if ($]>5.0095){ 4 | require Time::Piece; 5 | my $t = Time::Piece->new(); 6 | print 'Using Time::Piece...'; 7 | print "Today:".$t->dmy('-'); 8 | } 9 | else { 10 | require POSIX; 11 | print 'Using POSIX...'; 12 | print "Today:".POSIX::strftime( 13 | '%d-%m-%Y',localtime(time) 14 | ); 15 | } -------------------------------------------------------------------------------- /10_oop/tie.pl: -------------------------------------------------------------------------------- 1 | use strict;use warnings; use utf8; 2 | use DB_File ; use Data::Dumper; 3 | $\=$/; 4 | #tie a hash to a berkely database 1.x 5 | my (%table,$k,$v); 6 | tie %table, "DB_File", "db_file.db", 7 | O_RDWR|O_CREAT, 0644, $DB_HASH 8 | or die "Cannot open file 'db_file.db': $!"; 9 | 10 | # Add a few key/value pairs to the file 11 | $table{"apple"} = "red" unless exists $table{"apple"}; 12 | $table{"orange"} = "orange" unless exists $table{"orange"}; 13 | $table{"banana"} = "yellow" unless exists $table{"banana"}; 14 | $table{"tomato"} = "red" unless exists $table{"tomato"}; 15 | 16 | # Check for existence of a key 17 | print "Banana Exists" if exists $table{"banana"} ; 18 | # Delete a key/value pair. 19 | delete $table{"apple"} ; 20 | # dump the contents of the file 21 | 22 | print Dumper(\%table); 23 | untie %table; -------------------------------------------------------------------------------- /10_oop/tied.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;use utf8; 2 | use DB_File ;use Data::Dumper; 3 | $\=$/; 4 | 5 | my (%table,$obj); 6 | tie %table, "DB_File", "db_file.db", 7 | O_RDWR, 0644, $DB_HASH 8 | or die "Cannot open file 'db_file.db': $!"; 9 | $obj = tied(%table); 10 | my $value; 11 | $obj->get("banana",$value) ; 12 | print 'Banana is:'.$value; 13 | $obj->put('cow','milk'); 14 | print Dumper(\%table); 15 | 16 | undef $obj; 17 | untie %table; -------------------------------------------------------------------------------- /10_oop/use.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings;use utf8; 2 | use 5.010; 3 | $\=$/; 4 | 5 | use Time::Piece; 6 | my $t = localtime; 7 | say "Today:".$t->dmy('-'); 8 | -------------------------------------------------------------------------------- /10_oop/using_modules.pl: -------------------------------------------------------------------------------- 1 | use strict; use warnings; use utf8; 2 | use FindBin; 3 | BEGIN {$ENV{APP_ROOT} = $FindBin::Bin .'/..'} 4 | use lib($ENV{APP_ROOT}.'/lib'); 5 | use Data::Table;#patched... See TODO in module 6 | use Data::Dumper; 7 | 8 | binmode(STDOUT, ':utf8') if $ENV{LANG} =~/UTF-8/; 9 | print '$ENV{APP_ROOT}:'.$ENV{APP_ROOT}."\n\n"; 10 | print '$FindBin::Bin:'.$FindBin::Bin."\n\n"; 11 | 12 | # Read a csv file into a table object 13 | my $t = Data::Table::fromCSV( 14 | "$ENV{APP_ROOT}/data/products.csv" 15 | ); 16 | 17 | $t->addRow([ 18 | 'сирене', 19 | 'Синьо 20 | с маслини', 21 | 0.500,0.30 22 | ]); 23 | $t->tsv(1,{file=>\*STDOUT}); 24 | #or just 25 | print $/.$t->tsv; 26 | #print Dumper($t); 27 | 28 | -------------------------------------------------------------------------------- /11_dbi.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/11_dbi.odp -------------------------------------------------------------------------------- /12_p_and_t/creating_threads.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | BEGIN { 3 | use Config; 4 | $Config{useithreads} 5 | or die('Threads support needed.'); 6 | } 7 | use strict;use warnings; 8 | use threads; 9 | $|++; 10 | while (1){ 11 | sleep 1; 12 | my $thread_id = threads->self()->tid; 13 | threads->create(\&a_thread,$thread_id,[localtime]); 14 | #OR 15 | threads->new(\&a_thread,$thread_id,[localtime]); 16 | 17 | } 18 | 19 | sub a_thread { 20 | my @params = @_; 21 | my $self = threads->self(); 22 | my $thread_id = $self->tid(); 23 | my @created_threads; 24 | if ($thread_id % 2){ 25 | sleep 1; 26 | print "\t"; 27 | threads->create(\&a_thread,$thread_id,@params); 28 | } 29 | foreach(reverse 1 .. @params-2){ 30 | print "\t$/thread " . $params[$_] . ' created '; 31 | } 32 | print('thread with id '.$thread_id); 33 | 34 | print sprintf(' Time is: %02d:%02d:%02d'.$/, 35 | $params[-1]->[2],$params[-1]->[1],$params[-1]->[0]); 36 | 37 | } -------------------------------------------------------------------------------- /12_p_and_t/deadlock.pl: -------------------------------------------------------------------------------- 1 | use threads; 2 | use threads::shared; 3 | my $a :shared = 4; 4 | my $b :shared = 'foo'; 5 | my $thr1 = threads->create(sub { 6 | lock($a); 7 | sleep(2); 8 | lock($b); 9 | $a++; 10 | $b .= $a; 11 | })->join ; 12 | my $thr2 = threads->create(sub { 13 | lock($b); 14 | sleep(2); 15 | lock($a); 16 | $a++; 17 | $b .= $a; 18 | })->join ; 19 | print $thr1,$/,$thr2,$/; -------------------------------------------------------------------------------- /12_p_and_t/io-socket-server-threaded.pl: -------------------------------------------------------------------------------- 1 | use strict;use warnings; 2 | use threads; 3 | use IO::Socket; 4 | my ($host, $port, $path ) = ( 'localhost', 8088 ); 5 | my $listen = IO::Socket::INET->new( 6 | LocalAddr => $host, 7 | LocalPort => $port, 8 | Proto => 'tcp', 9 | Listen => 10, 10 | Type => SOCK_STREAM, 11 | ReuseAddr => 1 12 | ); 13 | print "Server ($0) running on port $port...\n"; 14 | 15 | while (my $socket = $listen->accept) { 16 | async(\&handle_connection, $socket)->detach; 17 | } 18 | sub handle_connection { 19 | my $connection = shift; 20 | print "Client connected at ", scalar(localtime), "\n"; 21 | $connection->print( 22 | 'You\'re connected to the server!' 23 | .'This is thread '.threads->self->tid .$/ 24 | ); 25 | while (<$connection>) { 26 | print "Client says: $_"; 27 | } 28 | } -------------------------------------------------------------------------------- /12_p_and_t/io-socket-tcp-server-fork.pl: -------------------------------------------------------------------------------- 1 | use strict;use warnings; 2 | use IO::Socket; 3 | use POSIX qw(:sys_wait_h); 4 | my ($host, $port, $path ) = ( 'localhost', 8088 ); 5 | my $server = new IO::Socket::INET ( 6 | LocalAddr => $host, 7 | LocalPort => $port, 8 | Proto => 'tcp', 9 | Listen => 10, 10 | Type => SOCK_STREAM, 11 | ReuseAddr => 1 12 | ) or die $@; 13 | 14 | 15 | sub REAPER { 16 | 1 until (-1 == waitpid(-1, WNOHANG)); 17 | $SIG{CHLD} = \&REAPER; 18 | } 19 | 20 | $SIG{CHLD} = \&REAPER; 21 | 22 | print "Server ($0) running on port $port...\n"; 23 | while (my $connection = $server->accept) { 24 | if (my $pid = fork){ 25 | handle_connection($connection,$$); 26 | } 27 | } 28 | $server->close(); 29 | sub handle_connection { 30 | my $connection = shift; 31 | my $pid = shift||0; 32 | print "Client connected at ", scalar(localtime), "\n"; 33 | $connection->print( 34 | 'You\'re connected to the server!' 35 | .'This is process id '.$pid .$/ 36 | ); 37 | while (<$connection>) { 38 | print "Client says: $_"; 39 | } 40 | $connection->shutdown(2); 41 | print "Client disconnected\n"; 42 | } 43 | 44 | -------------------------------------------------------------------------------- /12_p_and_t/lock.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | BEGIN { 3 | use Config; 4 | $Config{useithreads} 5 | or die('Threads support needed.'); 6 | } 7 | use strict;use warnings; 8 | use threads; 9 | use threads::shared; 10 | $|++; 11 | my $i=0; 12 | my $counter:shared = 0; 13 | my @threads; 14 | while ($i<6){ 15 | 16 | threads->create(\&a_thread)->join ; 17 | threads->new(\&a_thread)->join ; 18 | $i++; 19 | } 20 | 21 | exit; 22 | sub a_thread { 23 | 24 | my $self = threads->self(); 25 | my $thread_id = $self->tid(); 26 | lock($counter); 27 | print '/','*'x 20,$/; 28 | print 'thread with id: '.$thread_id .$/; 29 | if($thread_id %2){ 30 | print 'changing $counter from '.$counter; 31 | sleep 2; 32 | $counter +=2; 33 | print ' to '.$counter,"($thread_id)",$/; 34 | }else{ 35 | print 'changing $counter from '.$counter; 36 | sleep 1; 37 | $counter ++; 38 | print ' to '.$counter,"($thread_id)",$/; 39 | } 40 | 41 | print '*'x 20,'/'.$/; 42 | } -------------------------------------------------------------------------------- /12_p_and_t/pipes.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # pipes.pl 3 | use warnings; 4 | use strict; 5 | pipe CREAD, PWRITE; # parent->child 6 | pipe PREAD, CWRITE; # child->parent 7 | my $message = "S"; 8 | if (fork) { 9 | # parent - close child end of pipes 10 | close CREAD; 11 | close CWRITE; 12 | syswrite PWRITE, "$message \n"; 13 | while () { 14 | chomp; 15 | print "Parent got $_ \n"; 16 | syswrite PWRITE, "P$_ \n"; 17 | sleep 1; 18 | } 19 | } else { 20 | # child - close parent end of pipes 21 | close PREAD; 22 | close PWRITE; 23 | while () { 24 | chomp; 25 | print "Child got $_ \n"; 26 | syswrite CWRITE, "C$_ \n"; 27 | } 28 | } 29 | #Example from "Professional Perl Programming/Chapter 22: Creating and Managing Processes" by Wrox Press Ltd. -------------------------------------------------------------------------------- /12_p_and_t/queues.pl: -------------------------------------------------------------------------------- 1 | use threads; 2 | use Thread::Queue; 3 | 4 | my $DataQueue = Thread::Queue->new(); 5 | my $thr = threads->create(sub { 6 | while (my $DataElement = $DataQueue->dequeue()) { 7 | print("Popped $DataElement off the queue\n"); 8 | } 9 | }); 10 | my $r={h=>4}; 11 | $DataQueue->enqueue(12); 12 | $DataQueue->enqueue("A", "B", "C"); 13 | sleep(3); 14 | $DataQueue->enqueue('D',$r,undef); 15 | $thr->join(); -------------------------------------------------------------------------------- /12_p_and_t/race_conditions.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | BEGIN { 3 | use Config; 4 | $Config{useithreads} 5 | or die('Threads support needed.'); 6 | } 7 | use strict;use warnings; 8 | use threads; 9 | use threads::shared; 10 | use Data::Dumper; 11 | $|++; 12 | my $i=0; 13 | my %hash:shared = (apple=>'green',lemon=>'yellow', 14 | counter=>0 15 | ); 16 | my @threads; 17 | while ($i<6){ 18 | sleep 1; 19 | push @threads, threads->create(\&a_thread,\%hash); 20 | push @threads, threads->new(\&a_thread,\%hash); 21 | $i++; 22 | } 23 | $_->join foreach @threads; 24 | print Dumper \%hash; 25 | exit; 26 | sub a_thread { 27 | my @params = @_; 28 | my $self = threads->self(); 29 | my $thread_id = $self->tid(); 30 | my $rv = ''; 31 | print '/','*'x 20,$/; 32 | $params[0]->{id} = $thread_id; 33 | if($thread_id %2){ 34 | my $j= threads->new(\&a_thread,$params[0]); 35 | $j->detach; 36 | #sleep 2; 37 | print $params[0]->{counter},$/; 38 | $params[0]->{counter} ++; 39 | print $params[0]->{counter},$/; 40 | }else{ 41 | #sleep 1; 42 | $params[0]->{apple}='yellow'; 43 | print $params[0]->{counter},$/; 44 | $params[0]->{counter} +=2; 45 | print $params[0]->{counter},$/; 46 | } 47 | 48 | print Dumper $params[0]; 49 | print 'thread with id '.$thread_id .$/; 50 | print '*'x 20,'/'.$/; 51 | } -------------------------------------------------------------------------------- /12_p_and_t/semaphores.pl: -------------------------------------------------------------------------------- 1 | use threads; 2 | use Thread::Semaphore; 3 | 4 | my $semaphore = Thread::Semaphore->new(); 5 | my $GlobalVariable :shared = 0; 6 | 7 | $thr1 = threads->create(\&sample_sub, 1); 8 | $thr2 = threads->create(\&sample_sub, 2); 9 | $thr3 = threads->create(\&sample_sub, 3); 10 | 11 | sub sample_sub { 12 | my $SubNumber = shift(@_); 13 | my $TryCount = 10; 14 | my $LocalCopy; 15 | sleep(1); 16 | while ($TryCount--) { 17 | #$semaphore->down(); 18 | $LocalCopy = $GlobalVariable; 19 | print("$TryCount tries left for sub $SubNumber (\$GlobalVariable is $GlobalVariable)\n"); 20 | sleep(2); 21 | $LocalCopy++; 22 | $GlobalVariable = $LocalCopy; 23 | #$semaphore->up(); 24 | } 25 | } 26 | 27 | $thr1->join(); 28 | $thr2->join(); 29 | $thr3->join(); -------------------------------------------------------------------------------- /12_p_and_t/sharing_data.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | BEGIN { 3 | use Config; 4 | $Config{useithreads} 5 | or die('Threads support needed.'); 6 | } 7 | use strict;use warnings; 8 | use threads; 9 | use threads::shared; 10 | use Data::Dumper; 11 | $|++; 12 | my $i=0; 13 | my %hash:shared = (apple=>'green',lemon=>'yellow', 14 | #uncomment 15 | #d=>{} 16 | ); 17 | my @threads; 18 | while ($i<6){ 19 | sleep 1; 20 | push @threads, threads->create(\&a_thread,\%hash,[localtime]); 21 | push @threads, threads->new(\&a_thread,\%hash,[localtime]); 22 | $i++; 23 | } 24 | $_->join foreach @threads; 25 | print Dumper \%hash; 26 | exit; 27 | sub a_thread { 28 | my @params = @_; 29 | my $self = threads->self(); 30 | my $thread_id = $self->tid(); 31 | my $rv = ''; 32 | $params[0]->{id} = $thread_id; 33 | if($thread_id %2){ 34 | sleep 2; 35 | $params[0]->{apple}='red'; 36 | }else{ 37 | sleep 1; 38 | $params[0]->{apple}='yellow'; 39 | #$params[0]->{d}={}; 40 | } 41 | print '/','*'x 20,$/; 42 | print Dumper $params[0]; 43 | print 'thread with id '.$thread_id .$/, 44 | sprintf(' Time is: %02d:%02d:%02d'.$/, 45 | $params[-1]->[2],$params[-1]->[1],$params[-1]->[0]); 46 | print '*'x 20,'/'.$/; 47 | } -------------------------------------------------------------------------------- /12_p_and_t/threads_management.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | BEGIN { 3 | use Config; 4 | $Config{useithreads} 5 | or die('Threads support needed.'); 6 | } 7 | use strict;use warnings; 8 | use threads; 9 | $|++; 10 | 11 | my $odd = threads->create(\&a_thread,[localtime]); 12 | print $odd->join,$/; 13 | my $even = threads->new(\&a_thread,[localtime]); 14 | print $even->join,$/; 15 | 16 | exit; 17 | sub a_thread { 18 | my @params = @_; 19 | my $self = threads->self(); 20 | my $thread_id = $self->tid(); 21 | my $rv = ''; 22 | 23 | $rv .= 'thread with id '.$thread_id ; 24 | 25 | $rv .= sprintf(' Time is: %02d:%02d:%02d'.$/, 26 | $params[-1]->[2],$params[-1]->[1],$params[-1]->[0]); 27 | 28 | return $rv; 29 | } -------------------------------------------------------------------------------- /12_p_and_t/threads_management2.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | BEGIN { 3 | use Config; 4 | $Config{useithreads} 5 | or die('Threads support needed.'); 6 | } 7 | use strict;use warnings; 8 | use threads; 9 | $|++; 10 | my $i=0; 11 | while ($i<30){ 12 | sleep 1; 13 | my $odd = threads->create(\&a_thread,[localtime]); 14 | $odd->detach; 15 | my $even = threads->new(\&a_thread,[localtime]); 16 | $even->detach; 17 | $i++; 18 | } 19 | exit; 20 | sub a_thread { 21 | my @params = @_; 22 | my $self = threads->self(); 23 | my $thread_id = $self->tid(); 24 | my $rv = ''; 25 | if($thread_id %2){ 26 | sleep $thread_id; 27 | } 28 | $rv .= 'thread with id '.$thread_id ; 29 | $rv .= sprintf(' Time is: %02d:%02d:%02d'.$/, 30 | $params[-1]->[2],$params[-1]->[1],$params[-1]->[0]); 31 | print $rv; 32 | } -------------------------------------------------------------------------------- /12_p_and_t/threads_management3.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | BEGIN { 3 | use Config; 4 | $Config{useithreads} 5 | or die('Threads support needed.'); 6 | } 7 | use strict;use warnings; 8 | use threads; 9 | $|++; 10 | my $i=0; 11 | my @threads = (); 12 | while ($i<30){ 13 | push @threads, threads->create(\&a_thread,[localtime]); 14 | push @threads, threads->new(\&a_thread,[localtime]); 15 | $i++; 16 | } 17 | #uncomment and run again 18 | #print $_->join foreach @threads; 19 | 20 | exit; 21 | sub a_thread { 22 | my @params = @_; 23 | my $self = threads->self(); 24 | my $thread_id = $self->tid(); 25 | my $rv = ''; 26 | if($thread_id %2){ 27 | sleep $thread_id; 28 | } 29 | print 'thread with id '.$thread_id .$/; 30 | $rv .= sprintf(' Time is: %02d:%02d:%02d'.$/, 31 | $params[-1]->[2],$params[-1]->[1],$params[-1]->[0]); 32 | return $rv; 33 | } -------------------------------------------------------------------------------- /12_processes_and_threads.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/12_processes_and_threads.odp -------------------------------------------------------------------------------- /13_net.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/13_net.odp -------------------------------------------------------------------------------- /13_net/MyMech.pm: -------------------------------------------------------------------------------- 1 | package MyMech; 2 | use Data::Dumper; 3 | use base qw(WWW::Mechanize); 4 | use HTML::TreeBuilder; 5 | 6 | #the root url 7 | our $url = 'http://www.gsmarena.com/'; 8 | our $Config = { 9 | 10 | DEBUG => 1, 11 | agent_alias => 'Windows IE 6', 12 | onerror => \&Carp::croak, 13 | onwarn => \&Carp::carp(), 14 | cookie_jar => {}, 15 | autocheck => 1, 16 | agent => 17 | "Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.0.3) Gecko/20060425 SUSE/1.5.0.3-7 Firefox/1.5.0.3", 18 | 19 | #urls to listViews of phones 20 | #1.go to listView for each brand 21 | phones_urls => { 22 | 23 | #'BENQ-SIEMENS' => $url . 'benq_siemens-phones-42.php', 24 | NOKIA => $url . 'nokia-phones-1.php', 25 | SIEMENS => $url . 'siemens-phones-3.php', 26 | 27 | #MOTOROLA => $url . 'motorola-phones-4.php', 28 | #ALCATEL => $url . 'alcatel-phones-5.php', 29 | #PANASONIC => $url . 'panasonic-phones-6.php', 30 | SONY => $url . 'sony-phones-7.php', 31 | 32 | #BOSCH => $url . 'bosch-phones-10.php', 33 | #SAGEM => $url . 'sagem-phones-13.php', 34 | 35 | #SAMSUNG => $url . 'samsung-phones-9.php', 36 | #'SONY ERICSSON' => $url . 'sony_ericsson-phones-19.php', 37 | }, 38 | 39 | #each regex will collect an array of links to singleViwes 40 | #2. go to singleView for each model 41 | phones_url_regexes => { 42 | 43 | #'BENQ-SIEMENS' => 'benq_siemens_', 44 | NOKIA => 'nokia_\w+(_sport)?-\w+\.php', 45 | SIEMENS => 'siemens_\w+-\w+\.php', 46 | 47 | #MOTOROLA => 'motorola_.*\d{3,}\.php', 48 | #ALCATEL => 'alcatel_ot_\w+-\w+\.php', 49 | #PANASONIC => 'panasonic_\w+-\w+\.php', 50 | SONY => 'sony_cmd_', 51 | 52 | #BOSCH => 'bosch_com_\w+-\w+\.php', 53 | #SAGEM => 'sagem_', 54 | #SAMSUNG => 'samsung_\w+-\w+\.php', 55 | #'SONY ERICSSON' => 'sony_ericsson_\w+-\w+\.', 56 | }, 57 | 58 | #select the main small image 59 | #3. download the image 60 | }; 61 | our $phictionary = { #;) PHONE DICTIONARY 62 | No => 0, 63 | Yes => 1, 64 | Polyphonic => 'Полифонични', 65 | channels => 'канални ', 66 | colors => 'цвята', 67 | }; 68 | our $page = {}; 69 | 70 | #this will be assigned to $tx_phones 71 | 72 | 73 | =item get_phone_images 74 | 75 | saves the gif images urls on disk 76 | 77 | =cut 78 | 79 | sub get_phone_images { 80 | my $self = shift; 81 | my @images = @_; 82 | my $filename; 83 | foreach my $i (@images) { 84 | 85 | #print "\t".$i->url().$/ ; 86 | $i->url_abs() =~ /\/([^\/]+\.gif)$/i; 87 | $filename = $1; 88 | next if ($filename =~ /spacer\.gif/); 89 | 90 | # print "\t".'filename: '.$1.$/; 91 | $page->{image} = $filename; 92 | unless (-e './img/' . $filename) { 93 | $self->get($i->url_abs(), ":content_file" => './img/' . $filename); 94 | print "\t" . 'fetched: ' . $filename . $/; 95 | sleep 1; 96 | } 97 | else { 98 | print "\t" . 'file : ' . $filename . ' exists, skipping...' . $/; 99 | } 100 | } #endof @images loop 101 | 102 | return $self; 103 | } 104 | 105 | =item parse_page_content 106 | 107 | Gets the content of the page and parse it in to nice struct... 108 | The structure corresponds to the table fields in tx_phones 109 | this struct will be then inserted into the database using SQL::Abstract. 110 | Returns the struct. 111 | 112 | =cut 113 | 114 | sub parse_page_content { 115 | my $self = shift; 116 | %args = @_; 117 | 118 | # my $format =$args{format}|| 119 | my $content = $self->content(); 120 | my $root = HTML::TreeBuilder->new_from_content($content); 121 | 122 | #$root->parse($content); 123 | $root->eof(); # done parsing for this tree 124 | my $temp_page = {}; 125 | 126 | # here is the first place wheere we store data from the html 127 | # it is then searched and filtered so the values from it 128 | # can go to $page and $tx_phones 129 | $temp_page->{image} = $page->{image}; 130 | my $tx_phones; 131 | 132 | foreach my $h1 ($root->find_by_tag_name('h1')) { 133 | $temp_page->{title} = $h1->as_trimmed_text; 134 | $h1->delete; 135 | sleep 1; 136 | print $temp_page->{title} . $/; 137 | last; 138 | } 139 | my ($th_key, $temp_key, $count) = ('', '', 0); 140 | foreach my $table ($root->find_by_tag_name('table')) { 141 | print 'table ' . $count; 142 | foreach my $th ($table->find_by_tag_name('th')) { 143 | $th_key = $th->as_trimmed_text if $th->attr('scope'); 144 | } 145 | foreach my $td ($table->find_by_tag_name('td')) { 146 | 147 | #fillin a table with keys and values from td class tt1 and td class nfo 148 | if ($td->attr('class') eq 'ttl') { 149 | $temp_key = $td->as_trimmed_text; 150 | next; 151 | } 152 | if ($td->attr('class') eq 'nfo') { 153 | if ($temp_key =~ /\w/) { 154 | $temp_page->{$th_key}{$temp_key} = $td->as_trimmed_text; 155 | } 156 | else { 157 | $temp_page->{$th_key}{'_'} = $td->as_trimmed_text; 158 | 159 | } 160 | next; 161 | } 162 | 163 | #print $td->as_trimmed_text.$/.'----------------'.$/.$td->as_HTML.$/.'----------------'.$/; 164 | } #endof $td loop 165 | $count++; 166 | } #endof $table 167 | if (ref $temp_page) { 168 | print Dumper($temp_page); 169 | 170 | } 171 | $root->dump if $Config->{DEBUG}; # print( ) a representation of the tree 172 | $root->delete; # erase this tree because we're done with it 173 | 174 | #returns the parsed page 175 | return $temp_page; 176 | } 177 | 178 | 1; 179 | 180 | -------------------------------------------------------------------------------- /13_net/io-socket-tcp-client.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use IO::Socket; 4 | my ($host, $port, $path) = ( 5 | 'localhost', 6 | 8088, 7 | 8 | #'bulgarian-creative-circle.org', 9 | #80, 10 | '/slides/13_net/io-socket-response.txt' 11 | ); 12 | 13 | my $sock = IO::Socket::INET->new( 14 | PeerAddr => $host, 15 | PeerPort => $port, 16 | Proto => 'tcp', 17 | Timeout => 1 18 | ) or die $@; 19 | 20 | #or just 21 | #my $sock = IO::Socket::INET->new("$host:$port"); 22 | #$sock->autoflush; #like $| = 1 -- turned on by default 23 | 24 | die "Could not connect to $host$/" 25 | unless $sock->connected; 26 | 27 | if ($host !~ /localhost/) { 28 | 29 | # communicate with the server 30 | my $location = $host; 31 | $location .= ":$port" if $port != 80; 32 | print "Server says: ", print $sock->getline; 33 | 34 | #get default page 35 | $sock->print( 36 | join("\015\012", 37 | "GET $path HTTP/1.1", 38 | "Host:$location", "User-Agent:IO::Socket/$IO::Socket::VERSION ($^O)", 39 | "", "") 40 | ); 41 | print $sock->getlines; 42 | 43 | } 44 | else { 45 | # communicate with the server 46 | print "Client connected.\n"; 47 | print "Server says: ", $sock->getline; 48 | $sock->print("Hello from the client!\n"); 49 | $sock->print("And goodbye!\n"); 50 | 51 | } 52 | $sock->close or die $!; 53 | 54 | 55 | -------------------------------------------------------------------------------- /13_net/io-socket-tcp-server-nofork.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | # nonforker - server who multiplexes without forking 3 | use POSIX; 4 | use IO::Socket; 5 | use IO::Select; 6 | use Socket; 7 | use Fcntl; 8 | use Tie::RefHash; 9 | 10 | #use strict; 11 | $port = 8088; # change this at will 12 | $|++; 13 | 14 | # Listen to port. 15 | $server = IO::Socket::INET->new( 16 | LocalAddr => 'localhost', 17 | LocalPort => $port, 18 | Listen => 10, 19 | ReuseAddr => 1 20 | ) or die "Can't make server socket: $@\n"; 21 | 22 | # begin with empty buffers 23 | %inbuffer = (); 24 | %outbuffer = (); 25 | %ready = (); 26 | 27 | tie %ready, 'Tie::RefHash'; 28 | 29 | #nonblock($server); 30 | $select = IO::Select->new($server); 31 | 32 | # Main loop: check reads/accepts, check writes, check ready to process 33 | while (1) { 34 | my $client; 35 | my $rv; 36 | my $data; 37 | 38 | # check for new information on the connections we have 39 | 40 | # anything to read or accept? 41 | foreach $client ($select->can_read(1)) { 42 | 43 | if ($client == $server) { 44 | 45 | # accept a new connection 46 | 47 | $client = $server->accept(); 48 | $select->add($client); 49 | nonblock($client); 50 | } 51 | else { 52 | # read data 53 | $data = ''; 54 | $rv = $client->recv($data, POSIX::BUFSIZ, 0); 55 | 56 | unless (defined($rv) && length $data) { 57 | 58 | # This would be the end of file, so close the client 59 | delete $inbuffer{$client}; 60 | delete $outbuffer{$client}; 61 | delete $ready{$client}; 62 | 63 | $select->remove($client); 64 | close $client; 65 | next; 66 | } 67 | 68 | $inbuffer{$client} .= $data; 69 | 70 | # test whether the data in the buffer or the data we 71 | # just read means there is a complete request waiting 72 | # to be fulfilled. If there is, set $ready{$client} 73 | # to the requests waiting to be fulfilled. 74 | while ($inbuffer{$client} =~ s/(.*\n)//) { 75 | push(@{$ready{$client}}, $1); 76 | } 77 | } 78 | } 79 | 80 | # Any complete requests to process? 81 | foreach $client (keys %ready) { 82 | handle($client); 83 | } 84 | 85 | # Buffers to flush? 86 | foreach $client ($select->can_write(1)) { 87 | 88 | # Skip this client if we have nothing to say 89 | next unless exists $outbuffer{$client}; 90 | 91 | $rv = $client->send($outbuffer{$client}, 0); 92 | unless (defined $rv) { 93 | 94 | # Whine, but move on. 95 | warn "I was told I could write, but I can't.\n"; 96 | next; 97 | } 98 | if ( $rv == length $outbuffer{$client} 99 | || $! == POSIX::EWOULDBLOCK) 100 | { 101 | substr($outbuffer{$client}, 0, $rv) = ''; 102 | delete $outbuffer{$client} unless length $outbuffer{$client}; 103 | } 104 | else { 105 | # Couldn't write all the data, and it wasn't because 106 | # it would have blocked. Shutdown and move on. 107 | delete $inbuffer{$client}; 108 | delete $outbuffer{$client}; 109 | delete $ready{$client}; 110 | 111 | $select->remove($client); 112 | close($client); 113 | next; 114 | } 115 | } 116 | 117 | # Out of band data? 118 | foreach $client ($select->has_exception(0)) { # arg is timeout 119 | 120 | # Deal with out-of-band data here, if you want to. 121 | } 122 | } 123 | 124 | # handle($socket) deals with all pending requests for $client 125 | sub handle { 126 | 127 | # requests are in $ready{$client} 128 | # send output to $outbuffer{$client} 129 | my $client = shift; 130 | my $request; 131 | 132 | foreach $request (@{$ready{$client}}) { 133 | 134 | # $request is the text of the request 135 | # put text of reply into $outbuffer{$client} 136 | print $request; 137 | $outbuffer{$client} = 'lllllll'; 138 | } 139 | delete $ready{$client}; 140 | } 141 | 142 | # nonblock($socket) puts socket into nonblocking mode 143 | sub nonblock { 144 | my $socket = shift; 145 | my $flags; 146 | 147 | $flags = fcntl($socket, F_GETFL, 0) 148 | or die "Can't get flags for socket: $!\n"; 149 | fcntl($socket, F_SETFL, $flags | O_NONBLOCK) 150 | or die "Can't make socket nonblocking: $!\n"; 151 | } 152 | -------------------------------------------------------------------------------- /13_net/io-socket-tcp-server.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use IO::Socket; 4 | my ($host, $port, $path) = ('localhost', 8088); 5 | my $server = new IO::Socket::INET( 6 | LocalAddr => $host, 7 | LocalPort => $port, 8 | Proto => 'tcp', 9 | Listen => 10, 10 | Type => SOCK_STREAM, 11 | ReuseAddr => 1 12 | ); 13 | print "Server ($0) running on port $port...\n"; 14 | 15 | while (my $connection = $server->accept) { 16 | print "Client connected at ", scalar(localtime), "\n"; 17 | $connection->print("You're connected to the server!\n"); 18 | while (<$connection>) { 19 | print "Client says: $_"; 20 | } 21 | 22 | $connection->shutdown(2); 23 | print "Client disconnected\n"; 24 | } 25 | 26 | $server->close(); 27 | -------------------------------------------------------------------------------- /13_net/io-socket-udp-client.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use IO::Socket; 4 | my $host = 'localhost'; 5 | my $port = 4444; 6 | my $client = new IO::Socket::INET( 7 | PeerAddr => $host, 8 | PeerPort => $port, 9 | Timeout => 2, 10 | Proto => 'udp', 11 | ); 12 | $client->send("Hello from client") or die "Send: $!\n"; 13 | my $message; 14 | $client->recv($message, 1024, 0); 15 | print "Response was: $message\n"; 16 | 17 | 18 | #Based on example from "Professional Perl Programming/Chapter 23: Networking with Perl" by Wrox Press Ltd. 19 | -------------------------------------------------------------------------------- /13_net/io-socket-udp-server.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use warnings; 3 | use strict; 4 | use IO::Socket; 5 | my $port = 4444; 6 | my $server = new IO::Socket::INET( 7 | LocalPort => $port, 8 | Proto => 'udp', 9 | ); 10 | die "Bind failed: $!\n" unless $server; 11 | print "Server running on port $port...\n"; 12 | my $message; 13 | 14 | while (my $client = $server->recv($message, 1024, 0)) { 15 | my ($port, $ip) = unpack_sockaddr_in($client); 16 | my $host = gethostbyaddr($ip, AF_INET); 17 | print "Client $host:$port sent '$message' at ", scalar(localtime), "\n"; 18 | $server->send("Message '$message' received", 0, $client); 19 | } 20 | 21 | #Based on example from "Professional Perl Programming/Chapter 23: Networking with Perl" by Wrox Press Ltd. 22 | -------------------------------------------------------------------------------- /13_net/io-socket-uds-client.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use IO::Socket; 4 | my $server = IO::Socket::UNIX->new(Peer => "./udssock",) or die $@; 5 | 6 | # communicate with the server 7 | print "Client connected.\n"; 8 | print "Server says: ", $server->getline; 9 | $server->print("Hello from the client!\n"); 10 | $server->print("And goodbye!\n"); 11 | $server->close; 12 | 13 | 14 | #Based on example from "Professional Perl Programming/Chapter 23: Networking with Perl" by Wrox Press Ltd. 15 | -------------------------------------------------------------------------------- /13_net/io-socket-uds-server.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use IO::Socket; 4 | my $file = "./udssock"; 5 | unlink $file; 6 | my $server = IO::Socket::UNIX->new( 7 | Local => $file, 8 | Type => SOCK_STREAM, 9 | Listen => 5 10 | ) or die $@; 11 | 12 | print "Server running on file $file...\n"; 13 | while (my $connection = $server->accept) { 14 | $connection->print("You're connected to the server!\n"); 15 | while (<$connection>) { 16 | print "Client says: $_\n"; 17 | } 18 | $connection->close; 19 | } 20 | 21 | #Based on example from "Professional Perl Programming/Chapter 23: Networking with Perl" by Wrox Press Ltd. 22 | -------------------------------------------------------------------------------- /13_net/smtp.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use warnings; 4 | use Net::SMTP; 5 | use Data::Dumper; 6 | my $smtp = Net::SMTP->new( 7 | Host => 'localhost', 8 | Timeout => 30, 9 | Hello => 'localhost', 10 | ); 11 | my $from = 'berov@bulgarian-creative-circle.org'; 12 | my @to = ('k.berov@gmail.com',); 13 | my $text = $ARGV[0] || 'проба'; 14 | my $mess = "ERROR: Can't send mail using Net::SMTP. "; 15 | 16 | $smtp->mail($from) || die $mess; 17 | $smtp->to(@to, {SkipBad => 1}) || die $mess; 18 | $smtp->data($text) || die $mess; 19 | $smtp->dataend() || die $mess; 20 | $smtp->quit(); 21 | 22 | #print $dumper->Dump([$smtp],['$smtp']); 23 | 24 | -------------------------------------------------------------------------------- /13_net/socket-tcp-client.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # tcpinetclient.pl 3 | use warnings; 4 | use strict; 5 | use Socket; 6 | my $proto = getprotobyname('tcp'); 7 | my $host = inet_aton('localhost'); 8 | my $port = 8088; 9 | 10 | # Create 'sockaddr_in' structure to connect to the given 11 | # port on the IP address for the remote host 12 | my $servaddr = sockaddr_in($port, $host); 13 | 14 | # Create a socket for connecting on 15 | socket SERVER, PF_INET, SOCK_STREAM, $proto 16 | or die "Unable to create socket: $!"; 17 | 18 | # bind the socket to the local port and address 19 | connect SERVER, $servaddr or die "Unable to connect: $!"; 20 | 21 | # enable autoflush 22 | select SERVER; 23 | $| = 1; 24 | select STDOUT; 25 | 26 | # communicate with the server 27 | print "Client connected.\n"; 28 | print "Server says: ", scalar(); 29 | print SERVER "Hello from the client!\n"; 30 | print SERVER "And goodbye!\n"; 31 | close SERVER; 32 | 33 | #Example script from "Professional Perl Programming/Chapter 23: Networking with Perl" by Wrox Press Ltd. 34 | 35 | -------------------------------------------------------------------------------- /13_net/socket-tcp-server.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Socket; 4 | my ($host, $port, $proto) = ('localhost', 8088,); 5 | 6 | $proto = getprotobyname('tcp'); 7 | 8 | # Create 'sockaddr_in' structure to listen to the given port 9 | # on any locally available IP address 10 | my $servaddr = sockaddr_in($port, INADDR_ANY); 11 | 12 | # Create a socket for listening on 13 | socket SERVER, PF_INET, SOCK_STREAM, $proto 14 | or die "Unable to create socket: $!"; 15 | 16 | # bind the socket to the local port and address 17 | bind SERVER, $servaddr or die "Unable to bind: $!"; 18 | 19 | # listen to the socket to allow it to receive connection requests 20 | # allow up to 10 requests to queue up at once. 21 | listen SERVER, 10; 22 | 23 | # now accept connections 24 | print "Server running on port $port...\n"; 25 | while (accept CONNECTION, SERVER) { 26 | select CONNECTION; 27 | $| = 1; 28 | select STDOUT; 29 | print "Client connected at ", scalar(localtime), "\n"; 30 | print CONNECTION "You're connected to the server!\n"; 31 | while () { 32 | print "Client says: $_\n"; 33 | } 34 | close CONNECTION; 35 | print "Client disconnected\n"; 36 | } 37 | 38 | #Example script from "Professional Perl Programming/Chapter 23: Networking with Perl" by Wrox Press Ltd. 39 | 40 | -------------------------------------------------------------------------------- /13_net/www_mech.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use warnings; 4 | use MyMech; 5 | use Data::Dumper; 6 | 7 | #Config 8 | $MyMech::Config->{DEBUG} = 0; 9 | my $Config = $MyMech::Config; 10 | 11 | #print Dumper($Config); 12 | my $mech = MyMech->new( 13 | agent => $Config->{agent}, 14 | cookie_jar => $Config->{cookie_jar}, 15 | autocheck => $Config->{autocheck}, 16 | onwarn => $Config->{onwarn} 17 | ); 18 | 19 | #$mech->agent_alias($Config->{agent_alias}); 20 | 21 | my $Parsed_Site = {}; 22 | print "OK.$/ Conection to $MyMech::url established" . $/ 23 | if ($mech->get($MyMech::url)); 24 | sleep 1; 25 | 26 | #go to listView for each brand 27 | foreach (reverse sort keys %{$Config->{phones_urls}}) { 28 | print "OK.$/ we got $_ " . $/ if $mech->get($Config->{phones_urls}{$_}); 29 | sleep 1; 30 | print $/; 31 | 32 | #get the lins for singleViews 33 | my @links; 34 | @links = @{$mech->links}; 35 | foreach my $l (@links) { 36 | my $page_url = $l->url(); 37 | if ($page_url =~ qr/$Config->{phones_url_regexes}{$_}/) { 38 | print 'Link: ' . $page_url . ' let us go there! ' . $/; 39 | sleep 1; 40 | print 'Hurray, there we are ' . $/ if $mech->get($l->url_abs()); 41 | sleep 1; 42 | 43 | # print " Now we need the image, right? ".$/; 44 | print 'What are the images on this page? ' . $/; 45 | my @images; 46 | @images = $mech->find_all_images(tag => 'img', url_regex => qr/gif$/i); 47 | 48 | #get the images 49 | $mech->get_phone_images(@images); 50 | 51 | #let us get the content of the page and parse it into nice struct... 52 | $Parsed_Site->{$page_url} = $mech->parse_page_content(); 53 | 54 | # save individual dump to afile 55 | open PAGE, '>www.gsmarena.com/' . $page_url . '.dump' 56 | or die 'can not open file...' . $!; 57 | print PAGE Dumper($Parsed_Site->{$page_url}); 58 | close PAGE; 59 | 60 | } #endof phones_url_regexes 61 | } #endof links loop 62 | } #endof phones_urls loop; 63 | 64 | open SITE, '>www.gsmarena.com.dump'; 65 | print SITE Dumper($Parsed_Site); 66 | close SITE; 67 | -------------------------------------------------------------------------------- /14_sysadmin.odp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/14_sysadmin.odp -------------------------------------------------------------------------------- /14_sysadmin/filesed.txt: -------------------------------------------------------------------------------- 1 | -p 2 | 3 | causes Perl to assume the following loop around your program, 4 | which makes it iterate over filename arguments somewhat like sed: 5 | 6 | LINE: 7 | while (<>) { 8 | ... # your program goes here 9 | } continue { 10 | print or die "-p destination: $!\n"; 11 | } 12 | 13 | If a file named by an argument cannot be opened for some reason, 14 | Perl warns you about it, and moves on to the next file. 15 | Note that the lines are printed automatically. 16 | An error occurring during printing is treated as fatal. 17 | To suppress printing use the -n switch. 18 | A -p overrides a -n switch. 19 | 20 | BEGIN and END blocks may be used to capture control before or 21 | after the implicit loop, just as in awk. -------------------------------------------------------------------------------- /14_sysadmin/original.txt: -------------------------------------------------------------------------------- 1 | −i[extension] 2 | specifies that files processed by the "<>" construct are to be edited 3 | in−place. It does this by renaming the input file, opening the output file 4 | by the original name, and selecting that output file as the default for 5 | print() statements. The extension, if supplied, is used to modify the name 6 | of the old file to make a backup copy, following these rules: 7 | 8 | If no extension is supplied, no backup is made and the current file is over‐ 9 | written. 10 | 11 | If the extension doesn’t contain a "*", then it is appended to the end of the 12 | current filename as a suffix. If the extension does contain one or more "*" 13 | characters, then each "*" is replaced with the current filename. In Perl 14 | terms, you could think of this as: 15 | 16 | ($backup = $extension) =~ s/\*/$file_name/g; 17 | 18 | This allows you to add a prefix to the backup file, instead of (or in addi‐ 19 | tion to) a suffix: 20 | 21 | $ perl ‐pi’orig_*’ ‐e ’s/bar/baz/’ fileA # backup to ’orig_fileA’ 22 | 23 | Or even to place backup copies of the original files into another directory 24 | (provided the directory already exists): 25 | 26 | $ perl ‐pi’old/*.orig’ ‐e ’s/bar/baz/’ fileA # backup to ’old/fileA.orig’ 27 | 28 | These sets of one‐liners are equivalent: 29 | 30 | $ perl ‐pi ‐e ’s/bar/baz/’ fileA # overwrite current file 31 | $ perl ‐pi’*’ ‐e ’s/bar/baz/’ fileA # overwrite current file 32 | 33 | $ perl ‐pi’.orig’ ‐e ’s/bar/baz/’ fileA # backup to ’fileA.orig’ 34 | $ perl ‐pi’*.orig’ ‐e ’s/bar/baz/’ fileA # backup to ’fileA.orig’ 35 | 36 | From the shell, saying 37 | 38 | $ perl ‐p ‐i.orig ‐e "s/foo/bar/; ... " 39 | 40 | is the same as using the program: 41 | 42 | #!/usr/bin/perl ‐pi.orig 43 | s/foo/bar/; 44 | -------------------------------------------------------------------------------- /14_sysadmin/sed.pl: -------------------------------------------------------------------------------- 1 | :P -------------------------------------------------------------------------------- /Linus: -------------------------------------------------------------------------------- 1 | I was in a coffee shop in Portland, Oregon and happened to spot Linus Torvalds sitting alone at a window table. I asked the creator of the Linux operating system and the Git source code control system if I could join him. Over the next fifteen minutes we talked about programming and programmers. 2 | 3 | Typical Programmer: It’s been 20 years since Linux was released. Now it’s one of the most widely-used operating systems. How does that make you feel? 4 | 5 | Linus Torvalds: Surprised, frankly. It was a hobby project I didn’t expect to do much with. As interest in Linux grew I saw it used mainly by the hardcore programmers and computer geeks to separate themselves from the herd. There are a lot of people in the software industry who like to show off that they’re using the latest software or programming language. It’s a status thing, like the people who talk about obscure indie bands or foreign movies. Whether it’s Linux or Haskell or MongoDB or whatever, every workplace has at least one guy who spends most of his time talking about closures and how he is moving his blog to NodeJS so it will scale. 6 | 7 | Linux is mainstream now. Did it get too easy? 8 | 9 | I don’t think it’s any easier, but there are a lot more resources now. In most ways Linux is more complicated to learn and use than Windows or MacOS. The people using it for servers were already used to Unix so it was no big change for them. They were used to conflicting updates and dependencies and shared library hell. On the desktop I think people lost interest after a few years. 10 | 11 | Lost interest? 12 | 13 | No one is excited anymore about transparent console windows or Kate color schemes or being the first to post on Slashdot how to get some weird sound card to work. That’s what got the early adopters to switch from Windows to Linux. Now Linux looks like Windows. I can install Ubuntu on my grandmother’s laptop and she wouldn’t know the difference, as long as there’s a Facebook icon on the screen. 14 | 15 | What about all of the Linux distros out there? It seems like there are more distros than Linux desktop users. 16 | 17 | There are more Linux distros on a single Linux Format disc than Microsoft has versions of Windows. But they’re all pretty much the same thing warmed over. Only the clever and cute names distinguish one distro from another. Once a Linux For Dummies book was published I started to lose interest in it. 18 | You released the Git distributed version control system less than ten years ago. Git caught on quickly and seems to be the dominant source code control system, or at least the one people argue about most on Reddit and Hacker News. 19 | 20 | Git has taken over where Linux left off separating the geeks into know-nothings and know-it-alls. I didn’t really expect anyone to use it because it’s so hard to use, but that turns out to be its big appeal. No technology can ever be too arcane or complicated for the black t-shirt crowd. 21 | 22 | I thought Subversion was hard to understand. I haven’t wrapped my head around Git yet. 23 | 24 | You’ll spend a lot of time trying to get your head around it, and being ridiculed by the experts on github and elsewhere. I’ve learned that no toolchain can be too complicated because the drive for prestige and job security is too strong. Eventually you’ll discover the Easter egg in Git: all meaningful operations can be expressed in terms of the rebase command. Once you figure that out it all makes sense. I thought the joke would be obvious: rebase, freebase, as in what was Linus smoking? But programmers are an earnest and humorless crowd and the gag was largely lost on them. 25 | 26 | What do you think of github? 27 | 28 | It started as a place for mothballing unmaintained and unnecessary projects, and that is still most of what is hosted there. But it’s turned into a kind of World of Warcraft universe for programmers, where they are ranked by their commits and which projects they have trunk privileges on. I read about a recruiting company built around the idea that github reputation means something, so I guess if you aren’t committing to github you won’t be getting a job at the coolest startups. The good old days of writing FizzBuzz and moving Mt. Fuji during your interview are over. 29 | 30 | It sounds like you’ve soured a little on Git. 31 | 32 | The first Git For Dummies and Git Visual Quickstart books are going to be out in a couple of months, and that is the beginning of the end as far as I’m concerned. Those books mean the end of git expertise and github reputation as reliable indicators of geek status. Once a technology is adopted by the masses the extreme geeks find something more esoteric. Look at what happened to Ruby on Rails. The people stumbling their way through Rails to-do list tutorials have never even heard of DHH. 33 | 34 | So what’s next? 35 | 36 | I’m not sure. It’s getting hard to predict the next technology fashion. I have a text editor I’ve been using myself that is so complicated it makes VIM look like Notepad — maybe I’ll release that. 37 | 38 | Linus finished his coffee and had to leave. I appreciate his time and for making me think about Linux and Git in new ways. 39 | -------------------------------------------------------------------------------- /Linus~: -------------------------------------------------------------------------------- 1 | I was in a coffee shop in Portland, Oregon and happened to spot Linus Torvalds sitting alone at a window table. I asked the creator of the Linux operating system and the Git source code control system if I could join him. Over the next fifteen minutes we talked about programming and programmers. 2 | 3 | Typical Programmer: It’s been 20 years since Linux was released. Now it’s one of the most widely-used operating systems. How does that make you feel? 4 | 5 | Linus Torvalds: Surprised, frankly. It was a hobby project I didn’t expect to do much with. As interest in Linux grew I saw it used mainly by the hardcore programmers and computer geeks to separate themselves from the herd. There are a lot of people in the software industry who like to show off that they’re using the latest software or programming language. It’s a status thing, like the people who talk about obscure indie bands or foreign movies. Whether it’s Linux or Haskell or MongoDB or whatever, every workplace has at least one guy who spends most of his time talking about closures and how he is moving his blog to NodeJS so it will scale. 6 | 7 | Linux is mainstream now. Did it get too easy? 8 | 9 | I don’t think it’s any easier, but there are a lot more resources now. In most ways Linux is more complicated to learn and use than Windows or MacOS. The people using it for servers were already used to Unix so it was no big change for them. They were used to conflicting updates and dependencies and shared library hell. On the desktop I think people lost interest after a few years. 10 | 11 | Lost interest? 12 | 13 | No one is excited anymore about transparent console windows or Kate color schemes or being the first to post on Slashdot how to get some weird sound card to work. That’s what got the early adopters to switch from Windows to Linux. Now Linux looks like Windows. I can install Ubuntu on my grandmother’s laptop and she wouldn’t know the difference, as long as there’s a Facebook icon on the screen. 14 | 15 | What about all of the Linux distros out there? It seems like there are more distros than Linux desktop users. 16 | 17 | There are more Linux distros on a single Linux Format disc than Microsoft has versions of Windows. But they’re all pretty much the same thing warmed over. Only the clever and cute names distinguish one distro from another. Once a Linux For Dummies book was published I started to lose interest in it. 18 | You released the Git distributed version control system less than ten years ago. Git caught on quickly and seems to be the dominant source code control system, or at least the one people argue about most on Reddit and Hacker News. 19 | 20 | Git has taken over where Linux left off separating the geeks into know-nothings and know-it-alls. I didn’t really expect anyone to use it because it’s so hard to use, but that turns out to be its big appeal. No technology can ever be too arcane or complicated for the black t-shirt crowd. 21 | 22 | I thought Subversion was hard to understand. I haven’t wrapped my head around Git yet. 23 | 24 | You’ll spend a lot of time trying to get your head around it, and being ridiculed by the experts on github and elsewhere. I’ve learned that no toolchain can be too complicated because the drive for prestige and job security is too strong. Eventually you’ll discover the Easter egg in Git: all meaningful operations can be expressed in terms of the rebase command. Once you figure that out it all makes sense. I thought the joke would be obvious: rebase, freebase, as in what was Linus smoking? But programmers are an earnest and humorless crowd and the gag was largely lost on them. 25 | 26 | What do you think of github? 27 | 28 | It started as a place for mothballing unmaintained and unnecessary projects, and that is still most of what is hosted there. But it’s turned into a kind of World of Warcraft universe for programmers, where they are ranked by their commits and which projects they have trunk privileges on. I read about a recruiting company built around the idea that github reputation means something, so I guess if you aren’t committing to github you won’t be getting a job at the coolest startups. The good old days of writing FizzBuzz and moving Mt. Fuji during your interview are over. 29 | 30 | It sounds like you’ve soured a little on Git. 31 | 32 | The first Git For Dummies and Git Visual Quickstart books are going to be out in a couple of months, and that is the beginning of the end as far as I’m concerned. Those books mean the end of git expertise and github reputation as reliable indicators of geek status. Once a technology is adopted by the masses the extreme geeks find something more esoteric. Look at what happened to Ruby on Rails. The people stumbling their way through Rails to-do list tutorials have never even heard of DHH. 33 | 34 | So what’s next? 35 | 36 | I’m not sure. It’s getting hard to predict the next technology fashion. I have a text editor I’ve been using myself that is so complicated it makes VIM look like Notepad — maybe I’ll release that. 37 | 38 | Linus finished his coffee and had to leave. I appreciate his time and for making me think about Linux and Git in new ways. 39 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | PerlProgrammingCourse 2 | ===================== 3 | 4 | A relatively full beginner-to-intermediate Perl trainig course 5 | 6 | Perl Programming Course by Krasimir Berov is licensed under 7 | a Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported License. 8 | Based on works at www.perl.org/books/beginning-perl and perldoc.perl.org. 9 | Permissions beyond the scope of this license may be available from berov at cpan.org. -------------------------------------------------------------------------------- /img/180px-Multithreaded_process.svg.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/img/180px-Multithreaded_process.svg.png -------------------------------------------------------------------------------- /img/btv.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/img/btv.png -------------------------------------------------------------------------------- /img/cgi-ex-recipes.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/img/cgi-ex-recipes.png -------------------------------------------------------------------------------- /img/com-process.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/img/com-process.gif -------------------------------------------------------------------------------- /img/com-thread.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/img/com-thread.gif -------------------------------------------------------------------------------- /img/using_ppm.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kberov/PerlProgrammingCourse/b69e87caf1f8ebfab645880b17b1b386425a58fe/img/using_ppm.png -------------------------------------------------------------------------------- /lib/Data/Table.pm: -------------------------------------------------------------------------------- 1 | package Data::Table; 2 | BEGIN { die "Your perl version is old, see README for instructions" if $] < 5.005; } 3 | 4 | use strict; 5 | use vars qw($VERSION %DEFAULTS @ISA @EXPORT @EXPORT_OK); 6 | use Carp; 7 | 8 | require Exporter; 9 | require AutoLoader; 10 | 11 | @ISA = qw(Exporter AutoLoader); 12 | # Items to export into callers namespace by default. Note: do not export 13 | # names by default without a very good reason. Use EXPORT_OK instead. 14 | # Do not simply export all your public functions/methods/constants. 15 | @EXPORT = qw( 16 | 17 | ); 18 | $VERSION = '1.54'; 19 | %DEFAULTS = ( 20 | "CSV_DELIMITER"=>',', # controls how to read/write CSV file 21 | "CSV_QUALIFIER"=>'"', 22 | "OS"=>0 23 | # operatoring system: 0 for UNIX (\n as linebreak), 1 for Windows 24 | # (\r\n as linebreak), 2 for MAC (\r as linebreak) 25 | # this controls how to read and write CSV/TSV file 26 | ); 27 | 28 | sub new { 29 | my ($pkg, $data, $header, $type, $enforceCheck) = @_; 30 | my $class = ref($pkg) || $pkg; 31 | $type = 0 unless defined($type); 32 | $header=[] unless defined($header); 33 | $data=[] unless defined($data); 34 | $enforceCheck = 1 unless defined($enforceCheck); 35 | confess "new Data::Table: Size of data does not match header\n" 36 | if (($type && (scalar @$data) && $#{$data} != $#{$header}) || 37 | (!$type && (scalar @$data) && $#{$data->[0]} != $#{$header})); 38 | my $colHash = checkHeader($header); 39 | if ($enforceCheck && scalar @$data > 0) { 40 | my $size=scalar @{$data->[0]}; 41 | for (my $j =1; $j[$j]} == $size); 43 | } 44 | } elsif (scalar @$data == 0) { 45 | $type = 0; 46 | } 47 | my $self={ data=>$data, header=>$header, type=>$type, colHash=>$colHash}; 48 | return bless $self, $class; 49 | } 50 | 51 | sub checkHeader { 52 | my $header = shift; 53 | my $colHash = {}; 54 | for (my $i = 0; $i < scalar @$header; $i++) { 55 | my $elm = $header->[$i]; 56 | confess "Invalid column name (all digits): $elm at column ".($i+1) unless ($elm =~ /\D/); 57 | confess "Undefined column name (empty or all space) at column ".($i+1) unless $elm; 58 | #confess "Header name ".$colHash->{$elm}." appears more than once" if defined($colHash->{$elm}); 59 | if (defined($colHash->{$elm})) { 60 | confess "Header name ($elm) appears more than once: in column ".($colHash->{$elm}+1)." and column ".($i+1)."."; 61 | } 62 | $colHash->{$elm} = $i; 63 | } 64 | return $colHash; 65 | } 66 | 67 | # translate a column name into its position in the header 68 | # (also in column-based table) 69 | sub colIndex { 70 | my ($self, $colID) = @_; 71 | if ($colID =~ /\D/) { 72 | my $i = $self->{colHash}->{$colID}; 73 | return -1 unless defined($i); 74 | return $i; 75 | } 76 | return $colID; # assume an index already 77 | } 78 | 79 | sub nofCol { 80 | my $self = shift; 81 | return scalar @{$self->{header}}; 82 | } 83 | 84 | sub nofRow { 85 | my $self = shift; 86 | return 0 if (scalar @{$self->{data}} == 0); 87 | return ($self->{type})? 88 | scalar @{$self->{data}->[0]} : scalar @{$self->{data}}; 89 | } 90 | 91 | # still need to consider quotes and comma in string 92 | # need to get csv specification 93 | sub csvEscape { 94 | my ($s, $arg_ref) = @_; 95 | my ($delimiter, $qualifier) = ($Data::Table::DEFAULTS{CSV_DELIMITER}, $Data::Table::DEFAULTS{CSV_QUALIFIER}); 96 | $delimiter = $arg_ref->{'delimiter'} if (defined($arg_ref) && defined($arg_ref->{'delimiter'})); 97 | $qualifier = $arg_ref->{'qualifier'} if (defined($arg_ref) && defined($arg_ref->{'qualifier'})); 98 | return '' unless defined($s); 99 | my $qualifier2 = $qualifier; 100 | $qualifier2 = substr($qualifier, 1, 1) if length($qualifier)>1; # in case qualifier is a special symbol for regular expression 101 | $s =~ s/$qualifier/$qualifier2$qualifier2/g; 102 | if ($s =~ /[$qualifier$delimiter]/) { return "$qualifier2$s$qualifier2"; } 103 | return $s; 104 | } 105 | 106 | sub tsvEscape { 107 | my $s = shift; 108 | my %ESC = ( "\0"=>'0', "\n"=>'n', "\t"=>'t', "\r"=>'r', "\b"=>'b', 109 | "'"=>"'", "\""=>'"', "\\"=>'\\' ); 110 | ## what about \f? MySQL treats \f as f. 111 | return "\\N" unless defined($s); 112 | $s =~ s/([\0\\\b\r\n\t"'])/\\$ESC{$1}/g; 113 | return $s; 114 | } 115 | 116 | # output table in CSV format 117 | sub csv { 118 | my ($self, $header, $arg_ref)=@_; 119 | my ($status, @t); 120 | my $s = ''; 121 | my ($OS, $fileName_or_handler) = ($Data::Table::DEFAULTS{OS}, undef); 122 | $OS = $arg_ref->{'OS'} if (defined($arg_ref) && defined($arg_ref->{'OS'})); 123 | my ($delimiter, $qualifier) = ($Data::Table::DEFAULTS{CSV_DELIMITER}, $Data::Table::DEFAULTS{CSV_QUALIFIER}); 124 | if (defined($arg_ref)) { 125 | $delimiter = $arg_ref->{'delimiter'} if defined($arg_ref->{'delimiter'}); 126 | $qualifier = $arg_ref->{'qualifier'} if defined($arg_ref->{'qualifier'}); 127 | $fileName_or_handler = $arg_ref->{'file'} if defined($arg_ref->{'file'}); 128 | } 129 | my $delimiter2 = $delimiter; $delimiter2 = substr($delimiter, 1, 1) if length($delimiter)>1; 130 | my $endl = ($OS==2)?"\r":(($OS==1)?"\r\n":"\n"); 131 | $header=1 unless defined($header); 132 | $s=join($delimiter2, map {csvEscape($_, {delimiter=>$delimiter, qualifier=>$qualifier})} @{$self->{header}}) . $endl if $header; 133 | ###### $self->rotate if $self->{type}; 134 | if ($self->{data}) { 135 | $self->rotate() if ($self->{type}); 136 | my $data=$self->{data}; 137 | for (my $i=0; $i<=$#{$data}; $i++) { 138 | $s .= join($delimiter2, map {csvEscape($_, {delimiter=>$delimiter, qualifier=>$qualifier})} @{$data->[$i]}) . $endl; 139 | } 140 | } 141 | if (defined($fileName_or_handler)) { 142 | my $OUT; 143 | my $isFileHandler = ref($fileName_or_handler) ne ''; 144 | if ($isFileHandler) { 145 | $OUT = $fileName_or_handler; 146 | } else { 147 | open($OUT, "> $fileName_or_handler") or confess "Cannot open $fileName_or_handler to write.\n"; 148 | binmode $OUT; 149 | } 150 | print $OUT $s; 151 | close($OUT) unless $isFileHandler; 152 | } 153 | return $s; 154 | } 155 | 156 | # output table in TSV format 157 | sub tsv { 158 | my ($self, $header, $arg_ref)=@_; 159 | my ($status, @t); 160 | my $s = ''; 161 | my ($OS, $fileName_or_handler) = ($Data::Table::DEFAULTS{OS}, undef); 162 | $OS = $arg_ref->{'OS'} if (defined($arg_ref) && defined($arg_ref->{'OS'})); 163 | $fileName_or_handler = $arg_ref->{'file'} if (defined($arg_ref) && defined($arg_ref->{'file'})); 164 | my $endl = ($OS==2)?"\r":(($OS==1)?"\r\n":"\n"); 165 | $header=1 unless defined($header); 166 | $s=join("\t", map {tsvEscape($_)} @{$self->{header}}) . $endl if $header; 167 | ###### $self->rotate if $self->{type}; 168 | if ($self->{data}) { 169 | $self->rotate() if ($self->{type}); 170 | my $data=$self->{data}; 171 | for (my $i=0; $i<=$#{$data}; $i++) { 172 | $s .= join("\t", map {tsvEscape($_)} @{$data->[$i]}) . $endl; 173 | } 174 | } 175 | if (defined($fileName_or_handler)) { 176 | my $OUT; 177 | my $isFileHandler = ref($fileName_or_handler) ne ''; 178 | if ($isFileHandler) { 179 | $OUT = $fileName_or_handler; 180 | } else { 181 | open($OUT, "> $fileName_or_handler") or confess "Cannot open $fileName_or_handler to write.\n"; 182 | binmode $OUT; 183 | } 184 | print $OUT $s; 185 | close($OUT) unless $isFileHandler;; 186 | } 187 | return $s; 188 | } 189 | 190 | # output table in HTML format 191 | sub html { 192 | my ($self, $colors, $tag_tbl, $tag_tr, $tag_th, $tag_td, $portrait) = @_; 193 | my ($s, $s_tr, $s_td, $s_th) = ("", "tr", "", "th"); 194 | my $key; 195 | $tag_tbl = { border => 1 } unless (ref $tag_tbl eq 'HASH'); 196 | $tag_tr = {} unless (ref $tag_tr eq 'HASH'); 197 | $tag_th = {} unless (ref $tag_th eq 'HASH'); 198 | $tag_td = {} unless (ref $tag_td eq 'HASH'); 199 | $portrait = 1 unless defined($portrait); 200 | 201 | $s = "{$key}\""; 204 | } 205 | $s .= ">\n"; 206 | my $header=$self->{header}; 207 | my @BG_COLOR=("#D4D4BF","#ECECE4","#CCCC99"); 208 | @BG_COLOR=@$colors if ((ref($colors) eq "ARRAY") && (scalar @$colors==3)); 209 | foreach $key (keys %$tag_tr) { 210 | $s_tr .= " $key=\"$tag_tr->{$key}\""; 211 | } 212 | foreach $key (keys %$tag_th) { 213 | $s_th .= " $key=\"$tag_th->{$key}\""; 214 | } 215 | if ($portrait) { 216 | $s .= "<$s_tr bgcolor=\"" . $BG_COLOR[2] . "\"><$s_th>" . 217 | join("<$s_th>", @$header) . "\n"; 218 | $self->rotate() if $self->{type}; 219 | my $data=$self->{data}; 220 | for (my $i=0; $i<=$#{$data}; $i++) { 221 | $s .= "<$s_tr bgcolor=\"" . $BG_COLOR[$i%2] . "\">"; 222 | for (my $j=0; $j<=$#{$header}; $j++) { 223 | my $s_td = $tag_td->{$j} || $tag_td->{$header->[$j]}; 224 | $s .= defined($s_td)? ""; 227 | } 228 | $s .= "\n"; 229 | } 230 | } else { 231 | $self->rotate() unless $self->{type}; 232 | my $data=$self->{data}; 233 | for (my $i = 0; $i <= $#{$header}; $i++) { 234 | $s .= "<$s_tr><$s_th bgcolor=\"" . $BG_COLOR[2] . "\">" . 235 | $header->[$i] . ""; 236 | my $s_td = $tag_td->{$i} || $tag_td->{$header->[$i]}; 237 | for (my $j=0; $j<=$#{$data->[0]}; $j++) { 238 | $s .= defined($s_td)? ""; 242 | } 243 | $s .= "\n"; 244 | } 245 | } 246 | $s .= "
":""; 225 | $s .= (defined($data->[$i][$j]) && $data->[$i][$j] ne '')?$data->[$i][$j]:" "; 226 | $s .= "
"; 240 | $s .= (defined($data->[$i][$j]) && $data->[$i][$j] ne '')?$data->[$i][$j]:' '; 241 | $s .= "
\n"; 247 | return $s; 248 | } 249 | 250 | # output table in HTML format, with table orientation rotated, 251 | # so that each HTML table row is a column in the table 252 | # This is useful for a slim table (few columns but many rows) 253 | sub html2 { 254 | my ($self, $colors, $tag_tbl, $tag_tr, $tag_th, $tag_td) = @_; 255 | return $self->html($colors, $tag_tbl, $tag_tr, $tag_th, $tag_td, 0); 256 | } 257 | 258 | # apply a $fun to each elm in a col 259 | # function only has access to one element per row 260 | sub colMap { 261 | my ($self, $colID, $fun) = @_; 262 | my $c=$self->checkOldCol($colID); 263 | return undef unless defined $c; 264 | $self->rotate() unless $self->{type}; 265 | my $ref = $self->{data}->[$c]; 266 | my @tmp = map {scalar $fun->($_)} @$ref; 267 | $self->{data}->[$c] = \@tmp; 268 | return 1; 269 | } 270 | 271 | # apply a $fun to each row in the table 272 | # function has access to all elements in that row 273 | sub colsMap { 274 | my ($self, $fun) = @_; 275 | $self->rotate() if $self->{type}; 276 | map {&$fun} @{$self->{data}}; 277 | return 1; 278 | } 279 | 280 | sub addRow { 281 | my ($self, $rowRef, $rowIdx) = @_; 282 | my $numRow=$self->nofRow(); 283 | my @t; 284 | confess "addRow: size of added row does not match those in the table\n" 285 | if scalar @$rowRef != $self->nofCol(); 286 | $rowIdx=$numRow unless defined($rowIdx); 287 | return undef unless defined $self->checkNewRow($rowIdx); 288 | $self->rotate() if $self->{type}; 289 | my $data=$self->{data}; 290 | if ($rowIdx == 0) { 291 | unshift @$data, $rowRef; 292 | } elsif ($rowIdx == $numRow) { 293 | push @$data, $rowRef; 294 | } else { 295 | @t = splice @$data, $rowIdx; 296 | push @$data, $rowRef, @t; 297 | } 298 | return 1; 299 | } 300 | 301 | sub delRow { 302 | my ($self, $rowIdx ) = @_; 303 | return undef unless defined $self->checkOldRow($rowIdx); 304 | $self->rotate() if $self->{type}; 305 | my $data=$self->{data}; 306 | my @dels=splice(@$data, $rowIdx, 1); 307 | return shift @dels; 308 | } 309 | 310 | sub delRows { 311 | my ($self, $rowIdcsRef) = @_; 312 | my $rowIdx; 313 | my @indices = sort { $b <=> $a } @$rowIdcsRef; 314 | my @dels=(); 315 | foreach $rowIdx (@indices) { 316 | push @dels, $self->delRow($rowIdx); 317 | } 318 | return @dels; 319 | } 320 | 321 | # append a column to the table, input is a referenceof_array 322 | 323 | sub addCol { 324 | my ($self, $colRef, $colName, $colIdx) = @_; 325 | my $numCol=$self->nofCol(); 326 | my @t; 327 | confess "addCol: size of added col does not match rows in the table\n" 328 | if scalar @$colRef != $self->nofRow(); 329 | $colIdx=$numCol unless defined($colIdx); 330 | return undef unless defined $self->checkNewCol($colIdx, $colName); 331 | $self->rotate() unless $self->{type}; 332 | my $data=$self->{data}; 333 | my $header=$self->{header}; 334 | if ($colIdx == 0) { 335 | unshift @$header, $colName; 336 | } elsif ($colIdx == $numCol) { 337 | push @$header, $colName; 338 | } else { 339 | @t = splice @$header, $colIdx; 340 | push @$header, $colName, @t; 341 | } 342 | 343 | if ($colIdx == 0) { 344 | unshift @$data, $colRef; 345 | } elsif ($colIdx == $numCol) { 346 | push @$data, $colRef; 347 | } else { 348 | @t = splice @$data, $colIdx; 349 | push @$data, $colRef, @t; 350 | } 351 | 352 | for (my $i = 0; $i < scalar @$header; $i++) { 353 | my $elm = $header->[$i]; 354 | $self->{colHash}->{$elm} = $i; 355 | } 356 | return 1; 357 | } 358 | 359 | sub delCol { 360 | my ($self, $colID) = @_; 361 | my $c=$self->checkOldCol($colID); 362 | return undef unless defined $c; 363 | my $header=$self->{header}; 364 | my $name=$self->{header}->[$c]; 365 | splice @$header, $c, 1; 366 | $self->rotate() unless $self->{type}; 367 | my $data=$self->{data}; 368 | delete $self->{colHash}->{$name}; 369 | for (my $i = 0; $i < scalar @$header; $i++) { 370 | my $elm = $header->[$i]; 371 | $self->{colHash}->{$elm} = $i; 372 | } 373 | my @dels=splice @$data, $c, 1; 374 | return shift @dels; 375 | } 376 | 377 | sub delCols { 378 | my ($self, $colIDsRef) = @_; 379 | my $idx; 380 | my @indices = map { $self->colIndex($_) } @$colIDsRef; 381 | @indices = sort { $b <=> $a } @indices; 382 | 383 | my @dels=(); 384 | foreach my $colIdx (@indices) { 385 | push @dels, $self->delCol($colIdx); 386 | } 387 | return @dels; 388 | } 389 | 390 | 391 | sub rowRef { 392 | my ($self, $rowIdx) = @_; 393 | return undef unless defined $self->checkOldRow($rowIdx); 394 | $self->rotate if $self->{type}; 395 | return $self->{data}->[$rowIdx]; 396 | } 397 | 398 | sub rowRefs { 399 | my ($self, $rowIdcsRef) = @_; 400 | $self->rotate if $self->{type}; 401 | return $self->{data} unless defined $rowIdcsRef; 402 | my @ones = (); 403 | my $rowIdx; 404 | foreach $rowIdx (@$rowIdcsRef) { 405 | push @ones, $self->rowRef($rowIdx); 406 | } 407 | return \@ones; 408 | } 409 | 410 | sub row { 411 | my ($self, $rowIdx) = @_; 412 | my $data = $self->{data}; 413 | return undef unless defined $self->checkOldRow($rowIdx); 414 | if ($self->{type}) { 415 | my @one=(); 416 | for (my $i = 0; $i < scalar @$data; $i++) { 417 | push @one, $data->[$i]->[$rowIdx]; 418 | } 419 | return @one; 420 | } else { 421 | return @{$data->[$rowIdx]}; 422 | } 423 | } 424 | 425 | sub rowHashRef { 426 | my ($self, $rowIdx) = @_; 427 | my $data = $self->{data}; 428 | return undef unless defined $self->checkOldRow($rowIdx); 429 | my $header=$self->{header}; 430 | my $one = {}; 431 | for (my $i = 0; $i < scalar @$header; $i++) { 432 | $one->{$header->[$i]} = ($self->{type})? 433 | $self->{data}->[$i]->[$rowIdx]:$self->{data}->[$rowIdx]->[$i]; 434 | } 435 | return $one; 436 | } 437 | 438 | sub colRef { 439 | my ($self, $colID) = @_; 440 | my $c=$self->checkOldCol($colID); 441 | return undef unless defined $c; 442 | $self->rotate() unless $self->{type}; 443 | return $self->{data}->[$c]; 444 | } 445 | 446 | sub colRefs { 447 | my ($self, $colIDsRef) = @_; 448 | $self->rotate unless $self->{type}; 449 | return $self->{data} unless defined $colIDsRef; 450 | my @ones = (); 451 | my $colID; 452 | foreach $colID (@$colIDsRef) { 453 | push @ones, $self->colRef($colID); 454 | } 455 | return \@ones; 456 | } 457 | 458 | sub col { 459 | my ($self, $colID) = @_; 460 | my $data = $self->{data}; 461 | my $c=$self->checkOldCol($colID); 462 | return undef unless defined $c; 463 | if (!$self->{type}) { 464 | my @one=(); 465 | for (my $i = 0; $i < scalar @$data; $i++) { 466 | push @one, $data->[$i]->[$c]; 467 | } 468 | return @one; 469 | } else { 470 | return () unless ref($data->[$c]) eq "ARRAY"; 471 | return @{$data->[$c]}; 472 | } 473 | } 474 | 475 | sub rename { 476 | my ($self, $colID, $name) = @_; 477 | my $oldName; 478 | my $c=$self->checkOldCol($colID); 479 | return undef unless defined $c; 480 | $oldName=$self->{header}->[$c]; 481 | return if ($oldName eq $name); 482 | return undef unless defined $self->checkNewCol($c, $name); 483 | $self->{header}->[$c]=$name; 484 | $self->{colHash}->{$oldName}=undef; 485 | $self->{colHash}->{$name}=$c; 486 | return 1; 487 | } 488 | 489 | sub replace{ 490 | my ($self, $oldColID, $newColRef, $newName) = @_; 491 | my $oldName; 492 | my $c=$self->checkOldCol($oldColID); 493 | return undef unless defined $c; 494 | $oldName=$self->{header}->[$c]; 495 | $newName=$oldName unless defined($newName); 496 | unless ($oldName eq $newName) { 497 | return undef unless defined $self->checkNewCol($c, $newName); 498 | } 499 | confess "New column size ".(scalar @$newColRef)." must be ".$self->nofRow() unless (scalar @$newColRef==$self->nofRow()); 500 | $self->rename($c, $newName); 501 | $self->rotate() unless $self->{type}; 502 | my $old=$self->{data}->[$c]; 503 | $self->{data}->[$c]=$newColRef; 504 | return $old; 505 | } 506 | 507 | sub swap{ 508 | my ($self, $colID1, $colID2) = @_; 509 | my $c1=$self->checkOldCol($colID1); 510 | return undef unless defined $c1; 511 | my $c2=$self->checkOldCol($colID2); 512 | return undef unless defined $c2; 513 | my $name1=$self->{header}->[$c1]; 514 | my $name2=$self->{header}->[$c2]; 515 | 516 | $self->{header}->[$c1]=$name2; 517 | $self->{header}->[$c2]=$name1; 518 | $self->{colHash}->{$name1}=$c2; 519 | $self->{colHash}->{$name2}=$c1; 520 | $self->rotate() unless $self->{type}; 521 | my $data1=$self->{data}->[$c1]; 522 | my $data2=$self->{data}->[$c2]; 523 | $self->{data}->[$c1]=$data2; 524 | $self->{data}->[$c2]=$data1; 525 | return 1; 526 | } 527 | 528 | sub checkOldRow { 529 | my ($self, $rowIdx) = @_; 530 | my $maxIdx=$self->nofRow()-1; 531 | unless (defined $rowIdx) { 532 | print STDERR " Invalid row index\n"; 533 | return undef; 534 | } 535 | if ($rowIdx<0 || $rowIdx>$maxIdx) { 536 | print STDERR "Row index out of range [0..$maxIdx]" ; 537 | return undef; 538 | } 539 | return $rowIdx; 540 | } 541 | 542 | sub checkNewRow { 543 | my ($self, $rowIdx) = @_; 544 | my $maxIdx=$self->nofRow()-1; 545 | unless (defined $rowIdx) { 546 | print STDERR "Invalid row index: $rowIdx \n"; 547 | return undef; 548 | } 549 | $maxIdx+=1; 550 | if ($rowIdx<0 || $rowIdx>$maxIdx) { 551 | print STDERR "Row index out of range [0..$maxIdx]" ; 552 | return undef; 553 | } 554 | return $rowIdx; 555 | } 556 | 557 | sub checkOldCol { 558 | my ($self, $colID) = @_; 559 | my $c=$self->colIndex($colID); 560 | if ($c < 0) { 561 | print STDERR "Invalid column $colID"; 562 | return undef; 563 | } 564 | return $c; 565 | } 566 | 567 | sub checkNewCol { 568 | my ($self, $colIdx, $colName) = @_; 569 | my $numCol=$self->nofCol(); 570 | unless (defined $colIdx) { 571 | print STDERR "Invalid column index $colIdx"; 572 | return undef; 573 | } 574 | if ($colIdx<0 || $colIdx>$numCol) { 575 | print STDERR "Column index $colIdx out of range [0..$numCol]"; 576 | return undef; 577 | } 578 | if (defined $self->{colHash}->{$colName} ) { 579 | print STDERR "Column name $colName already exists" ; 580 | return undef; 581 | } 582 | unless ($colName =~ /\D/) { 583 | print STDERR "Invalid column name $colName" ; 584 | return undef; 585 | } 586 | return $colIdx; 587 | } 588 | 589 | sub elm { 590 | my ($self, $rowIdx, $colID) = @_; 591 | my $c=$self->checkOldCol($colID); 592 | return undef unless defined $c; 593 | return undef unless defined $self->checkOldRow($rowIdx); 594 | return ($self->{type})? 595 | $self->{data}->[$c]->[$rowIdx]: 596 | $self->{data}->[$rowIdx]->[$c]; 597 | } 598 | 599 | sub elmRef { 600 | my ($self, $rowIdx, $colID) = @_; 601 | my $c=$self->checkOldCol($colID); 602 | return undef unless defined $c; 603 | return undef unless defined $self->checkOldRow($rowIdx); 604 | return ($self->{type})? 605 | \$self->{data}->[$c]->[$rowIdx]: 606 | \$self->{data}->[$rowIdx]->[$c]; 607 | } 608 | 609 | sub setElm { 610 | my ($self, $rowIdx, $colID, $val) = @_; 611 | my $c=$self->checkOldCol($colID); 612 | return undef unless defined $c; 613 | return undef unless defined $self->checkOldRow($rowIdx); 614 | if ($self->{type}) { 615 | $self->{data}->[$c]->[$rowIdx]=$val; 616 | } else { 617 | $self->{data}->[$rowIdx]->[$c]=$val; 618 | } 619 | return 1; 620 | } 621 | 622 | # convert the internal structure of a table between row-based and column-based 623 | sub rotate { 624 | my $self=shift; 625 | my $newdata=[]; 626 | my $data=$self->{data}; 627 | $self->{type} = ($self->{type})?0:1; 628 | if ($self->{type} && scalar @$data == 0) { 629 | for (my $i=0; $i < $self->nofCol; $i++) { 630 | $newdata->[$i] = []; 631 | } 632 | } else { 633 | for (my $i=$#{$data->[0]}; $i>=0; $i--) { 634 | for (my $j=$#{$data}; $j>=0; $j--) { 635 | $newdata->[$i][$j]=$data->[$j][$i]; 636 | } 637 | } 638 | } 639 | $self->{data}=$newdata; 640 | return 1; 641 | } 642 | 643 | sub header { 644 | my ($self, $header) = @_; 645 | unless (defined($header)) { 646 | return @{$self->{header}}; 647 | } else { 648 | if (scalar @$header != scalar @{$self->{header}}) { 649 | confess "Header array should have size ".(scalar @{$self->{header}}); 650 | } else { 651 | my $colHash = checkHeader($header); 652 | $self->{header} = $header; 653 | $self->{colHash} = $colHash; 654 | } 655 | } 656 | } 657 | 658 | sub type { 659 | my $self=shift; 660 | return $self->{type}; 661 | } 662 | 663 | sub data { 664 | my $self=shift; 665 | return $self->{data}; 666 | } 667 | 668 | # $t->sort(colID1, type1, order1, colID2, type2, order2, ... ); 669 | # where 670 | # colID is a column index (integer) or name (string), 671 | # type is 0 for numerical and 1 for others 672 | # order is 0 for ascending and 1 for descending 673 | # Sorting is done with priority of colname1, colname2, ... 674 | 675 | sub sort_v0 { 676 | my $self = shift; 677 | my ($str, $i) = ("", 0); 678 | my @cols = (); 679 | while (scalar @_) { 680 | my $c = shift; 681 | my $col = $self->checkOldCol($c); 682 | return undef unless defined $col; 683 | push @cols, $col; 684 | my $op = '<=>'; 685 | $op = 'cmp' if shift; # string 686 | $str .=(shift)? "(\$b->[$i] $op \$a->[$i]) || " : 687 | "(\$a->[$i] $op \$b->[$i]) || " ; 688 | $i++; 689 | } 690 | substr($str, -3) = ""; # removes || from the end of $str 691 | $self->rotate() if $self->{type}; 692 | # construct a pre-ordered array 693 | my $fun = sub { my ($cols, $data) = @_; 694 | my @ext; 695 | @ext = map {$data->[$_]} @$cols; 696 | push @ext, $data; 697 | return \@ext; 698 | }; 699 | my @preordered = map {&$fun(\@cols, $_)} @{$self->{data}}; 700 | $self->{data} = [ map {$_->[$i]} eval "sort {$str} \@preordered;" ]; 701 | return 1; 702 | } 703 | 704 | sub sort { 705 | my $self = shift; 706 | my @cols = @_; 707 | confess "Parameters be in groups of three!\n" if ($#cols % 3 != 2); 708 | foreach (0 .. ($#cols/3)) { 709 | my $col = $self->checkOldCol($cols[$_*3]); 710 | return undef unless defined $col; 711 | $cols[$_*3]=$col; 712 | } 713 | my @subs=(); 714 | for (my $i=0; $i<=$#cols; $i+=3) { 715 | my $mysub; 716 | if ($cols[$i+1] == 0) { 717 | $mysub = ($cols[$i+2]? sub {defined($_[1])?(defined($_[0])? $_[1] <=> $_[0]:1):(defined($_[0])?-1:0)} : sub {defined($_[1])?(defined($_[0])? $_[0] <=> $_[1]:-1):(defined($_[0])?1:0)}); 718 | } elsif ($cols[$i+1] == 1) { 719 | $mysub = ($cols[$i+2]? sub {defined($_[1])?(defined($_[0])? $_[1] cmp $_[0]:1):(defined($_[0])?-1:0)} : sub {defined($_[1])?(defined($_[0])? $_[0] cmp $_[1]:-1):(defined($_[0])?1:0)}); 720 | } elsif (ref $cols[$i+1] eq 'CODE') { 721 | my $predicate=$cols[$i+1]; 722 | $mysub = ($cols[$i+2]? sub {defined($_[1])?(defined($_[0])? $predicate->($_[1],$_[0]) : 1): (defined($_[0])?-1:0)} : 723 | sub {defined($_[1])?(defined($_[0])? $predicate->($_[0],$_[1]) : -1): (defined($_[0])?1:0)} ); 724 | } else { 725 | confess "Sort method should be 0 (numerical), 1 (other type), or a subroutine reference!\n"; 726 | } 727 | push @subs, $mysub; 728 | } 729 | my $func = sub { 730 | my $res = 0; 731 | foreach (0 .. ($#cols/3)) { 732 | $res ||= $subs[$_]->($a->[$cols[$_*3]], $b->[$cols[$_*3]]); 733 | return $res unless $res==0; 734 | } 735 | return $res; 736 | }; 737 | $self->rotate() if $self->{type}; 738 | $self->{data} = [sort $func @{$self->{data}}]; 739 | return 1; 740 | } 741 | 742 | # return rows as sub table in which 743 | # a pattern $pattern is matched 744 | sub match_pattern { 745 | my ($self, $pattern, $countOnly) = @_; 746 | my @data=(); 747 | $countOnly=0 unless defined($countOnly); 748 | my $cnt=0; 749 | $self->rotate() if $self->{type}; 750 | @Data::Table::OK= eval "map { $pattern?1:0; } \@{\$self->{data}};"; 751 | for (my $i=0; $i<$self->nofRow(); $i++) { 752 | if ($Data::Table::OK[$i]) { 753 | push @data, $self->{data}->[$i] unless $countOnly; 754 | $cnt++; 755 | } 756 | } 757 | return $cnt if $countOnly; 758 | my @header=@{$self->{header}}; 759 | return new Data::Table(\@data, \@header, 0); 760 | } 761 | 762 | # return rows as sub table in which 763 | # a string elm in an array @$s is matched 764 | sub match_string { 765 | my ($self, $s, $caseIgn, $countOnly) = @_; 766 | confess unless defined($s); 767 | $countOnly=0 unless defined($countOnly); 768 | my @data=(); 769 | my $r; 770 | $self->rotate() if $self->{type}; 771 | @Data::Table::OK=(); 772 | $caseIgn=0 unless defined($caseIgn); 773 | 774 | ### comment out next line if your perl version < 5.005 ### 775 | $r = ($caseIgn)?qr/$s/i : qr/$s/; 776 | my $cnt=0; 777 | 778 | foreach my $row_ref (@{$self->data}) { 779 | push @Data::Table::OK, undef; 780 | foreach my $elm (@$row_ref) { 781 | next unless defined($elm); 782 | 783 | ### comment out the next line if your perl version < 5.005 784 | if ($elm =~ /$r/) { 785 | ### uncomment the next line if your perl version < 5.005 786 | # if ($elm =~ /$s/ || ($elm=~ /$s/i && $caseIgn)) { 787 | 788 | push @data, $row_ref unless $countOnly; 789 | $Data::Table::OK[$#Data::Table::OK]=1; 790 | $cnt++; 791 | last; 792 | } 793 | } 794 | } 795 | return $cnt if $countOnly; 796 | my @header=@{$self->{header}}; 797 | return new Data::Table(\@data, \@header, 0); 798 | } 799 | 800 | sub rowMask { 801 | my ($self, $OK, $c) = @_; 802 | confess unless defined($OK); 803 | $c = 0 unless defined ($c); 804 | my @data=(); 805 | $self->rotate() if $self->{type}; 806 | my $data0=$self->data; 807 | for (my $i=0; $i<$self->nofRow(); $i++) { 808 | if ($c) { 809 | push @data, $data0->[$i] unless $OK->[$i]; 810 | } else { 811 | push @data, $data0->[$i] if $OK->[$i]; 812 | } 813 | } 814 | my @header=@{$self->{header}}; 815 | return new Data::Table(\@data, \@header, 0); 816 | } 817 | 818 | sub rowMerge { 819 | my ($self, $tbl) = @_; 820 | confess "Tables must have the same number of columns" unless ($self->nofCol()==$tbl->nofCol()); 821 | $self->rotate() if $self->{type}; 822 | $tbl->rotate() if $tbl->{type}; 823 | my $data=$self->{data}; 824 | # for ($i=0; $i<$tbl->nofRow(); $i++) { 825 | push @$data, @{$tbl->{data}}; 826 | # } 827 | return 1; 828 | } 829 | 830 | sub colMerge { 831 | my ($self, $tbl) = @_; 832 | confess "Tables must have the same number of rows" unless ($self->nofRow()==$tbl->nofRow()); 833 | my $col; 834 | foreach $col ($tbl->header) { 835 | confess "Duplicate column $col in two tables" if defined($self->{colHash}->{$col}); 836 | } 837 | my $i = $self->nofCol(); 838 | foreach $col ($tbl->header) { 839 | push @{$self->{header}}, $col; 840 | $self->{colHash}->{$col} = $i++; 841 | } 842 | $self->rotate() unless $self->{type}; 843 | $tbl->rotate() unless $tbl->{type}; 844 | my $data=$self->{data}; 845 | for ($i=0; $i<$tbl->nofCol(); $i++) { 846 | push @$data, $tbl->{data}->[$i]; 847 | } 848 | return 1; 849 | } 850 | 851 | sub subTable { 852 | my ($self, $rowIdcsRef, $colIDsRef) = @_; 853 | my @newdata=(); 854 | my @newheader=(); 855 | $rowIdcsRef = [0..($self->nofRow()-1)] unless defined $rowIdcsRef; 856 | $colIDsRef = [0..($self->nofCol()-1)] unless defined $colIDsRef; 857 | for (my $i = 0; $i < scalar @{$colIDsRef}; $i++) { 858 | $colIDsRef->[$i]=$self->checkOldCol($colIDsRef->[$i]); 859 | return undef unless defined $colIDsRef; 860 | push @newheader, $self->{header}->[$colIDsRef->[$i]]; 861 | } 862 | if ($self->{type}) { 863 | for (my $i = 0; $i < scalar @{$colIDsRef}; $i++) { 864 | my @one=(); 865 | for (my $j = 0; $j < scalar @{$rowIdcsRef}; $j++) { 866 | return undef unless defined $self->checkOldRow($rowIdcsRef->[$j]); 867 | push @one, $self->{data}->[$colIDsRef->[$i]]->[$rowIdcsRef->[$j]]; 868 | } 869 | push @newdata, \@one; 870 | } 871 | } else { 872 | for (my $i = 0; $i < scalar @{$rowIdcsRef}; $i++) { 873 | return undef unless defined $self->checkOldRow($rowIdcsRef->[$i]); 874 | my @one=(); 875 | for (my $j = 0; $j < scalar @{$colIDsRef}; $j++) { 876 | push @one, $self->{data}->[$rowIdcsRef->[$i]]->[$colIDsRef->[$j]]; 877 | } 878 | push @newdata, \@one; 879 | } 880 | } 881 | return new Data::Table(\@newdata, \@newheader, $self->{type}); 882 | } 883 | 884 | sub clone { 885 | my $self = shift; 886 | my $data = $self->{data}; 887 | my @newheader = @{$self->{header}}; 888 | my @newdata = (); 889 | for (my $i = 0; $i < scalar @{$data}; $i++) { 890 | my @one=(); 891 | for (my $j = 0; $j < scalar @{$data->[$i]}; $j++) { 892 | push @one, $data->[$i]->[$j]; 893 | } 894 | push @newdata, \@one; 895 | } 896 | return new Data::Table(\@newdata, \@newheader, $self->{type}); 897 | } 898 | 899 | sub fromCSVi { 900 | my $self = shift; 901 | return fromCSV(@_); 902 | } 903 | 904 | sub fromCSV { 905 | my ($name_or_handler, $includeHeader, $header, $arg_ref) = @_; 906 | $includeHeader = 1 unless defined($includeHeader); 907 | my ($OS, $delimiter, $qualifier, $skip_lines, $skip_pattern) = ($Data::Table::DEFAULTS{OS}, $Data::Table::DEFAULTS{CSV_DELIMITER}, $Data::Table::DEFAULTS{CSV_QUALIFIER}, 0, undef); 908 | $OS = $arg_ref->{'OS'} if (defined($arg_ref) && defined($arg_ref->{'OS'})); 909 | # OS: 0 for UNIX (\n as linebreak), 1 for Windows (\r\n as linebreak) 910 | ### 2 for MAC (\r as linebreak) 911 | if (defined($arg_ref)) { 912 | $delimiter = $arg_ref->{'delimiter'} if defined($arg_ref->{'delimiter'}); 913 | $qualifier = $arg_ref->{'qualifier'} if defined($arg_ref->{'qualifier'}); 914 | $skip_lines = $arg_ref->{'skip_lines'} if (defined($arg_ref->{'skip_lines'}) && $arg_ref->{'skip_lines'}>0); 915 | $skip_pattern = $arg_ref->{'skip_pattern'} if defined($arg_ref->{'skip_pattern'}); 916 | } 917 | my @header; 918 | my $givenHeader = 0; 919 | if (defined($header) && ref($header) eq 'ARRAY') { 920 | $givenHeader = 1; 921 | @header= @$header; 922 | } 923 | my $isFileHandler=ref($name_or_handler) ne ""; 924 | my $SRC; 925 | if ($isFileHandler) { 926 | $SRC = $name_or_handler; # a file handler 927 | } else { 928 | open($SRC, $name_or_handler) or confess "Cannot open $name_or_handler to read"; 929 | binmode $SRC,':utf8';#TODO:Send a Bug-report/feature request with patch 930 | } 931 | my @data = (); 932 | my $oldRowDelimiter=$/; 933 | my $newRowDelimiter=($OS==2)?"\r":(($OS==1)?"\r\n":"\n"); 934 | my $n_endl = length($newRowDelimiter); 935 | $/=$newRowDelimiter; 936 | my $s; 937 | for (my $i=0; $i<$skip_lines; $i++) { 938 | $s=<$SRC>; 939 | } 940 | $s=<$SRC>; 941 | if (defined($skip_pattern)) { while (defined($s) && $s =~ /$skip_pattern/) { $s = <$SRC> }; } 942 | if (substr($s, -$n_endl, $n_endl) eq $newRowDelimiter) { for (1..$n_endl) { chop $s }} 943 | # $_=~ s/$newRowDelimiter$//; 944 | unless ($s) { 945 | #confess "Empty data file" unless $givenHeader; 946 | return undef unless $givenHeader; 947 | $/=$oldRowDelimiter; 948 | return new Data::Table(\@data, \@header, 0); 949 | } 950 | my $one; 951 | if ($s =~ /$delimiter$/) { # if the line ends by ',', the size of @one will be incorrect 952 | # due to the tailing of split function in perl 953 | $s .= ' '; # e.g., split $s="a," will only return a list of size 1. 954 | $one = parseCSV($s, undef, {delimiter=>$delimiter, qualifier=>$qualifier}); 955 | $one->[$#{@$one}]=undef; 956 | } else { 957 | $one = parseCSV($s, undef, {delimiter=>$delimiter, qualifier=>$qualifier}); 958 | } 959 | #print join("|", @$one), scalar @$one, "\n"; 960 | my $size = scalar @$one; 961 | unless ($givenHeader) { 962 | if ($includeHeader) { 963 | @header = @$one; 964 | } else { 965 | @header = map {"col$_"} (1..$size); # name each column as col1, col2, .. etc 966 | } 967 | } 968 | push @data, $one unless ($includeHeader); 969 | 970 | while($s = <$SRC>) { 971 | next if (defined($skip_pattern) && $s =~ /$skip_pattern/); 972 | if (substr($s, -$n_endl, $n_endl) eq $newRowDelimiter) { for (1..$n_endl) { chop $s }} 973 | # $_=~ s/$newDelimiter$//; 974 | my $one = parseCSV($s, $size, {delimiter=>$delimiter, qualifier=>$qualifier}); 975 | confess "Inconsistent column number at data entry: ".($#data+1) unless ($size==scalar @$one); 976 | push @data, $one; 977 | } 978 | close($SRC) unless $isFileHandler; 979 | $/=$oldRowDelimiter; 980 | return new Data::Table(\@data, \@header, 0); 981 | } 982 | 983 | # Idea: use \ as the escape char to encode a CSV string, 984 | # replace \ by \\ and comma inside a field by \c. 985 | # A comma inside a field must have odd number of " in front of it, 986 | # therefore it can be distinguished from comma used as the deliminator. 987 | # After escape, and split by comma, we unescape each field string. 988 | # 989 | # This parser will never be crashed by any illegal CSV format, 990 | # it always return an array! 991 | sub parseCSV { 992 | my ($s, $size, $arg_ref)=@_; 993 | $size = 0 unless defined $size; 994 | my ($delimiter, $qualifier) = ($Data::Table::DEFAULTS{CSV_DELIMITER}, $Data::Table::DEFAULTS{CSV_QUALIFIER}); 995 | $delimiter = $arg_ref->{'delimiter'} if (defined($arg_ref) && defined($arg_ref->{'delimiter'})); 996 | $qualifier = $arg_ref->{'qualifier'} if (defined($arg_ref) && defined($arg_ref->{'qualifier'})); 997 | my $delimiter2 = $delimiter; $delimiter2 = substr($delimiter, 1, 1) if length($delimiter)>1; 998 | my $qualifier2 = $qualifier; $qualifier2 = substr($qualifier, 1, 1) if length($qualifier)>1; 999 | # $s =~ s/\n$//; # chop" # assume extra characters has been cleaned before 1000 | return [split /$delimiter/, $s , $size] if -1==index $s, $qualifier; 1001 | $s =~ s/\\/\\\\/g; # escape \ => \\ 1002 | my $n = length($s); 1003 | my ($q, $i)=(0, 0); 1004 | while ($i < $n) { 1005 | my $ch=substr($s, $i, 1); 1006 | $i++; 1007 | if ($ch eq $delimiter2 && ($q%2)) { 1008 | substr($s, $i-1, 1)='\\c'; # escape , => \c if it's not a deliminator 1009 | $i++; 1010 | $n++; 1011 | } elsif ($ch eq $qualifier2) { 1012 | $q++; 1013 | } 1014 | } 1015 | $s =~ s/(^$qualifier)|($qualifier\s*$)//g; # get rid of boundary ", then restore "" => " 1016 | $s =~ s/$qualifier\s*$delimiter/$delimiter2/g; 1017 | $s =~ s/$delimiter\s*$qualifier/$delimiter2/g; 1018 | $s =~ s/$qualifier$qualifier/$qualifier2/g; 1019 | my @parts=split(/$delimiter/, $s, $size); 1020 | @parts = map {$_ =~ s/(\\c|\\\\)/$1 eq '\c'?$delimiter2:'\\'/eg; $_ } @parts; 1021 | # my @parts2=(); 1022 | # foreach $s2 (@parts) { 1023 | # $s2 =~ s/\\c/,/g; # restore \c => , 1024 | # $s2 =~ s/\\\\/\\/g; # restore \\ => \ 1025 | # push @parts2, $s2; 1026 | # } 1027 | return \@parts; 1028 | } 1029 | 1030 | sub fromTSVi { 1031 | my $self = shift; 1032 | return fromTSV(@_); 1033 | } 1034 | 1035 | sub fromTSV { 1036 | my ($name_or_handler, $includeHeader, $header, $arg_ref) = @_; 1037 | my ($OS, $skip_lines, $skip_pattern) = ($Data::Table::DEFAULTS{OS}, 0, undef); 1038 | $OS = $arg_ref->{'OS'} if (defined($arg_ref) && defined($arg_ref->{'OS'})); 1039 | # OS: 0 for UNIX (\n as linebreak), 1 for Windows (\r\n as linebreak) 1040 | ### 2 for MAC (\r as linebreak) 1041 | $skip_lines = $arg_ref->{'skip_lines'} if (defined($arg_ref) && defined($arg_ref->{'skip_lines'}) && $arg_ref->{'skip_lines'}>0); 1042 | $skip_pattern = $arg_ref->{'skip_pattern'} if defined($arg_ref->{'skip_pattern'}); 1043 | 1044 | my %ESC = ( '0'=>"\0", 'n'=>"\n", 't'=>"\t", 'r'=>"\r", 'b'=>"\b", 1045 | "'"=>"'", '"'=>"\"", '\\'=>"\\" ); 1046 | ## what about \f? MySQL treats \f as f. 1047 | 1048 | $includeHeader = 1 unless defined($includeHeader); 1049 | $OS=0 unless defined($OS); 1050 | 1051 | my @header; 1052 | my $givenHeader = 0; 1053 | if (defined($header) && ref($header) eq 'ARRAY') { 1054 | $givenHeader = 1; 1055 | @header= @$header; 1056 | } 1057 | my $isFileHandler=ref($name_or_handler) ne ""; 1058 | my $SRC; 1059 | if ($isFileHandler) { 1060 | $SRC = $name_or_handler; # a file handler 1061 | } else { 1062 | open($SRC, $name_or_handler) or confess "Cannot open $name_or_handler to read"; 1063 | binmode $SRC; 1064 | } 1065 | my @data = (); 1066 | my $oldRowDelimiter=$/; 1067 | my $newRowDelimiter=($OS==2)?"\r":(($OS==1)?"\r\n":"\n"); 1068 | my $n_endl = length($newRowDelimiter); 1069 | $/=$newRowDelimiter; 1070 | my $s; 1071 | for (my $i=0; $i<$skip_lines; $i++) { 1072 | $s=<$SRC>; 1073 | } 1074 | $s=<$SRC>; 1075 | if (defined($skip_pattern)) { while (defined($s) && $s =~ /$skip_pattern/) { $s = <$SRC> }; } 1076 | if (substr($s, -$n_endl, $n_endl) eq $newRowDelimiter) { for (1..$n_endl) { chop $s }} 1077 | # $_=~ s/$newRowDelimiter$//; 1078 | unless ($s) { 1079 | confess "Empty data file" unless $givenHeader; 1080 | $/=$oldRowDelimiter; 1081 | return new Data::Table(\@data, \@header, 0); 1082 | } 1083 | #chop; 1084 | my $one; 1085 | if ($s =~ /\t$/) { # if the line ends by ',', the size of @$one will be incorrect 1086 | # due to the tailing of split function in perl 1087 | $s .= ' '; # e.g., split $s="a," will only return a list of size 1. 1088 | @$one = split(/\t/, $s); 1089 | $one->[$#{@$one}]=''; 1090 | } else { 1091 | @$one = split(/\t/, $s); 1092 | } 1093 | # print join("|", @$one), scalar @$one, "\n"; 1094 | my $size = scalar @$one; 1095 | unless ($givenHeader) { 1096 | if ($includeHeader) { 1097 | @header = map { $_ =~ s/\\([0ntrb'"\\])/$ESC{$1}/g; $_ } @$one; 1098 | } else { 1099 | @header = map {"col$_"} (1..$size); # name each column as col1, col2, .. etc 1100 | } 1101 | } 1102 | push @data, $one unless ($includeHeader); 1103 | 1104 | while($s = <$SRC>) { 1105 | #chop; 1106 | # $_=~ s/$newRowDelimiter$//; 1107 | next if (defined($skip_pattern) && $s =~ /$skip_pattern/); 1108 | if (substr($s, -$n_endl, $n_endl) eq $newRowDelimiter) { for (1..$n_endl) { chop $s }} 1109 | my @one = split(/\t/, $s, $size); 1110 | for (my $i=0; $i < $size; $i++) { 1111 | next unless defined($one[$i]); 1112 | if ($one[$i] eq "\\N") { 1113 | $one[$i]=undef; 1114 | } else { 1115 | $one[$i] =~ s/\\([0ntrb'"\\])/$ESC{$1}/g; 1116 | } 1117 | } 1118 | confess "Inconsistent column number at data entry: ".($#data+1) unless ($size==scalar @one); 1119 | push @data, \@one; 1120 | } 1121 | close($SRC) unless $isFileHandler; 1122 | $/=$oldRowDelimiter; 1123 | return new Data::Table(\@data, \@header, 0); 1124 | } 1125 | 1126 | sub fromSQLi { 1127 | my $self = shift; 1128 | return fromSQL(@_); 1129 | } 1130 | 1131 | sub fromSQL { 1132 | my ($dbh, $sql, $vars) = @_; 1133 | my ($sth, $header, $t); 1134 | $sth = $dbh->prepare($sql) or confess "Preparing: , ".$dbh->errstr; 1135 | my @vars=() unless defined $vars; 1136 | $sth->execute(@$vars) or confess "Executing: ".$dbh->errstr; 1137 | # $Data::Table::ID = undef; 1138 | # $Data::Table::ID = $sth->{'mysql_insertid'}; 1139 | if ($sth->{NUM_OF_FIELDS}) { 1140 | $header=$sth->{'NAME'}; 1141 | $t = new Data::Table($sth->fetchall_arrayref(), $header, 0); 1142 | } else { 1143 | $t = undef; 1144 | } 1145 | $sth->finish; 1146 | return $t; 1147 | } 1148 | 1149 | sub join { 1150 | my ($self, $tbl, $type, $cols1, $cols2) = @_; 1151 | my $n1 = scalar @$cols1; 1152 | # default cols2 to cols1 if not specified 1153 | if (!defined($cols2) && $n1>0) { 1154 | $cols2 = []; 1155 | foreach my $c (@$cols1) { 1156 | push @$cols2, $c; 1157 | } 1158 | } 1159 | my $n2 = scalar @$cols2; 1160 | confess "The number of join columns must be the same: $n1 != $n2" unless $n1==$n2; 1161 | confess "At least one join column must be specified" unless $n1; 1162 | my ($i, $j, $k); 1163 | my @cols3 = (); 1164 | for ($i = 0; $i < $n1; $i++) { 1165 | $cols1->[$i]=$self->checkOldCol($cols1->[$i]); 1166 | confess "Unknown column ". $cols1->[$i] unless defined($cols1->[$i]); 1167 | $cols2->[$i]=$tbl->checkOldCol($cols2->[$i]); 1168 | confess "Unknown column ". $cols2->[$i] unless defined($cols2->[$i]); 1169 | $cols3[$cols2->[$i]]=1; 1170 | } 1171 | my @cols4 = (); # the list of remaining columns 1172 | my @header2 = (); 1173 | for ($i = 0; $i < $tbl->nofCol; $i++) { 1174 | unless (defined($cols3[$i])) { 1175 | push @cols4, $i; 1176 | push @header2, $tbl->{header}->[$i]; 1177 | } 1178 | } 1179 | 1180 | $self->rotate() if $self->{type}; 1181 | $tbl->rotate() if $tbl->{type}; 1182 | my $data1 = $self->{data}; 1183 | my $data2 = $tbl->{data}; 1184 | my %H=(); 1185 | my $key; 1186 | my @subRow; 1187 | for ($i = 0; $i < $self->nofRow; $i++) { 1188 | @subRow = @{$data1->[$i]}[@$cols1]; 1189 | $key = join("\t", map {tsvEscape($_)} @subRow); 1190 | unless (defined($H{$key})) { 1191 | $H{$key} = [[$i], []]; 1192 | } else { 1193 | push @{$H{$key}->[0]}, $i; 1194 | } 1195 | } 1196 | for ($i = 0; $i < $tbl->nofRow; $i++) { 1197 | @subRow = @{$data2->[$i]}[@$cols2]; 1198 | $key = join("\t", map {tsvEscape($_)} @subRow); 1199 | unless (defined($H{$key})) { 1200 | $H{$key} = [[], [$i]]; 1201 | } else { 1202 | push @{$H{$key}->[1]}, $i; 1203 | } 1204 | } 1205 | # $type 1206 | # 0: inner join 1207 | # 1: left outer join 1208 | # 2: right outer join 1209 | # 3: full outer join 1210 | my @ones = (); 1211 | my @null1 = (); 1212 | my @null2 = (); 1213 | my @null3 = (); 1214 | $null1[$self->nofCol-1]=undef; 1215 | $null3[$self->nofCol-1]=undef; 1216 | if ($#cols4>=0) { $null2[$#cols4]=undef; } 1217 | foreach $key (keys %H) { 1218 | my ($rows1, $rows2) = @{$H{$key}}; 1219 | my $nr1 = scalar @$rows1; 1220 | my $nr2 = scalar @$rows2; 1221 | next if ($nr1 == 0 && ($type == 0 || $type == 1)); 1222 | next if ($nr2 == 0 && ($type == 0 || $type == 2)); 1223 | if ($nr2 == 0 && ($type == 1 || $type == 3)) { 1224 | for ($i = 0; $i < $nr1; $i++) { 1225 | push @ones, [$self->row($rows1->[$i]), @null2]; 1226 | } 1227 | next; 1228 | } 1229 | if ($nr1 == 0 && ($type == 2 || $type == 3)) { 1230 | for ($j = 0; $j < $nr2; $j++) { 1231 | my @row2 = $tbl->row($rows2->[$j]); 1232 | for ($k = 0; $k< scalar @$cols1; $k++) { 1233 | $null3[$cols1->[$k]] = $row2[$cols2->[$k]]; 1234 | } 1235 | if ($#cols4>=0) { 1236 | push @ones, [@null3, @row2[@cols4]]; 1237 | } else { 1238 | push @ones, [@null3]; 1239 | } 1240 | } 1241 | next; 1242 | } 1243 | for ($i = 0; $i < $nr1; $i++) { 1244 | for ($j = 0; $j < $nr2; $j++) { 1245 | my @row2 = $tbl->row($rows2->[$j]); 1246 | push @ones, [$self->row($rows1->[$i]), @row2[@cols4]]; 1247 | } 1248 | } 1249 | } 1250 | my $header = [@{$self->{header}}, @header2]; 1251 | return new Data::Table(\@ones, $header, 0); 1252 | } 1253 | 1254 | sub group { 1255 | my ($self, $colsToGroupBy, $colsToCalculate, $funsToApply, $newColNames) = @_; 1256 | confess "colsToGroupBy has to be specified!" unless defined($colsToGroupBy) && ref($colsToGroupBy) eq "ARRAY"; 1257 | my @X = (); 1258 | foreach my $x (@$colsToGroupBy) { 1259 | my $x_idx = $self->checkOldCol($x); 1260 | confess "Unknown column ". $x unless defined($x_idx); 1261 | push @X, $x_idx; 1262 | } 1263 | my @Y = (); 1264 | my %Y= (); 1265 | if (defined($colsToCalculate)) { 1266 | foreach my $y (@$colsToCalculate) { 1267 | my $y_idx = $self->checkOldCol($y); 1268 | confess "Unknown column ". $y unless defined($y_idx); 1269 | push @Y, $y_idx; 1270 | $Y{$y_idx} = 1; 1271 | } 1272 | } 1273 | if (scalar @Y) { 1274 | confess "The size of colsToCalculate, funcsToApply and newColNames should be the same!\n" 1275 | unless (scalar @Y == scalar @$funsToApply && scalar @Y == scalar @$newColNames); 1276 | } 1277 | 1278 | my @header = (); 1279 | my @X_name = (); 1280 | my $cnt = 0; 1281 | my $i; 1282 | for ($i=0; $i<$self->nofCol; $i++) { 1283 | next if defined($Y{$i}); 1284 | push @X_name, $i; 1285 | push @header, $self->{header}->[$i]; 1286 | $cnt += 1; 1287 | } 1288 | if (defined($newColNames)) { 1289 | foreach my $y (@$newColNames) { 1290 | push @header, $y; 1291 | $cnt += 1; 1292 | } 1293 | } 1294 | 1295 | my @ones = (); 1296 | my %X = (); 1297 | my %val = (); 1298 | my %rowIdx = (); 1299 | my $idx = 0; 1300 | for ($i=0; $i<$self->nofRow; $i++) { 1301 | my @row = (); 1302 | my $myRow = $self->rowRef($i); 1303 | my @val = (); 1304 | foreach my $x (@X) { 1305 | push @val, defined($myRow->[$x])?$myRow->[$x]:""; 1306 | } 1307 | my $myKey = CORE::join("\t", @val); 1308 | if (scalar @Y) { 1309 | my %Y = (); 1310 | foreach my $y (@Y) { 1311 | next if defined($Y{$y}); 1312 | $Y{$y} = 1; 1313 | if (defined($val{$y}->{$myKey})) { 1314 | push @{$val{$y}->{$myKey}}, $myRow->[$y]; 1315 | } else { 1316 | $val{$y}->{$myKey} = [$myRow->[$y]]; 1317 | } 1318 | } 1319 | } 1320 | next if defined($X{$myKey}); 1321 | $X{$myKey} = 1; 1322 | foreach my $j (@X_name) { 1323 | push @row, $myRow->[$j]; 1324 | } 1325 | $row[$cnt-1] = undef if (scalar @row < $cnt); 1326 | push @ones, \@row; 1327 | $rowIdx{$myKey} = $idx++; 1328 | } 1329 | 1330 | if (scalar @Y) { 1331 | $cnt -= scalar @Y; 1332 | for($i=0; $i[$i]) eq "CODE") { 1335 | $ones[$rowIdx{$s}]->[$cnt+$i] = $funsToApply->[$i]->(@{$val{$Y[$i]}->{$s}}); 1336 | } else { 1337 | confess "The ${i}th element in the function array is not a valid reference!\n"; 1338 | } 1339 | } 1340 | } 1341 | } 1342 | 1343 | return new Data::Table(\@ones, \@header, 0); 1344 | } 1345 | 1346 | sub pivot { 1347 | my ($self, $colToSplit, $colToSplitIsNumeric, $colToFill, $colsToGroupBy, $keepRestCols) = @_; 1348 | $keepRestCols = 0 unless defined($keepRestCols); 1349 | $colToSplitIsNumeric = 1 unless defined($colToSplitIsNumeric); 1350 | my $y = $self->checkOldCol($colToSplit); 1351 | my $y_name = defined($y)?$self->{header}->[$y]:undef; 1352 | confess "Unknown column ". $colToSplit if (!defined($y) && defined($colToSplit)); 1353 | my $z = $self->checkOldCol($colToFill); 1354 | my $z_name = defined($z)?$self->{header}->[$z]:undef; 1355 | confess "Unknown column ". $colToFill if (!defined($z) && defined($colToFill)); 1356 | confess "Cannot take colToFill, if colToSplit is 'undef'" if (defined($z) && !defined($y)); 1357 | my @X = (); 1358 | if (defined($colsToGroupBy)) { 1359 | foreach my $x (@$colsToGroupBy) { 1360 | my $x_idx = $self->checkOldCol($x); 1361 | confess "Unknown column ". $x unless defined($x_idx); 1362 | push @X, $self->{header}->[$x_idx]; 1363 | } 1364 | } 1365 | my ($val, @Y, %Y); 1366 | 1367 | if (defined($colToSplit)) { 1368 | @Y = $self->col($y); 1369 | %Y = (); 1370 | foreach $val (@Y) { 1371 | $val = "NULL" unless defined($val); 1372 | $Y{$val} = 1; 1373 | } 1374 | } 1375 | 1376 | if ($colToSplitIsNumeric) { 1377 | @Y = sort { $a <=> $b } (keys %Y); 1378 | } else { 1379 | @Y = sort { $a cmp $b } (keys %Y); 1380 | } 1381 | 1382 | my @header = (); 1383 | my $i; 1384 | my @X_name = (); 1385 | 1386 | if (!$keepRestCols) { 1387 | foreach my $x (@X) { 1388 | push @X_name, $x; 1389 | } 1390 | } else { 1391 | for ($i=0; $i<$self->nofCol; $i++) { 1392 | next if ((defined($y) && $i==$y) || (defined($z) && $i==$z)); 1393 | push @X_name, $self->{header}->[$i]; 1394 | } 1395 | } 1396 | my $cnt = 0; 1397 | for ($i=0; $i < @X_name; $i++) { 1398 | my $s = $X_name[$i]; 1399 | while (defined($Y{$s})) { 1400 | $s = "_".$s; 1401 | } 1402 | push @header, $s; 1403 | $Y{$s} = $cnt++; 1404 | } 1405 | 1406 | if (defined($y)) { 1407 | foreach $val (@Y) { 1408 | push @header, ($colToSplitIsNumeric?"$y_name=":"") . $val; 1409 | $Y{$val} = $cnt++; 1410 | } 1411 | } 1412 | 1413 | my @ones = (); 1414 | my %X = (); 1415 | my $rowIdx = 0; 1416 | for ($i=0; $i<$self->nofRow; $i++) { 1417 | my @row = (); 1418 | my $myRow = $self->rowHashRef($i); 1419 | my $myKey; 1420 | if (scalar @X) { 1421 | my @val = (); 1422 | foreach my $x (@X) { 1423 | push @val, defined($myRow->{$x})?$myRow->{$x}:""; 1424 | } 1425 | $myKey = CORE::join("\t", @val); 1426 | } 1427 | unless (defined($X{$myKey})) { 1428 | foreach my $s (@X_name) { 1429 | push @row, $myRow->{$s}; 1430 | } 1431 | $row[$cnt-1] = undef if (scalar @row < $cnt); 1432 | } 1433 | if (defined($y)) { 1434 | my $val = $myRow->{$y_name}; 1435 | $val = "NULL" unless defined($val); 1436 | if (!defined($X{$myKey})) { 1437 | $row[$Y{$val}] = defined($z)?$myRow->{$z_name}:1; 1438 | } else { 1439 | $ones[$X{$myKey}][$Y{$val}] = defined($z)?$myRow->{$z_name}:1; 1440 | } 1441 | } 1442 | unless (defined($X{$myKey})) { 1443 | push @ones, \@row; 1444 | $X{$myKey} = $rowIdx++; 1445 | } 1446 | } 1447 | return new Data::Table(\@ones, \@header, 0); 1448 | } 1449 | 1450 | sub fromFileGuessOS { 1451 | my ($name) = @_; 1452 | my $SRC; 1453 | my @OS=("\n", "\r\n", "\r"); 1454 | # operatoring system: 0 for UNIX (\n as linebreak), 1 for Windows 1455 | # (\r\n as linebreak), 2 for MAC (\r as linebreak) 1456 | my ($len, $os)=(-1, -1); 1457 | for (my $i=0; $i<@OS; $i++) { 1458 | open($SRC, $name) or confess "Cannot open $name to read"; 1459 | binmode $SRC; 1460 | local($/)=$OS[$i]; 1461 | my $s = <$SRC>; 1462 | #print ">> $i => ". (length($s)-length($OS[$i]))."\n"; 1463 | my $myLen=length($s)-length($OS[$i]); 1464 | if ($len<0 || ($myLen>0 && $myLen<$len)) { 1465 | $len=length($s)-length($OS[$i]); 1466 | $os=$i; 1467 | } 1468 | close($SRC); 1469 | } 1470 | # find the OS linebreak that gives the shortest first line 1471 | return $os; 1472 | } 1473 | 1474 | sub fromFileGetTopLines { 1475 | my ($name, $os, $numLines) = @_; 1476 | $os = fromFileGuessOS($name) unless defined($os); 1477 | $numLines = 2 unless defined($numLines); 1478 | my @OS=("\n", "\r\n", "\r"); 1479 | # operatoring system: 0 for UNIX (\n as linebreak), 1 for Windows 1480 | # (\r\n as linebreak), 2 for MAC (\r as linebreak) 1481 | my $SRC; 1482 | my @lines=(); 1483 | open($SRC, $name) or confess "Cannot open $name to read"; 1484 | binmode $SRC; 1485 | local($/)=$OS[$os]; 1486 | my $n_endl = length($OS[$os]); 1487 | my $cnt=0; 1488 | while(<$SRC>) { 1489 | $cnt++; 1490 | for (1..$n_endl) { chop; } 1491 | push @lines, $_; 1492 | last if ($numLines>0 && $cnt>=$numLines); 1493 | } 1494 | close($SRC); 1495 | return @lines; 1496 | } 1497 | 1498 | sub fromFileIsHeader { 1499 | my ($s, $delimiter) = @_; 1500 | $delimiter=$Data::Table::DEFAULTS{'CSV_DELIMITER'} unless defined($delimiter); 1501 | return 0 if (!defined($s) || $s eq "" || $s=~ /$delimiter$/); 1502 | my $fields=parseCSV($s, 0, {delimiter=>$delimiter}); 1503 | foreach my $name (@$fields) { 1504 | return 0 unless $name; 1505 | next if $name=~/[^0-9.eE\-+]/; 1506 | return 0 if $name=~/^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?/; 1507 | } 1508 | return 1; 1509 | } 1510 | 1511 | sub fromFileGuessDelimiter { 1512 | my $s_line= shift; 1513 | my @DELIMITER=(",","\t",":"); 1514 | my $numCol=-1; my $i=-1; 1515 | return $Data::Table::DEFAULTS{CSV_DELIMITER} unless @$s_line; 1516 | for (my $d=0; $d<@DELIMITER; $d++) { 1517 | my $colFound=-1; 1518 | foreach my $line (@$s_line) { 1519 | unless (defined($line)) { 1520 | return $Data::Table::DEFAULTS{CSV_DELIMITER}; 1521 | } else { 1522 | my $header = parseCSV($line, 0, {delimiter=>$DELIMITER[$d]}); 1523 | if ($colFound<0) { 1524 | $colFound = scalar @$header; 1525 | } elsif ($colFound != scalar @$header) { 1526 | $colFound = -1; 1527 | last; 1528 | } 1529 | } 1530 | } 1531 | next if $colFound<0; 1532 | if ($colFound>$numCol) { 1533 | $numCol=$colFound; $i=$d; 1534 | } 1535 | } 1536 | return ($i<0)?$Data::Table::DEFAULTS{CSV_DELIMITER}:$DELIMITER[$i]; 1537 | } 1538 | 1539 | sub fromFile { 1540 | my ($name, $arg_ref) = @_; 1541 | my $linesChecked = 2; 1542 | $linesChecked= $arg_ref->{'OS'} if (defined($arg_ref) && defined($arg_ref->{'OS'})); 1543 | if (defined($arg_ref)) { 1544 | $linesChecked = $arg_ref->{'linesChecked'} if defined($arg_ref->{'linesChecked'}); 1545 | } 1546 | my $os = fromFileGuessOS($name); 1547 | my @S = fromFileGetTopLines($name, $os, $linesChecked); 1548 | return undef unless scalar @S; 1549 | my $delimiter = fromFileGuessDelimiter(\@S); 1550 | my $hasHeader = fromFileIsHeader($S[0], $delimiter); 1551 | my $t = undef; 1552 | #print ">>>". join("\n", @S)."\n"; 1553 | #print "OS=$os, hasHeader=$hasHeader, delimiter=$delimiter\n"; 1554 | if ($delimiter eq "\t") { 1555 | $t=fromTSV($name, $hasHeader, undef, {OS=>$os}); 1556 | } else { 1557 | $t=fromCSV($name, $hasHeader, undef, {OS=>$os, delimiter=>$delimiter}); 1558 | } 1559 | return $t; 1560 | } 1561 | 1562 | ## interface to GD::Graph 1563 | # use GD::Graph::points; 1564 | # $graph = GD::Graph::points->new(400, 300); 1565 | # $graph->plot([$t->colRef(1), $t->colRef(2)]); 1566 | 1567 | 1; 1568 | 1569 | __END__ 1570 | 1571 | 1572 | =head1 NAME 1573 | 1574 | Data::Table - Data type related to database tables, spreadsheets, CSV/TSV files, HTML table displays, etc. 1575 | 1576 | =head1 SYNOPSIS 1577 | 1578 | # some cool ways to use Table.pm 1579 | use Data::Table; 1580 | 1581 | $header = ["name", "age"]; 1582 | $data = [ 1583 | ["John", 20], 1584 | ["Kate", 18], 1585 | ["Mike", 23] 1586 | ]; 1587 | $t = new Data::Table($data, $header, 0); # Construct a table object with 1588 | # $data, $header, $type=0 (consider 1589 | # $data as the rows of the table). 1590 | print $t->csv; # Print out the table as a csv file. 1591 | 1592 | $t = Data::Table::fromCSV("aaa.csv"); # Read a csv file into a table object 1593 | ### Since version 1.51, a new method fromFile can automatically guess the correct file format 1594 | # either CSV or TSV file, file with or without a column header line 1595 | # e.g. 1596 | # $t = Data::Table::fromFile("aaa.csv"); 1597 | # is equivalent. 1598 | print $t->html; # Display a 'portrait' HTML TABLE on web. 1599 | 1600 | use DBI; 1601 | $dbh= DBI->connect("DBI:mysql:test", "test", "") or die $DBI::errstr; 1602 | my $minAge = 10; 1603 | $t = Data::Table::fromSQL($dbh, "select * from mytable where age >= ?", [$minAge]); 1604 | # Construct a table form an SQL 1605 | # database query. 1606 | 1607 | $t->sort("age", 0, 0); # Sort by col 'age',numerical,ascending 1608 | print $t->html2; # Print out a 'landscape' HTML Table. 1609 | 1610 | $row = $t->delRow(2); # Delete the third row (index=2). 1611 | $t->addRow($row, 4); # Add the deleted row back as fifth row. 1612 | @rows = $t->delRows([0..2]); # Delete three rows (row 0 to 2). 1613 | $col = $t->delCol("age"); # Delete column 'age'. 1614 | $t->addCol($col, "age",2); # Add column 'age' as the third column 1615 | @cols = $t->delCols(["name","phone","ssn"]); 1616 | # Delete 3 columns at the same time. 1617 | 1618 | $name = $t->elm(2,"name"); # Element access 1619 | $t2=$t->subTable([1, 3..4],['age', 'name']); 1620 | # Extract a sub-table 1621 | 1622 | $t->rename("Entry", "New Entry"); # Rename column 'Entry' by 'New Entry' 1623 | $t->replace("Entry", [1..$t->nofRow()], "New Entry"); 1624 | # Replace column 'Entry' by an array of 1625 | # numbers and rename it as 'New Entry' 1626 | $t->swap("age","ssn"); # Swap the positions of column 'age' 1627 | # with column 'ssn' in the table. 1628 | 1629 | $t->colMap('name', sub {return uc}); # Map a function to a column 1630 | $t->sort('age',0,0,'name',1,0); # Sort table first by the numerical 1631 | # column 'age' and then by the 1632 | # string column 'name' in ascending 1633 | # order 1634 | $t2=$t->match_pattern('$_->[0] =~ /^L/ && $_->[3]<0.2'); 1635 | # Select the rows that matched the 1636 | # pattern specified 1637 | $t2=$t->match_string('John'); # Select the rows that matches 'John' 1638 | # in any column 1639 | 1640 | $t2=$t->clone(); # Make a copy of the table. 1641 | $t->rowMerge($t2); # Merge two tables 1642 | $t->colMerge($t2); 1643 | 1644 | $t = new Data::Table( # create an employ salary table 1645 | [ 1646 | ['Tom', 'male', 'IT', 65000], 1647 | ['John', 'male', 'IT', 75000], 1648 | ['Tom', 'male', 'IT', 65000], 1649 | ['John', 'male', 'IT', 75000], 1650 | ['Peter', 'male', 'HR', 85000], 1651 | ['Mary', 'female', 'HR', 80000], 1652 | ['Nancy', 'female', 'IT', 55000], 1653 | ['Jack', 'male', 'IT', 88000], 1654 | ['Susan', 'female', 'HR', 92000] 1655 | ], 1656 | ['Name', 'Sex', 'Department', 'Salary'], 0); 1657 | 1658 | sub average { # this is an subroutine calculate mathematical average, ignore NULL 1659 | my @data = @_; 1660 | my ($sum, $n) = (0, 0); 1661 | foreach $x (@data) { 1662 | next unless $x; 1663 | $sum += $x; $n++; 1664 | } 1665 | return ($n>0)?$sum/$n:undef; 1666 | } 1667 | 1668 | $t2 = $t->group(["Department","Sex"],["Name", "Salary"], [sub {scalar @_}, \&average], ["Nof Employee", "Average Salary"]); 1669 | # For each (Department,Sex) pair, calculate the number of employees and average salary 1670 | $t2 = $t2->pivot("Sex", 0, "Average Salary", ["Department"]); 1671 | # Show average salary information in a Department by Sex spreadsheet 1672 | 1673 | =head1 ABSTRACT 1674 | 1675 | This perl package uses perl5 objects to make it easy for 1676 | manipulating spreadsheet data among disk files, database, and Web 1677 | publishing. 1678 | 1679 | A table object contains a header and a two-dimensional array of scalars. 1680 | Four class methods Data::fromFile, Data::Table::fromCSV, Data::Table::fromTSV, and Data::Table::fromSQL allow users 1681 | to create a table object from a CSV/TSV file or a database SQL selection in a snap. 1682 | 1683 | Table methods provide basic access, add, delete row(s) or column(s) operations, as well as more advanced sub-table extraction, table sorting, 1684 | record matching via keywords or patterns, table merging, and web publishing. 1685 | Data::Table class also provides a straightforward interface to other 1686 | popular Perl modules such as DBI and GD::Graph. 1687 | 1688 | The current version of Table.pm is available at http://easydatabase.googlepages.com 1689 | 1690 | We use Data::Table instead of Table, because Table.pm has already been used inside PerlQt module in CPAN. 1691 | 1692 | =head1 INTRODUCTION 1693 | 1694 | =over 4 1695 | 1696 | A table object has three data members: 1697 | 1698 | =item 1. $data: 1699 | 1700 | a reference to an array of array-references. 1701 | It's basically a reference to a two-dimensional array. 1702 | 1703 | =item 2. $header: 1704 | 1705 | a reference to a string array. The array contains all the column names. 1706 | 1707 | =item 3. $type = 1 or 0. 1708 | 1709 | 1 means that @$data is an array of table columns (fields) (column-based); 1710 | 0 means that @$data is an array of table rows (records) (row-based); 1711 | 1712 | =back 1713 | 1714 | Row-based/Column-based are two internal implementations for a table object. 1715 | E.g., if a spreadsheet consists of two columns lastname and age. 1716 | In a row-based table, $data = [ ['Smith', 29], ['Dole', 32] ]. 1717 | In a column-based table, $data = [ ['Smith', 'Dole'], [29, 32] ]. 1718 | 1719 | Two implementations have their pros and cons for different operations. 1720 | Row-based implementation is better for sorting and pattern matching, 1721 | while column-based one is better for adding/deleting/swapping columns. 1722 | 1723 | Users only need to specify the implementation type of the table upon its 1724 | creation via Data::Table::new, and can forget about it afterwards. 1725 | Implementation type of a table should be considered volatile, because 1726 | methods switch table objects from one type into another internally. 1727 | Be advised that row/column/element references gained via table::rowRef, 1728 | table::rowRefs, table::colRef, table::colRefs, or table::elmRef may 1729 | become stale after other method calls afterwards. 1730 | 1731 | For those who want to inherit from the Data::Table class, internal method 1732 | table::rotate is used to switch from one implementation type into another. 1733 | There is an additional internal assistant data structure called 1734 | colHash in our current implementation. This hash 1735 | table stores all column names and their corresponding column index number as 1736 | key-value pairs for fast conversion. This gives users an option to use 1737 | column name wherever a column ID is expected, so that user don't have to use 1738 | table::colIndex all the time. E.g., you may say 1739 | $t->rename('oldColName', 'newColName') 1740 | instead of $t->rename($t->colIndex('oldColName'), 'newColIdx'). 1741 | 1742 | =head1 DESCRIPTION 1743 | 1744 | =head2 Field Summary 1745 | 1746 | =over 4 1747 | 1748 | =item data refto_arrayof_refto_array 1749 | 1750 | contains a two-dimensional spreadsheet data. 1751 | 1752 | =item header refto_array 1753 | 1754 | contains all column names. 1755 | 1756 | =item type 0/1 1757 | 1758 | 0 is row-based, 1 is column-based, describe the orientation of @$data. 1759 | 1760 | =back 1761 | 1762 | =head2 Package Variables 1763 | 1764 | =over 4 1765 | 1766 | =item $Data::Table::VERSION 1767 | 1768 | =item @Data::Table::OK 1769 | 1770 | see table::match_string and table::match_pattern 1771 | 1772 | =item %Data::Table::DEFAULTS 1773 | 1774 | Store default settings, currently it contains CSV_DELIMITER (set to ','), CSV_QUALIFER (set to '"'), and OS (set to 0). 1775 | see table::fromCSV, table::csv, table::fromTSV, table::tsv for details. 1776 | 1777 | =back 1778 | 1779 | =head2 Class Methods 1780 | 1781 | Syntax: return_type method_name ( [ parameter [ = default_value ]] [, parameter [ = default_value ]] ) 1782 | 1783 | If method_name starts with table::, this is an instance method, it can be used as $t->method( parameters ), where $t is a table reference. 1784 | 1785 | If method_name starts with Data::Table::, this is a class method, it should be called as 1786 | Data::Table::method, e.g., $t = Data::Table::fromCSV("filename.csv"). 1787 | 1788 | Conventions for local variables: 1789 | 1790 | colID: either a numerical column index or a column name; 1791 | rowIdx: numerical row index; 1792 | rowIDsRef: reference to an array of column IDs; 1793 | rowIdcsRef: reference to an array of row indices; 1794 | rowRef, colRef: reference to an array of scalars; 1795 | data: ref_to_array_of_ref_to_array of data values; 1796 | header: ref to array of column headers; 1797 | table: a table object, a blessed reference. 1798 | 1799 | =head2 Table Creation 1800 | 1801 | =over 4 1802 | 1803 | =item table Data::Table::new ( $data = [], $header = [], $type = 0, $enforceCheck = 1) 1804 | 1805 | create a new table. 1806 | It returns a table object upon success, undef otherwise. 1807 | $data: points to the spreadsheet data. 1808 | $header: points to an array of column names. A column name must have at least one non-digit character. 1809 | $type: 0 or 1 for row-based/column-based spreadsheet. 1810 | $enforceCheck: 1/0 to turn on/off initial checking on the size of each row/column to make sure the data arguement indeed points to a valid structure. 1811 | 1812 | =item table table::subTable ($rowIdcsRef, $colIDsRef) 1813 | 1814 | create a new table, which is a subset of the original. 1815 | It returns a table object. 1816 | $rowIdcsRef: points to an array of row indices. 1817 | $colIDsRef: points to an array of column IDs. 1818 | The function make a copy of selected elements from the original table. 1819 | Undefined $rowIdcsRef or $colIDsRef is interpreted as all rows or all columns. 1820 | 1821 | =item table table::clone 1822 | 1823 | make a clone of the original. 1824 | It return a table object, equivalent to table::subTable(undef,undef). 1825 | 1826 | =item table Data::Table::fromCSV ($name_or_handler, $includeHeader = 1, $header = ["col1", ... ], {OS=>$Data::Table::DEFAULTS{'OS'}, delimiter=>$Data::Table::DEFAULTS{'CSV_DELIMITER'}, qualifier=>$Data::Table::DEFAULTS{'CSV_QUALIFIER'}, skip_lines=>0, skip_pattern=>undef}) 1827 | 1828 | create a table from a CSV file. 1829 | return a table object. 1830 | $name_or_handler: the CSV file name or an already opened file handler. If a handler is used, it's not closed upon return. 1831 | $includeHeader: 0 or 1 to ignore/interpret the first line in the file as column names, 1832 | If it is set to 0, the array in $header is used. If $header is not supplied, the default column names are "col1", "col2", ... 1833 | optional named argument OS specifies under which operating system the CSV file was generated. 0 for UNIX, 1 for PC and 2 for MAC. If not specified, $Data::Table::DEFAULTS{'OS'} is used, which defaults to UNIX. Basically linebreak is defined as "\n", "\r\n" and "\r" for three systems, respectively. 1834 | 1835 | optional name argument delimiter and qualifier let user replace comma and double-quote by other meaningful single characters. Exception: if the delimiter or the qualifier is a special symbol in regular expression, you must escape it by '\'. For example, in order to use pipe symbol as the delimiter, you must specify the delimiter as '\|'. 1836 | 1837 | optional name argument skip_lines let you specify how many lines in the csv file should be skipped, before the data are interpretted. 1838 | 1839 | optional name argument skip_pattern let you specify a regular expression. Lines that match the regular expression will be skipped. 1840 | 1841 | The following example reads a DOS format CSV file and writes a MAC format: 1842 | 1843 | $t = Data::Table:fromCSV('A_DOS_CSV_FILE.csv', 1, undef, {OS=>1}); 1844 | $t->csv(1, {OS=>2, file=>'A_MAC_CSV_FILE.csv'}); 1845 | open(SRC, 'A_DOS_CSV_FILE.csv') or die "Cannot open A_DOS_CSV_FILE.csv to read!"; 1846 | $t = Data::Table::fromCSV(\*SRC, 1); 1847 | close(SRC); 1848 | 1849 | The following example reads a non-standard CSV file with : as the delimiter, ' as the qaulifier 1850 | 1851 | my $s="col_A:col_B:col_C\n1:2, 3 or 5:3.5\none:'one:two':'double\", single'''"; 1852 | open my $fh, "<", \$s or die "Cannot open in-memory file\n"; 1853 | my $t_fh=Data::Table::fromCSV($fh, 1, undef, {delimiter=>':', qualifier=>"'"}); 1854 | close($fh); 1855 | print $t_fh->csv; 1856 | # convert to the standard CSV (comma as the delimiter, double quote as the qualifier) 1857 | # col_A,col_B,col_C 1858 | # 1,"2, 3 or 5",3.5 1859 | # one,one:two,"double"", single'" 1860 | print $t->csv(1, {delimiter=>':', qualifier=>"'"}); # prints the csv file use the original definition 1861 | 1862 | The following example reads bbb.csv file (included in the package) by skipping the first line (skip_lines=>1), then treats any line that starts with '#' (or space comma) as comments (skip_pattern=>'^\s*#'), use ':' as the delimiter. 1863 | 1864 | $t = Data::Table::fromCSV("bbb.csv", 1, undef, {skip_lines=>1, delimiter=>':', skip_pattern=>'^\s*#'}); 1865 | 1866 | =item table table::fromCSVi ($name, $includeHeader = 1, $header = ["col1", ... ]) 1867 | 1868 | Same as Data::Table::fromCSV. However, this is an instant method (that's what 'i' stands for), which can be inherited. 1869 | 1870 | =item table Data::Table::fromTSV ($name, $includeHeader = 1, $header = ["col1", ... ], {OS=>$Data::Table::DEFAULTS{'OS'}, skip_lines=>0, skip_pattern=>undef}) 1871 | 1872 | create a table from a TSV file. 1873 | return a table object. 1874 | $name: the TSV file name or an already opened file handler. If a handler is used, it's not closed upon return.. 1875 | $includeHeader: 0 or 1 to ignore/interpret the first line in the file as column names, 1876 | If it is set to 0, the array in $header is used. If $header is not supplied, the default column names are "col1", "col2", ... 1877 | optional named argument OS specifies under which operating system the TSV file was generated. 0 for UNIX, 1 for P 1878 | C and 2 for MAC. If not specified, $Data::Table::DEFAULTS{'OS'} is used, which defaults to UNIX. Basically linebreak is defined as "\n", "\r\n" and "\r" for three systems, respectively. Exception: if the delimiter or the qualifier is a special symbol in regular expression, you must escape it by '\'. For example, in order to use pipe symbol as the delimiter, you must specify the delimiter as '\|'. 1879 | 1880 | optional name argument skip_lines let you specify how many lines in the csv file should be skipped, before the data are interpretted. 1881 | 1882 | optional name argument skip_pattern let you specify a regular expression. Lines that match the regular expression will be skipped. 1883 | 1884 | See similar examples under Data::Table::fromCSV; 1885 | 1886 | Note: read "TSV FORMAT" section for details. 1887 | 1888 | =item table table::fromTSVi ($name, $includeHeader = 1, $header = ["col1", ... ]) 1889 | 1890 | Same as Data::Table::fromTSV. However, this is an instant method (that's what 'i' stands for), which can be inherited. 1891 | 1892 | =item table Data::Table::fromFile ($file_name, {linesChecked=>2}) 1893 | 1894 | create a table from a text file. 1895 | return a table object. 1896 | $file_name: the file name (cannot take a file handler). 1897 | linesChecked: the first number of lines used for guessing the input format. The delimiter will have to produce the same number of columns for these lines. By default only check the first 2 lines, 0 means all lines in the file. 1898 | 1899 | fromFile is added after version 1.51. It relies on the following new methods to automatically figure out the correct file format in order to call fromCSV or fromTSV internally: 1900 | 1901 | fromFileGuessOS($file_name) 1902 | returns integer, 0 for UNIX, 1 for PC, 2 for MAC 1903 | fromFileGetTopLines($file_name, $os, $lineNumber) # $os defaults to fromFileGuessOS($file_name), if not specified 1904 | returns an array of strings, each string represents each row with linebreak removed. 1905 | fromFileGuessDelimiter($lineArrayRef) # guess delimiter from ",", "\t", ":"; 1906 | returns the guessed delimiter string. 1907 | fromFileIsHeader($line_concent, $delimiter) # $delimiter defaults to $Data::Table::DEFAULTS{'CSV_DELIMITER'} 1908 | returns 1 or 0. 1909 | 1910 | It first ask fromFileGuessOS to figure out which OS (UNIX, PC or MAC) generated the input file. The fetch the first linesChecked lines using fromFileGetTopLines. It then guesses the best delimiter using fromFileGuessDelimiter, then it checks if the first line looks like a column header row using fromFileIsHeader. Since fromFileGuessOS and fromFileGetTopLines needs to open/close the input file, these methods can only take file name, not file handler. 1911 | 1912 | fromFileGuessOS finds the linebreak that gives shortest first line (in the priority of UNIX, PC, MAC upon tie). 1913 | fromFileGuessDelimiter works based on the assumption that the correct delimiter will produce equal number of columns for the given rows. If multiple matches, it chooses the delimiter that gives maximum number of columns. If none matches, it returns the default delimiter. 1914 | fromFileIsHeader works based on the assumption that no column header can be empty or pure numeric value. 1915 | 1916 | =item table Data::Table::fromSQL ($dbh, $sql, $vars) 1917 | 1918 | create a table from the result of an SQL selection query. 1919 | It returns a table object upon success or undef otherwise. 1920 | $dbh: a valid database handler. 1921 | Typically $dbh is obtained from DBI->connect, see "Interface to Database" or DBI.pm. 1922 | $sql: an SQL query string. 1923 | $vars: optional reference to an array of variable values, 1924 | required if $sql contains '?'s which need to be replaced 1925 | by the corresponding variable values upon execution, see DBI.pm for details. 1926 | Hint: in MySQL, Data::Table::fromSQL($dbh, 'show tables from test') will also create a valid table object. 1927 | 1928 | =item table Data::Table::fromSQLi ($dbh, $sql, $vars) 1929 | 1930 | Same as Data::Table::fromSQL. However, this is an instant method (that's what 'i' stands for), whic 1931 | h can be inherited. 1932 | 1933 | =back 1934 | 1935 | =head2 Table Access and Properties 1936 | 1937 | =over 4 1938 | 1939 | =item int table::colIndex ($colID) 1940 | 1941 | translate a column name into its numerical position, the first column has index 0 as in as any perl array. 1942 | return -1 for invalid column names. 1943 | 1944 | =item int table::nofCol 1945 | 1946 | return number of columns. 1947 | 1948 | =item int table::nofRow 1949 | 1950 | return number of rows. 1951 | 1952 | =item scalar table::elm ($rowIdx, $colID) 1953 | 1954 | return the value of a table element at [$rowIdx, $colID], 1955 | undef if $rowIdx or $colID is invalid. 1956 | 1957 | =item refto_scalar table::elmRef ($rowIdx, $colID) 1958 | 1959 | return the reference to a table element at [$rowIdx, $colID], to allow possible modification. 1960 | It returns undef for invalid $rowIdx or $colID. 1961 | 1962 | =item array table::header ($header) 1963 | 1964 | Without argument, it returns an array of column names. 1965 | Otherwise, use the new header. 1966 | 1967 | =item int table::type 1968 | 1969 | return the implementation type of the table (row-based/column-based) at the time, 1970 | be aware that the type of a table should be considered as volatile during method calls. 1971 | 1972 | =back 1973 | 1974 | =head2 Table Formatting 1975 | 1976 | =over 4 1977 | 1978 | =item string table::csv ($header, {OS=>$Data::Table::DEFAULTS{'OS'}, file=>undef, delimiter=>$Data::Table::DEFAULTS{'CSV_DELIMITER'}, qualifier=>$Data::Table::DEFAULTS{'CSV_QAULIFIER'}}) 1979 | 1980 | return a string corresponding to the CSV representation of the table. 1981 | $header controls whether to print the header line, 1 for yes, 0 for no. 1982 | optional named argument OS specifies for which operating system the CSV file is generated. 0 for UNIX, 1 for P 1983 | C and 2 for MAC. If not specified, $Data::Table::DEFAULTS{'OS'} is used. Basically linebreak is defined as "\n", "\r\n" and "\r" for three systems, respectively. 1984 | if 'file' is given, the csv content will be written into it, besides returning the string. 1985 | One may specify custom delimiter and qualifier if the other than default are desired. 1986 | 1987 | =item string table::tsv 1988 | 1989 | return a string corresponding to the TSV representation of the table. 1990 | $header controls whether to print the header line, 1 for yes, 0 for no. 1991 | optional named argument OS specifies for which operating system the TSV file is generated. 0 for UNIX, 1 for P 1992 | C and 2 for MAC. If not specified, $Data::Table::DEFAULTS{'OS'} is used. Basically linebreak is defined as "\n", "\r\n" and "\r" for three systems, respectively. 1993 | if 'file' is given, the tsv content will be written into it, besides returning the string. 1994 | 1995 | Note: read "TSV FORMAT" section for details. 1996 | 1997 | =item string table::html ($colors = ["#D4D4BF","#ECECE4","#CCCC99"], 1998 | $tag_tbl = {border => '1'}, 1999 | $tag_tr = {align => 'left'}, 2000 | $tag_th = {align => 'center'}, 2001 | $tag_td = {col3 => 'align="right" valign="bottom"', 4 => 'align="left"'}, 2002 | $l_portrait = 1 2003 | ) 2004 | 2005 | return a string corresponding to a 'Portrait/Landscape'-style html-tagged table. 2006 | $colors: a reference to an array of three color strings, used for backgrounds for table header, odd-row records, and even-row records, respectively. 2007 | A default color array ("#D4D4BF","#ECECE4","#CCCC99") 2008 | will be used if $colors isn't defined. 2009 | 2010 | $tag_tbl: a reference to a hash that specifies any legal attributes such as name, border, 2011 | id, class, etc. for the TABLE tag. 2012 | 2013 | $tag_tr: a reference to a hash that specifies any legal attributes for the TR tag. 2014 | 2015 | $tag_th: a reference to a hash that specifies any legal attributes for the TH tag. 2016 | 2017 | $tag_td: a reference to a hash that specifies any legal attributes for the TD tag. 2018 | 2019 | Notice $tag_tr and $tag_th controls all the rows and columns of the whole table. The keys of the hash are the attribute names in these cases. However, $tag_td is column specific, i.e., you should specify TD attributes for every column separately. 2020 | The key of %$tag_td are either column names or column indices, the value is the full string to be inserted into the TD tag. E.g., $tag_td = {col3 => 'align=right valign=bottom} only change the TD tag in "col3" to be <TD align=right valign=bottom>. 2021 | 2022 | $portrait controls the layout of the table. The default is 1, i.e., the table is shown in the 2023 | "Portrait" style, like in Excel. 0 means "Landscape". 2024 | 2025 | Attention: You will have to escape HTML-Entities yourself (for example '<' as '<'), if you have characters in you table which need to be escaped. You can do this for example with the escapeHTML-function from CGI.pm (or the HTML::Entities module). 2026 | 2027 | use CGI qw(escapeHTML); 2028 | [...] 2029 | $t->colMap($columnname, sub{escapeHTML($_)}); # for every column, where HTML-Entities occur. 2030 | 2031 | =item string table::html2 ($colors = ["#D4D4BF","#ECECE4","#CCCC99"], 2032 | $specs = {'name' => '', 'border' => '1', ...}) 2033 | 2034 | This method is deprecated. It's here for compatibility. It now simple call html method with $portrait = 0, see previous description. 2035 | 2036 | return a string corresponding to a "Landscape" html-tagged table. 2037 | This is useful to present a table with many columns, but very few entries. 2038 | Check the above table::html for parameter descriptions. 2039 | 2040 | =back 2041 | 2042 | =head2 Table Operations 2043 | 2044 | =over 4 2045 | 2046 | =item int table::setElm ($rowIdx, $colID, $val) 2047 | 2048 | modify the value of a table element at [$rowIdx, $colID] to a new value $val. 2049 | It returns 1 upon success, undef otherwise. 2050 | 2051 | 2052 | =item int table::addRow ( $rowRef, $rowIdx = table::nofRow) 2053 | 2054 | add a new row ($rowRef points to the actual list of scalars), the new row will be referred as $rowIdx as the result. E.g., addRow($aRow, 0) will put the new row as the very first row. 2055 | By default, it appends a row to the end. 2056 | It returns 1 upon success, undef otherwise. 2057 | 2058 | =item refto_array table::delRow ( $rowIdx ) 2059 | 2060 | delete a row at $rowIdx. It will the reference to the deleted row. 2061 | 2062 | =item refto_array table::delRows ( $rowIdcsRef ) 2063 | 2064 | delete rows in @$rowIdcsRef. It will return an array of deleted rows 2065 | upon success. 2066 | 2067 | =item int table::addCol ($colRef, $colName, $colIdx = numCol) 2068 | 2069 | add a new column ($colRef points to the actual data), the new column will be referred as $colName or $colIdx as the result. E.g., addCol($aCol, 'newCol', 0) will put the new column as the very first column. 2070 | By default, append a row to the end. 2071 | It will return 1 upon success or undef otherwise. 2072 | 2073 | =item refto_array table::delCol ($colID) 2074 | 2075 | delete a column at $colID 2076 | return the reference to the deleted column. 2077 | 2078 | =item arrayof_refto_array table::delCols ($colIDsRef) 2079 | 2080 | delete a list of columns, pointed by $colIDsRef. It will 2081 | return an array of deleted columns upon success. 2082 | 2083 | =item refto_array table::rowRef ($rowIdx) 2084 | 2085 | return a reference to the row at $rowIdx 2086 | upon success or undef otherwise. 2087 | 2088 | =item refto_arrayof_refto_array table::rowRefs ($rowIdcsRef) 2089 | 2090 | return a reference to array of row references upon success, undef otherwise. 2091 | 2092 | =item array table::row ($rowIdx) 2093 | 2094 | return a copy of the row at $rowIdx 2095 | upon success or undef otherwise. 2096 | 2097 | =item refto_hash table::rowHashRef ($rowIdx) 2098 | 2099 | return a reference to a hash, which contains a copy of the row at $rowIdx, 2100 | upon success or undef otherwise. The keys in the hash are column names, and 2101 | the values are corresponding elements in that row. The hash is a copy, therefore modifying the hash values doesn't change the original table. 2102 | 2103 | =item refto_array table::colRef ($colID) 2104 | 2105 | return a reference to the column at $colID 2106 | upon success. 2107 | 2108 | =item refto_arrayof_refto_array table::colRefs ($colIDsRef) 2109 | 2110 | return a reference to array of column references upon success. 2111 | 2112 | =item array table::col ($colID) 2113 | 2114 | return a copy to the column at $colID 2115 | upon success or undef otherwise. 2116 | 2117 | =item int table::rename ($colID, $newName) 2118 | 2119 | rename the column at $colID to a $newName 2120 | (the newName must be valid, 2121 | and should not be identical to any other existing column names). 2122 | It returns 1 upon success 2123 | or undef otherwise. 2124 | 2125 | =item refto_array table::replace ($oldColID, $newColRef, $newName) 2126 | 2127 | replace the column at $oldColID by the array pointed by $newColRef, and renamed it to $newName. $newName is optional if you don't want to rename the column. 2128 | It returns 1 upon success or undef otherwise. 2129 | 2130 | =item int table::swap ($colID1, $colID2) 2131 | 2132 | swap two columns referred by $colID1 and $colID2. 2133 | It returns 1 upon success or undef otherwise. 2134 | 2135 | =item int table::colMap ($colID, $fun) 2136 | 2137 | foreach element in column $colID, map a function $fun to it. 2138 | It returns 1 upon success or undef otherwise. 2139 | This is a handy way to format a column. E.g. if a column named URL contains URL strings, colMap("URL", sub {"$_"}) before html() will change each URL into a clickable hyper link while displayed in a web browser. 2140 | 2141 | =item int table::colsMap ($fun) 2142 | 2143 | foreach row in the table, map a function $fun to it. 2144 | It can do whatever colMap can do and more. 2145 | It returns 1 upon success or undef otherwise. 2146 | colMap function only give $fun access to the particular element per row, while colsMap give $fun full access to all elements per row. E.g. if two columns named duration and unit (["2", "hrs"], ["30", "sec"]). colsMap(sub {$_->[0] .= " (".$_->[1].")"; } will change each row into (["2 hrs", "hrs"], ["30 sec", "sec"]). 2147 | As show, in the $func, a column element should be referred as $_->[$colIndex]. 2148 | 2149 | =item int table::sort($colID1, $type1, $order1, $colID2, $type2, $order2, ... ) 2150 | 2151 | sort a table in place. 2152 | First sort by column $colID1 in $order1 as $type1, then sort by $colID2 in $order2 as $type2, ... 2153 | $type is 0 for numerical and 1 for others; 2154 | $order is 0 for ascending and 1 for descending; 2155 | Sorting is done in the priority of colID1, colID2, ... 2156 | It returns 1 upon success or undef otherwise. 2157 | Notice the table is rearranged as a result! This is different from perl's list sort, which returns a sorted copy while leave the original list untouched, 2158 | the authors feel inplace sorting is more natural. 2159 | 2160 | table::sort can take a user supplied operator, this is useful when neither numerical nor alphabetic order is correct. 2161 | 2162 | $Well=["A_1", "A_2", "A_11", "A_12", "B_1", "B_2", "B_11", "B_12"]; 2163 | $t = new Data::Table([$Well], ["PlateWell"], 1); 2164 | $t->sort("PlateWell", 1, 0); 2165 | print join(" ", $t->col("PlateWell")); 2166 | # prints: A_1 A_11 A_12 A_2 B_1 B_11 B_12 B_2 2167 | # in string sorting, "A_11" and "A_12" appears before "A_2"; 2168 | my $my_sort_func = sub { 2169 | my @a = split /_/, $_[0]; 2170 | my @b = split /_/, $_[1]; 2171 | my $res = ($a[0] cmp $b[0]) || (int($a[1]) <=> int($b[1])); 2172 | }; 2173 | $t->sort("PlateWell", $my_sort_func, 0); 2174 | print join(" ", $t->col("PlateWell")); 2175 | # prints the correct order: A_1 A_2 A_11 A_12 B_1 B_2 B_11 B_12 2176 | 2177 | =item table table::match_pattern ($pattern, $countOnly) 2178 | 2179 | return a new table consisting those rows evaluated to be true by $pattern 2180 | upon success or undef otherwise. If $countOnly is set to 1, it simply returns the number of rows that matches the string without making a new copy of table. $countOnly is 0 by default. 2181 | 2182 | Side effect: @Data::Table::OK stores a true/false array for the original table rows. Using it, users can find out what are the rows being selected/unselected. 2183 | In the $pattern string, a column element should be referred as $_->[$colIndex]. E.g., match_pattern('$_->[0]>3 && $_->[1]=~/^L') retrieve all the rows where its first column is greater than 3 and second column starts with letter 'L'. Notice it only takes colIndex, column names are not acceptable here! 2184 | 2185 | =item table table::match_string ($s, $caseIgnore, $countOnly) 2186 | 2187 | return a new table consisting those rows contains string $s in any of its fields upon success, undef otherwise. if $caseIgnore evaluated to true, case will is be ignored (s/$s/i). If $countOnly is set to 1, it simply returns the number of rows that matches the string without making a new copy of table. $countOnly is 0 by default. 2188 | 2189 | Side effect: @Data::Table::OK stores a true/false array for the original table rows. 2190 | Using it, users can find out what are the rows being selected/unselected. 2191 | The $s string is actually treated as a regular expression and 2192 | applied to each row element, therefore one can actually specify several keywords 2193 | by saying, for instance, match_string('One|Other'). 2194 | 2195 | =item table table::rowMask($mask, $complement) 2196 | 2197 | mask is reference to an array, where elements are evaluated to be true or false. The size of the mask must be equal to the nofRow of the table. return a new table consisting those rows where the corresponding mask element is true (or false, when complement is set to true). 2198 | 2199 | E.g., $t1=$tbl->match_string('keyword'); $t2=$tbl->rowMask(\@Data::Table::OK, 1) creates two new tables. $t1 contains all rows match 'keyword', while $t2 contains all other rows. 2200 | 2201 | mask is reference to an array, where elements are evaluated to be true or false. The size of the mask must be equal to the nofRow of the table. return 2202 | a new table consisting those rows where the corresponding mask element is true (or false, when complement is set to true). 2203 | 2204 | E.g., $t1=$tbl->match_string('keyword'); $t2=$tbl->rowMask(\@Data::Table::OK, 1) creates two new tables. $t1 contains all rows match 'keyword', while 2205 | $t2 contains all other rows. 2206 | 2207 | =item table table::group($colsToGroupBy, $colsToCalculate, $funsToApply, $newColNames) 2208 | 2209 | Primary key columns are specified in $colsToGroupBy. All rows are grouped by primary keys first. Then for each group, an array of subroutines (in $funsToAppy) are applied to corresponding columns and yield a list of new columns (specified in $newColNames). 2210 | 2211 | $colsToGroupBy, $colsToCalculate are references to array of colIDs. $funsToApply is a reference to array of subroutine references. $newColNames are a 2212 | reference to array of new column name strings. If specified, the size of arrays pointed by $colsToCalculate, $funsToApply and $newColNames should be i 2213 | dentical. A column may be used more than once in $colsToCalculate. 2214 | 2215 | E.g., an employee salary table $t contains the following columns: Name, Sex, Department, Salary. (see examples in the SYNOPSIS) 2216 | 2217 | $t2 = $t->group(["Department","Sex"],["Name", "Salary"], [sub {scalar @_}, \&average], ["Nof Employee", "Average Salary"]); 2218 | 2219 | Department, Sex are used together as the primary key columns, a new column "Nof Employee" is created by counting the number of employee names in each group, a new column "Average Salary" is created by averaging the Salary data falled into each group. As the result, we have the head count and average salary information for each (Department, Sex) pair. With your own functions (such as sum, product, average, standard deviation, etc), group method is very handy for accounting purpose. 2220 | 2221 | =item table table::pivot($colToSplit, $colToSplitIsNumeric, $colToFill, $colsToGroupBy, $keepRestCols) 2222 | 2223 | Every unique values in a column (specified by $colToSplit) become a new column. undef value become "NULL". If the column type is numeric (specified by $colToSplitIsNumeric), the new column names are prefixed by "oldColumnName=". The new cell element is filled by the value specified by $colToFill. 2224 | 2225 | When primary key columns are specified by $colsToGroupBy, all records sharing the same primary key collapse into one row, with values in $colToFill filling the corresponding new columns. If $colToFill is not specified, a cell is filled with 1 if there is a corresponding data record in the original table. 2226 | 2227 | $colToSplit and $colToFill are colIDs. $colToSplitIsNumeric is 1/0. $colsToGroupBy is a reference to array of colIDs. $keepRestCols is 1/0, by default is 0. If $keepRestCols is off, only primary key columns and new columns are exported, otherwise, all the rest columns are exported as well. 2228 | 2229 | E.g., applying pivot method to the resultant table of the example of the group method. 2230 | 2231 | $t2->pivot("Sex", 0, "Average Salary",["Department"]); 2232 | 2233 | This creates a 2x3 table, where Departments are use as row keys, Sex (female and male) become two new columns. "Average Salary" values are used to fill the new table elements. Used together with group method, pivot method is very handy for account type of analysis. 2234 | 2235 | =back 2236 | 2237 | =head2 Table-Table Manipulations 2238 | 2239 | =over 4 2240 | 2241 | =item int table::rowMerge ($tbl) 2242 | 2243 | Append all the rows in the table object $tbl to the original rows. 2244 | The merging table $tbl must have the same number of columns as the original. 2245 | It returns 1 upon success, undef otherwise. 2246 | The table object $tbl should not be used afterwards, since it becomes part of 2247 | the new table. 2248 | 2249 | =item int table::colMerge ($tbl) 2250 | 2251 | Append all the columns in table object $tbl to the original columns. 2252 | Table $tbl must have the same number of rows as the original. 2253 | It returns 1 upon success, undef otherwise. 2254 | Table $tbl should not be used afterwards, since it becomes part of 2255 | the new table. 2256 | 2257 | =item table table::join ($tbl, $type, $cols1, $cols2) 2258 | 2259 | Join two tables. The following join types are supported (defined by $type): 2260 | 2261 | 0: inner join 2262 | 1: left outer join 2263 | 2: right outer join 2264 | 3: full outer join 2265 | 2266 | $cols1 and $cols2 are references to array of colIDs, where rows with the same elements in all listed columns are merged. As the result table, columns listed in $cols2 are deleted, before a new table is returned. 2267 | 2268 | The implementation is hash-join, the running time should be linear with respect to the sum of number of rows in the two tables (assume both tables fit in memory). 2269 | 2270 | =back 2271 | 2272 | =head2 Internal Methods 2273 | 2274 | All internal methods are mainly implemented for used by 2275 | other methods in the Table class. Users should avoid using them. 2276 | Nevertheless, they are listed here for developers who 2277 | would like to understand the code and may derive a new class from Data::Table. 2278 | 2279 | =over 4 2280 | 2281 | =item int table::rotate 2282 | 2283 | convert the internal structure of a table between row-based and column-based. 2284 | return 1 upon success, undef otherwise. 2285 | 2286 | =item string csvEscape($rowRef) 2287 | 2288 | Encode an array of scalars into a CSV-formatted string. 2289 | 2290 | optional named arguments: delimiter and qualifier, in case user wants to use characters other than the defaults. 2291 | The default delimiter and qualifier is taken from $Data::Table::DEFAULTS{'CSV_DELIMITER'} (defaults to ',') and $Data::Table::DEFAULTS{'CSV_QUALIFIER'} (defaults to '"'), respectively. 2292 | 2293 | =item refto_array parseCSV($string) 2294 | 2295 | Break a CSV encoded string to an array of scalars (check it out, we did it the cool way). 2296 | 2297 | optional argument size: specify the expected number of fields after csv-split. 2298 | optional named arguments: delimiter and qualifier, in case user wants to use characters other than the defaults. 2299 | respectively. The default delimiter and qualifier is taken from $Data::Table::DEFAULTS{'CSV_DELIMITER'} (defaults to ',') and $Data::Table::DEFAULTS{'CSV_QUALIFIER'} (defaults to '"'), respectively. 2300 | 2301 | =item string tsvEscape($rowRef) 2302 | 2303 | Encode an array of scalars into a TSV-formatted string. 2304 | 2305 | =back 2306 | 2307 | =head1 TSV FORMAT 2308 | 2309 | There is no standard for TSV format as far as we know. CSV format can't handle binary data very well, therefore, we choose the TSV format to overcome this limitation. 2310 | 2311 | We define TSV based on MySQL convention. 2312 | 2313 | "\0", "\n", "\t", "\r", "\b", "'", "\"", and "\\" are all escaped by '\' in the TSV file. 2314 | (Warning: MySQL treats '\f' as 'f', and it's not escaped here) 2315 | Undefined values are represented as '\N'. 2316 | 2317 | =head1 INTERFACE TO OTHER SOFTWARES 2318 | 2319 | Spreadsheet is a very generic type, therefore Data::Table class provides an easy 2320 | interface between databases, web pages, CSV/TSV files, graphics packages, etc. 2321 | 2322 | Here is a summary (partially repeat) of some classic usages of Data::Table. 2323 | 2324 | =head2 Interface to Database and Web 2325 | 2326 | use DBI; 2327 | 2328 | $dbh= DBI->connect("DBI:mysql:test", "test", "") or die $DBI::errstr; 2329 | my $minAge = 10; 2330 | $t = Data::Table::fromSQL($dbh, "select * from mytable where age >= ?", [$minAge]); 2331 | print $t->html; 2332 | 2333 | =head2 Interface to CSV/TSV 2334 | 2335 | $t = fromFile("mydata.csv"); # after version 1.51 2336 | $t = fromFile("mydata.tsv"); # after version 1.51 2337 | 2338 | $t = fromCSV("mydata.csv"); 2339 | $t->sort(1,1,0); 2340 | print $t->csv; 2341 | 2342 | Same for TSV 2343 | 2344 | =head2 Interface to Excel 2345 | 2346 | Convert between an Excel file and tables 2347 | see Data::Table::Excel 2348 | 2349 | =head2 Interface to Graphics Package 2350 | 2351 | use GD::Graph::points; 2352 | 2353 | $graph = GD::Graph::points->new(400, 300); 2354 | $t2 = $t->match('$_->[1] > 20 && $_->[3] < 35.7'); 2355 | my $gd = $graph->plot($t->colRefs([0,2])); 2356 | open(IMG, '>mygraph.png') or die $!; 2357 | binmode IMG; 2358 | print IMG $gd->png; 2359 | close IMG; 2360 | 2361 | =head1 AUTHOR 2362 | 2363 | Copyright 1998-2008, Yingyao Zhou & Guangzhou Zou. All rights reserved. 2364 | 2365 | It was first written by Zhou in 1998, significantly improved and maintained by Zou since 1999. The authors thank Tong Peng and Yongchuang Tao for valuable suggestions. We also thank those who kindly reported bugs, some of them are acknowledged in the "Changes" file. 2366 | 2367 | This library is free software; you can redistribute it and/or modify 2368 | it under the same terms as Perl itself. 2369 | 2370 | Please send bug reports and comments to: easydatabase at gmail dot com. When sending 2371 | bug reports, please provide the version of Table.pm, the version of 2372 | Perl. 2373 | 2374 | =head1 SEE ALSO 2375 | 2376 | Data::Table::Excel, DBI, GD::Graph. 2377 | 2378 | =cut 2379 | 2380 | --------------------------------------------------------------------------------