A large collection of programming examples I have accumulated over the years. Most of them were in files called "test1", "test2", "testme", etc
C command line arguments
I always forget how to access C command line arguements, because I only type out the code once per program I create.
Code
#include <stdio.h>
#include <sys/prctl.h>
int main (int argc, char *argv[])
{
int count;
printf ("This program was called with \"%s\".\n",argv[0]);
if (argc > 1)
{
for (count = 1; count < argc; count++)
{
printf("argv[%d] = %s\n", count, argv[count]);
}
}
else
{
printf("The command had no other arguments.\n");
}
return 0;
}
Compile
gcc printArgs.c -o printArgs
Run
./printArgs a b c d
Output
This program was called with "./printArgs".
argv[1] = a
argv[2] = b
argv[3] = c
argv[4] = d
Scope of Perl's error messages
Recently one of my coworkers wasn't sure if Perl's error handling was working correctly, so we created this test case. It shows that Perl's die() call causes an error that moves up the call stack correctly, and not via lexical scope.
$@="";
eval {
func();
print "Die caught in dynamic scope",$@, "\n";
};
sub func {
eval { die " " };
}
print "Lexical scope does not see an error: ", $@, "\n";
Output
Die caught in dynamic scope at test.pl line 11.
Lexical scope does not see an error:
Test Perl's variable aliasing
Code
use strict;
use Data::Dumper;
my @fruits = ( "apple", "banana", "pear");
foreach my $fruit ( @fruits ) {
$fruit =~ s/(\w)/\U$1\E/g; #Regular expression to make the string UPPERCASE
}
print "List will be uppercase if aliasing works\n";
print Dumper \@fruits;
sub lower_case {
my $fruit = shift;
$fruit =~ s/(\w)/\L$1\E/g; #Regular expression to make the string lowercase
#print $fruit,"\n";
return $fruit;
}
foreach my $fruit ( @fruits ) {
lower_case($fruit);
}
print "\n\nList will be lowercase if aliasing works through function arguments\n";
print Dumper \@fruits;
foreach my $fruit ( @fruits ) {
$fruit = lower_case($fruit);
}
print "\n\nList will be lowercase if using the aliased variable as an lvalue works\n";
print Dumper \@fruits;
Output
List will be uppercase if aliasing works
$VAR1 = [
'APPLE',
'BANANA',
'PEAR'
];
List will be lowercase if aliasing works through function arguments
$VAR1 = [
'APPLE',
'BANANA',
'PEAR'
];
List will be lowercase if using the aliased variable as an lvalue works
$VAR1 = [
'apple',
'banana',
'pear'
];
Add a method to an object at runtime (monkey patch)
This demonstrates how to add a method to an object that has already been created. In general this is a terrible idea, but it is useful in some situations.
You can wrap the previous function to extend functionality in a library that you don't have access to.
Code
use strict;
my $obj = new demo_class();
#Add a new method from outside the object, at compile time
sub demo_class::new_method {
print "Compile time method insertion worked\n";
}
$obj->new_method();
#Add a new method from outside the object, at run time
my $obj_class = ref($obj);
my $tmp = sub {
print "Run time method insertion worked\n";
};
#disable safety system
no strict 'refs';
#add the function using a typeglob
*{$obj_class."::newer_method"} = $tmp;
$obj->newer_method();
#Our test class
package demo_class;
sub new {
my $class = shift;
return bless {}, $class;
}
Output
Compile time method insertion worked
Run time method insertion worked
Autoload
Code
use Data::Dumper;
sub AUTOLOAD {
print "Autoload called with $AUTOLOAD \n";
}
a_func_that_does_not_exist();
Output
Autoload called with main::a_func_that_does_not_exist
Partial regex (Regular Expression) matches
#!/usr/bin/perl
print "If a match half suceeeds, what happens to the match variables?\n";
my $test_string = "apple banana pear orange";
$test_string =~ m/(.+?) (.+?)/;
print "Matched $1, $2\n";
$test_string =~ m/(.+?) (blahblahblah)/;
print "Matched $1, $2\n";
print "The variables are unchanged in a partial match\n";
Output
If a match half suceeeds, what happens to the match variables?
Matched apple, b
Matched apple, b
The variables are unchanged in a partial match
Print a histogram of keys from a file organised into key=value lines
Change the = sign to the character your fields are separated by
my %count;
while (<>) {
my @arr = split /,/;
foreach (@arr) {
my ($key) = split /=/;
$count{$key}++;
}
}
while(($key,$value)=each %count){
printf ("%-8s %-40s",$value, $key);
for ($index = 1; $index <= $value/1000; $index++) {
print "*";
}
print "\n";
}
Deliberately create zombie processes on your system (for testing)
#include <stdlib.h>
#include <sys/types.h>
#include <unistd.h>
int main ()
{
pid_t child_pid;
child_pid = fork ();
if (child_pid > 0) {
sleep (600);
}
else {
exit (0);
}
return 0;
}
Call a JSON-RPC function
Example JSON 1.1 RPC call
use JSON::RPC::Client;
use strict;
use Data::Dumper;
my $client = new JSON::RPC::Client;
my $uri = 'http://127.0.0.1/rpc/'; #Replace with your server address
my $callobj = {
'method' => 'Method.Function', #Replace with the name of your call here
'params' => [
[
{
'ParamA' => 'ValA',
'ParamB' => 'ValB',
}
]
],
'version' => '1.1'
};
my $res = $client->call($uri, $callobj);
if($res) {
if ($res->is_error) {
print "Error : ", Dumper($res->error_message);
}
else {
print $res->result;
}
}
else {
print $client->status_line;
}
XML SemanticDiff example
use XML::SemanticDiff;
use XML::Diff;
use Data::Dumper;
my $file = shift;
my $file2 = shift;
my $diff = XML::SemanticDiff->new(keeplinenums => 1);
my %seen;
my %struct;
my %char;
my %tcount;
foreach my $change ($diff->compare($file, $file2)) {
next if ( $change->{message} =~ /different value/);
#unless ($seen{$change->{context}}) {print ")\n",$change->{context}, "\n (";}
my $c = $change->{context};
$c =~ s/\[.+?\]//g;
my @c = split /\//, $c;
shift @c;
$change->{message} =~ /'(.+?)'/;
#print $1, "\n";
#push @c, $1;
#push @c, $1;
push @c, "count";
$tcount{$1}++;
eval 'my $a = $char{'.join("}{", @c)."}++";
next if $change->{message} =~ /Character differences in element/;
eval 'my $a = $struct{'.join("}{", @c)."}";
$seen{$change->{context}}++;
$change->{message} =~ /'(.+?)'/;
#print $1,",";
}
print "Structural changes between the two files\n";
print Dumper \%struct;
print "Character (oontent) changes between the two files\n";
print Dumper \%char;
print "Differences in leaf tags\n";
print Dumper \%tcount;
What C type is this integer?
Prints out the C types that the test integer will fit into.
my $test = "2518231051";
my $sizes = {
"Unsigned (2^16)" => 2**16,
"Signed (2^15)" => 2**15,
"Unsigned (2^32)" => 2**32,
"Signed (2^31)" => 2**31,
"Unsigned (2^64)" => 2**64,
"Signed (2^63)" => 2**63,
};
while ( my ($key, $val) = each %$sizes ) {
if ($test > $val) { print "$test is larger than $key\n"};
if ($test < -$val) { print "$test is smaller than $key\n"};
if ($test < $val) { print "$test is smaller than $key\n"};
Check that each line in file 1 is present in file2
#!/usr/bin/perl
$f2name = shift;
$f1name = shift;
my $f1 = join "", `cat $f1name`;
my @lines = `cat $f2name`;
foreach my $l ( @lines ) {
$l =~ s/\s+/\\s*/g;
unless ( $f1 =~ m/$l/x ) {
print "Could not find: $l\n";
}
}