#*********************************************************************
+********
# public create
# *************
# Uses:     Saves the given object into the database  
# Params:    HASH with new object attributes
# Return:    The inserted object, or undef if the Object can't be inse
+rted 
#*********************************************************************
+********
sub create {
    
    my $class = shift;
    my ($param) = @_;
    my $dbh = Jnms::Database::Control::DatabaseManager->get_database->
+{dbh};
    
    my $id;
    my $error;
    # check if the required fields are there and insert on the db
    #print STDERR Dumper($class,$param);
    $class->_check_required_create_fields($param);
    eval{
        $id = $class->_insert_into_database($param);
        $dbh->commit;
    };
    if ($@) {
             warn "Transaction aborted because $@";
             $error = $@;
             # now rollback to undo the incomplete changes
             # but do it in an eval{} as it may also fail
             eval { $dbh->rollback };
             die "Transaction aborted because of $error";
             # add other application on-error-clean-up code here
    }    
    #return the inserted object
    return $class->find($id);    
}
#*********************************************************************
+********
# public list_all
# ***************
# Uses:     gets all Objects that matches the child class type from th
+e db  
# Params:    None.
# Return:    an ARRAY of all Objects of the requested type 
#*********************************************************************
+********
sub list_all {
    
    my $class = shift;
    my ($param) = @_;
    
    my $dbh = Jnms::Database::Control::DatabaseManager->get_database->
+{dbh};
    # get the constants specified on the child class
    my $columns = join(', ', $class->TABLE_COLUMNS);
    my $table = $class->TABLE_NAME;
    my $order = $class->LIST_ORDER;
    my @column_values = ();
    
    my $objects = $dbh->selectall_arrayref("SELECT $columns FROM $tabl
+e ORDER BY $order", {Slice=>{}}, @column_values);
    
    bless($_, ref($class) || $class) foreach @$objects;
    
    my $depth = 0;
    if (ref $param eq 'HASH') {
        $depth = $param->{depth};
    }
    elsif($param) {
        $depth = $param;
    }
    unless(defined $depth){ $depth = 0; }
    $objects = $class->_find_foreign_keys($objects, $depth);

    return $objects;
}
[download]

use strict;
#use gd;
print "\nRunning Barcode... \n\n";

my $text = "333";

use Barcode::Code128 'FNC1';
my $object = new Barcode::Code128;
$object->text(FNC1.'00000123455555555558');

$object->png($text);

open(PNG, ">h:/perl/code128.png") or die "Can't write code128.png: $!\
+n";
binmode(PNG);
print PNG $object->png("CODE 128");
close(PNG);
[download]

I need to find every possible combination for putting x objects in y containers. All objects have to be used in every possibility. I have been searching the web but nothing seems to really fit.

So given 5 objects I need to come up with all combinations of these 5 objects that could fit in 3 containers. Possiblity one could be 12 34 5 while two would be 1 23 45 and so on.

Hello. Does a lock still work correct, if I overwrite a locked file while it is locked? Illustration:

...
sub do_log {
    ...
    sysopen my $fh, $logfile, O_RDWR|O_CREAT or do {...};
    my $tmp_file = "${logfile}_tmp";
    open my $tmp_fh, '>', "$tmp_file" or do {...};
    if (flock $fh, LOCK_EX) {            #exclusive lock
        while (<$fh>) {
            ..
            my $line = $_;
            ..
            print $tmp_fh $line, "\n";
        }
        close $tmp_fh or die "Can't close tmp_file: $!";
        move($tmp_file, $logfile);
    }
    close $fh or die "Can't close logfile $!";  #unlocks automatic
}
[download]

I have had a perl snippet to manipulate data from database. Now I intend to make a tree view interface as the front end of it for end users so that they can sort, remove, and add the data easily.

• this gui interface will be running on windows.
  
• gtk2-perl can't be installed by cpan or ppm on M$ easily.
  
• I have to embed perl into C if I write gui interface in Gtk+. But I'm afraid that it will take too much time for me since I don't have any try on embedding before.
  

So which way should I choose for the sake of saving time:

• rewrite code in c totally
• install gtk+-perl a thousand times ;)
• embed perl into c

print -localtime, $/;
print +localtime, $/;
print +gmtime, $/;
print -+gmtime, $/;
__END__
-Fri Nov  6 01:10:44 2009
4417161010953090
4417961010953090
-Fri Nov  6 09:10:44 2009
[download]

I'm relatively new to Moose. I'm trying to add the concept of a cached attribute. Essentially, there is a timestamp that is associated with an attribute, which is checked on each access. If the timestamp is older than a certain threshold, the value gets cleared (by the clearer function), and then the value will automatically be refetched (e.g. from the Database) by the build function.

The code to do the timers and database fetch is very straightforward.

What is less straightforward is the best way to do this in Moose. I have a somewhat reasonable solution, but I'd bet someone will have a far more elegant solution.

My solution works like this: you must declare an "around" method modifier, and pass the name of the attribute to a utility function. The utility function will automatically create a timer associated with the attribute (if needed), as well as reset the timer, and call the clearer method.

It occurs to me that this could be done more cleanly. For one, in the around method I must specify the name of the attribute twice. This allows me to use the same function (named "around_timer_cached" below) generically for all the attributes (note that the around method modifier passes the coderef, but not the attribute, which seems like a flaw). E.g.

around 'some_attribute' => sub { around_timer_cached ('some_attribute'
+, @_) };
[download]

Is there a more elegant way to get the attribute name in the called "around" method? Also, is there a way to extend the attribute system so that this could just be yet another declarative parameter passed into the "has" decl (e.g. cached_secs => 600).

Finally, has someone already done such extensions to the attribute system?

Hey Folks,

I Frequently use perl to process 2 files line by line.

Most of the times I compare two files line by line and check if one line is same to corresponding line of other file, or if one line is substring of other line etc and many more operations.

The technique which I generally use is to first save lines of two files in 2 different arrays.

Then execute a for loop where I compare corresponding index elements of the 2 arrays.

I guess this is not an optimize solution since if both files are huge creating large sized arrays may consume lot of memory.

So wanted to know if there is any better approach to process 2 files line by line.

Cheers,

Parag

We are using perlxs with C++ code and we are trying to support the Itanium platform. This code works on Solaris, Windows, and non-Itanium HP-UX. In the past we have had problems with HP-UX and the "Exec Format Error", to resolve this we used the '+A' link option to embed the funcions from the standard libraries in our shared library. With Itanium the aCC compiler is no longer supporting the '+A' link option.

My understanding of the "Exec Format Error" is that either our shared library isn't resolving something or it is conflicting something in our perl installation. Unfortunately I cannot determine what it is or how to resolve it. I tried building our shared library as closely as we can to the our perl installation. As well as setting the LD_LIBRARY_PATH to where our shared libraries exist.

How do I resolve this or get more information on what is failing.

Thanks for you time,

Kevin Roy

Hello Monks

I'm looking for any advise on doing something which is pretty much impossible to guarantee (and also a subject that has been beaten to death, so sorry for bring it up again).

We have a custom "forums type" application where we want to try to track the truly unique page views per person/machine as we plan to give incentives to those that are the most popular/most viewed.

Right now I'm planning on starting with just IP's and cookies (will probably be looking at flash shared objects soon).

I'm interested in anyone's opinions on a better approach then what I'm currently doing and also if anyone has any ideas on how to best deal with cookie size.

The plan so far is this

1. Have a table created that stores a page view, the table will have the message id, IP address, date viewed and a user id (if the person is logged in).

for example:

create table Views (
id int(11),
UserId int(11),
IPAddress varchar(15),
DateAdded timestamp default current_timestamp
)
[download]

if ($session_data->{'LoggedIn'}) {
    $existing_view = $db->selectall_arrayref(qq|Select DateAdded from 
+Views where Id = ? and (IPAddress = ? or UserId = ?)|,undef,($id,$r->
+connection->remote_ip,$userid));
} else {
    $existing_view = $db->selectall_arrayref(qq|Select DateAdded from 
+Views where Id = ? and IPAddress = ?|,undef,($id,$r->connection->remo
+te_ip));
}
[download]

unless (@$existing_view) {
 # get our cookie of id's
 if ($cookie) {
  unless ( grep { $_ == $id } @cookieids ) {
   if ($user_session_data->{'LoggedIn'} == 1) {
    $db->do(qq|Insert into Views (thread_id,IPAddress,UserId) values (
+?,?,?)|,undef,($id,$r->connection->remote_ip,$userid));
   } else {
    $db->do(qq|Insert into Views (thread_id,IPAddress) values (?,?)|,u
+ndef,($id,$r->connection->remote_ip));
   }
   $cookie = $existing_cookie . $new_cookie;
} else {
 $cookie = $id;
}
# set the new cookie
[download]

Right now what bothers me most about the above is there is no real limit to the size of the cookie as it could kept getting added to forever, which means at some point it will be too big.

TIA for any help!

use strict;
use warnings;
use XML::XPath;

my $file = $ARGV[0];
my $xp = XML::XPath->new(filename=>$file);
for my $n (1 .. 32812) {

my $wnposnodeset = $xp->find('/e/p//w[@id='.$n.']/a[@name="wn"]');
my @wns;
if (my @wnnodelist = $wnnodeset->get_nodelist) {
@wns = map($_->string_value, @wnnodelist);}

my $lnodeset = $xp->find('/e/p//w[@id='.$n.']/a[@name="l"]');
my @ls;
if (my @lnodelist = $lnodeset->get_nodelist) {
@ls = map($_->string_value, @lnodelist);}

print "@ls#@wns\n";
}
[download]

How to get PDF information using PDF::API2

This below code will display page count information

use strict;
use vars qw(@ISA %pgsz $VERSION);

@ISA = qw(PDF::API2::Basic::PDF::Pages);
use PDF::API2::Basic::PDF::Pages;
use PDF::API2::Basic::PDF::Utils;
use PDF::API2::Util;

use PDF::API2::Annotation;

use PDF::API2::Content;
use PDF::API2::Content::Text;

use PDF::API2::Util;

use POSIX qw(floor ceil);
use Math::Trig;use strict;
use PDF::API2;


my $pf = 'mypdffile.pdf';
my $pdf = PDF::API2->open($pf) or die $!;

print "Starting analysis of $pf...\n";
my $pagenumber = $pdf->pages;
print "$pagenumber pages.\n";
my %opts = $pdf->info;
while (my ($k, $v) = each %opts) 
{
print "option $k is: $v\n" 
}
[download]

I want to get info what kind of page label is used for PDF page i.e. Roman/Arabic or named page.

$ perl -le'$x=0.05;$y=sqrt($x+$x+$x);$g="$y";print "Is $y equal to $g?
+";print $y==$g?"Yes":"No"'
Is 0.387298334620742 equal to 0.387298334620742?
No
[download]

So, dear monks, how do you see yourself in reference to the race I mentioned, now and in forthcoming years? I am somewhat exhausted, but my enthusiasm continues. I am worrying about the confidence level, because when I am looking for job, I need higher confidence.

#!/usr/bin/perl -w
use UI::Dialog; # sudo apt-get install libui-dialog-perl

my $statement = "My name is $0...\n";

my $d1 = new UI::Dialog(title => 'I know my name');
$d1->msgbox(text => $statement);

print $statement;

exit;
[download]

1. The first time you open a terminal and type "perl knowthyself". You get this output: "My name is knowthyself..."
2. Then you use the terminal and type "./knowthyself". You get this output: "My name is ./knowthyself..."
3. Finally you go to your file manager (Nautilus) and click on the file. You are asked what to do: Do you want to run it in a terminal, do you want to show its contents, do you want to cancel the action, or do you want to just run it? Of course you choose this last action (run the program without opening a terminal). You get this output (in a window): My name is /home/user/Desktop/knowthyself...

This script runs through an Outlook Express mail folder and pulls out email information for all mail after a given date. The information is then inserted into a table in a MS Word document to build a correspondence list as part of a meeting agenda document.

Much of the code dealing with the location of things is hard wired and will need to be changed in (I hope) obvious ways for your own application.

(1 x $a) =~ /(?:$1)*(.*)/ and ($a, $b) = ($b, length $1) while $b
[download]

($a, $b) = ($b, $a =~ /(?:$1)*(.*)/) while $b
[download]