####
use strict;
use warnings;
use Data::Dumper;
my @television_headings = qw{ title alt_title start_year end_year
wikipedia allmovie imdb tvcom genre };
my @csv_television;
# creating dummy data for the example
foreach my $n ( 1 .. 3 )
{
push( @csv_television, join( '|', map { $_ . $n } @television_headings ) );
}
my $tv_hash = {};
load_h( $tv_hash, \@television_headings, \@csv_television );
print Dumper $tv_hash;
sub load_h
{
my ( $h, $headings, $csv_data ) = @_;
foreach my $line ( @$csv_data )
{
my @vals = split( /\Q|\E/, $line ); # might want a real CSV parser instead
my %data;
@data{ @$headings } = @vals; # hash slice
$h->{ $vals[0] } = \%data;
}
}
####
open(SHELL,">shell.sh");
print SHELL "cd $dir","\n";
print SHELL "cp $file $configParams{BASEDIR}";
system ("bash shell.sh") ;
close(SHELL);
####
# my original idea was to have a getter/setter for each "extended info" item:
sub pass_ticker_id{
my( $self, $value ) = @_;
if( defined $value ){
$self->{pass_ticker_id} = $value ? 1 : 0;
}
return $self->{pass_ticker_id};
}
# we could lump them together:
sub pass_extended_info{
my( $self, $value ) = @_;
if( defined $value ){
$self->{pass_ticker_id} = $value ? 1 : 0;
$self->{kitchen_sink} = $value ? 1 : 0;
}
return $value;
}
# the ticker methods could then be something like:
sub threaded_ids {
my( $self, $base ) = @_;
$self->{agent}->get( $self->{site}
. "?node_id=180684;id=$base" );
$self->{agent}->success()
or die "Unable to fetch thread ticker for id = $base.\n";
my $struct = XMLin(
$self->{agent}->content(),
ForceArray => 1,
KeepRoot => 1
);
my $ref = $self->pass_extended_info ?
{ 'ticker_id' => 180684, 'data' => $struct } :
$struct;
return $ref;
}
# if you wanted to lump the extended info into a single hash:
my $ref = $self->pass_extended_info ?
{ 'info' => { 'ticker_id' => 180684,
'kitchen_sink' => $self->{kitchen_sink} },
'data' => $struct } :
$struct;
# if the extended_info part was sub-ified:
sub threaded_ids {
my( $self, $base ) = @_;
$self->{agent}->get( $self->{site}
. "?node_id=180684;id=$base" );
$self->{agent}->success()
or die "Unable to fetch thread ticker for id = $base.\n";
my $struct = XMLin(
$self->{agent}->content(),
ForceArray => 1,
KeepRoot => 1
);
return $self->_format_struct( '180684', $struct );
}
sub _format_struct{
my( $self, $tickerid, $struct ) = @_;
my $ref = $self->pass_extended_info ?
{ 'ticker_id' => $tickerid, 'data' => $struct } :
$struct;
return $ref;
}
# or, to really make a mess of things:
sub threaded_ids {
my( $self, $base ) = @_;
my $url = $self->{site} . "?node_id=180684;id=$base";
$self->_get_ticker( $url ) or return;
return $self->_parse_struct( 180684 );
}
sub _get_ticker{
my( $self, $url ) = @_;
$self->{agent}->get( $url );
$self->{agent}->success() or
do{
warn "Unable to fetch ticker for $url\n";
return;
};
}
sub _parse_struct{
my( $self, $tickerid ) = @_;
my $struct = XMLin(
$self->{agent}->content(),
ForceArray => 1,
KeepRoot => 1
);
return $self->_format_struct( $tickerid, $struct );
}
####
# Grab info (title, date, reputation, etc) for a user's nodes.
# Uses the user node info XML Ticker (id://32704). If the
# "reputation" field is not required, foruser=userNameOrID can
# be used, which avoids requiring a login. Otherwise returns
# information about nodes by the logged-in user (or by Anonymous
# Monk if no login).
sub user_nodes {
my( $self, %params ) = @_;
my $parameters = '';
foreach( ( 'for_user', 'for_userid' ) ) {
$parameters .= exists( $params{$_} )
? ";$_=$params{$_}"
: '';
}
$self->{agent}->get(
$self->{site}
. "?node_id=32704;"
. $parameters
. $self->_login_URI()
);
$self->{agent}->success()
or die "Unable to fetch user nodes ticker.\n";
return XMLin(
$self->{agent}->content(),
ForceArray => 1
);
}
####
sub user_nodes {
my( $self, %params ) = @_;
my @allowed_params = ( 'for_user', 'for_userid' );
my $url = join( '', '?node_id=32704;',
get_param_list( \@allowed_params, %params ),
$self->_login_URI()
);
get_ticker( $self, $url, 'user nodes' );
return XMLin(
$self->{agent}->content(),
ForceArray => 1
);
}
sub get_param_list {
my ( $ref2allowed, %params ) = @_;
my $parameters = '';
foreach( @$ref2allowed ) {
$parameters .= exists( $params{$_} )
? ";$_=$params{$_}"
: '';
}
return $parameters;
}
sub get_ticker {
my ( $self, $url, $tickertype ) = @_;
$self->{agent}->get( $self->{site} . $url );
$self->{agent}->success()
or die "Unable to fetch $tickertype ticker.\n";
}
####
use strict;
use warnings;
use Data::Dumper;
use PerlMonks::Mechanized;
# pass username and password to 'new'
my $pm_obj = PerlMonks::Mechanized->new( 'xxxx', 'xxxx' );
my $root_node_id = 466016; # node used for example
my @node_ids = ( $root_node_id, $root_node_id + 1 );
#***********************************************************
print "PM object:\n";
print Dumper( $pm_obj );
{
print "user_stats:\n";
my $data = $pm_obj->user_stats( showall => 1 );
print Dumper( $data );
}
print "PM object:\n";
print Dumper( $pm_obj );
foreach my $method qw( threaded_ids
thread_list
node_info
node_content )
{
print "$method:\n";
my $data = $pm_obj->$method( $root_node_id );
print Dumper( $data );
}
foreach my $method qw( node_info
node_titles )
{
print "$method:\n";
my $data = $pm_obj->$method( @node_ids );
print Dumper( $data );
}
####
use strict;
use warnings;
use PerlMonks::Mechanized;
my $timeformat = '%Y-%m-%d %H:%M:%S'; # format for strftime
# should put username and password into ENV vars instead
my $pm_obj = PerlMonks::Mechanized->new( 'username', 'passwd' );
#***********************************************************
my @msgs;
my $since_id = 0; # get all messages
my $delay = 10; # num secs between page requests (init value)
my $max_recs = 100; # max # records to return at a time (init value)
while( 1 )
{
my ( $data, $info ) = $pm_obj->private_message(
archived => 'both',
xmlstyle => 'clean',
since_id => $since_id,
max_recs => $max_recs,
min_poll_seconds => $delay );
last if( not defined $data );
# update the max_recs and min_poll_seconds params
# based on the values in INFO
$delay = $info->[0]->{min_poll_seconds} || $delay;
$max_recs = $info->[0]->{max_recs} || $max_recs;
# save the msgs for processing (could just print now instead)
push( @msgs, @{ $data } );
# msgs are returned in ascending id order, so the
# last msg is the most recent
$since_id = $data->[-1]->{message_id};
print 'retrieved ', scalar @{ $data }, ' messages';
if( scalar @{ $data } <= $max_recs )
{
print "\n";
last;
}
print ", sleeping $delay secs\n";
sleep( $delay );
}
print "\nprivate messages:\n";
foreach my $msg ( @msgs )
{
my $datetime = format_datetime_string( $msg->{time},
$timeformat );
print "$datetime - $msg->{author}: $msg->{content}\n\n";
}
#***********************************************************
sub format_datetime_string
{
my ( $string, $format ) = @_;
# $string is of the format: YYYYMMDDhhmmss
# YYYY = 4 digit year
# MM = month, 1-12
# DD = day, 1-31
# hh = hour (24 hr scale, EST)
# mm = min
# ss = sec
my $year = substr( $string, 0, 4 );
my $month = substr( $string, 4, 2 );
my $day = substr( $string, 6, 2 );
my $hour = substr( $string, 8, 2 );
my $min = substr( $string, 10, 2 );
my $sec = substr( $string, 12, 2 );
# strftime expects $month to be 0..11 and
# $year to be num yrs since 1900
return POSIX::strftime( $format, $sec, $min, $hour,
$day, $month-1, $year-1900 );
}
####
sub private_message {
my( $self, %params ) = @_;
my $parameters = '';
foreach( ( 'max_recs', 'since_id', 'prior_to', 'archived' ) ) {
$parameters .= exists( $params{$_} )
? ";$_=$params{$_}"
: '';
}
$self->{agent}->get(
$self->{site}
. "?node_id=15848;xmlstyle=clean"
. $parameters
. $self->_login_URI()
);
$self->{agent}->success()
or die "Unable to fetch Private Message ticker.\n";
# Return values modified by bobf 6-20-05.
# Was just the {message} block, now is ( {message}, {info} ).
# This allows the caller to obtain params from the INFO section,
# including the max_recs and min_poll_seconds params set by PM.
# This change is not necessary if the while() loop to get all
# msgs is included in this method rather than in the caller.
my $data = XMLin( $self->{agent}->content(), ForceArray => 1 );
return( $data->{message}, $data->{INFO} );
}
####
my $pm_obj = PerlMonks::Mechanized->new();
my $node_data = $pm_obj->node_info( @node_ids );
my $title = $node_data->title( $node_ids[3] );
####
my $pm_obj = PerlMonks::Mechanized->new();
my $node_data = $pm_obj->node_info( @node_ids );
add_node_data( $node_data, \%alldata );
my $title = $alldata{ $node_ids[3] }{title};
####
my %nodedata;
my $pm_obj = PerlMonks::Mechanized->new();
my $data = $pm_obj->node_info( @node_ids );
add_node_data( $data, \%nodedata );
####
package PerlMonks::Mechanized::Data;
# PerlMonks::Mechanized::Data standardizes the data structure returned
# by the PM::Mech user_nodes, node_info, node_content, and node_titles
# methods. The add_node_data routine takes as input the ref returned
# from those methods (output from XML::Simple) and a ref
# to a master hash.
# The structure of the master hash is shown below.
#$alldata_ref:
# $node_id =>
# {
# 'node_id' => '466017',
# 'root_node' => '466016',
# 'parent_node' => '466016',
#
# 'author_user' => '333489',
# 'author_name' => 'muba',
#
# 'title' => 'Re: regex for word puzzle',
# 'content' => (node text),
# 'reputation' => '17',
# 'nodetype' => 'note',
#
# 'createtime' => '20050612204931',
# 'created' => '2005-06-12 20:49:31',
# 'lastupdate' => '',
# 'lastedit' => '20050407145724'
# }
use strict;
use warnings;
use Carp qw( carp );
use Data::Dumper;
use Exporter;
our @ISA = ("Exporter");
#our @EXPORT = ();
our @EXPORT_OK = qw( add_node_data );
our $VERSION = 0.01;
#*********************************************************************
my %integrate = ( user_nodes => \&_add_user_nodes,
node_info => \&_add_node_info,
node_content => \&_add_node_content,
node_titles => \&_add_node_titles );
sub add_node_data
{
my ( $newdata_ref, $alldata_ref ) = @_;
# $newdata_ref = ref to the output from the PM::Mech methods
# $alldata_ref = ref to the master hash containing all node data
my $datatype = _determine_data_type( $newdata_ref );
if( not defined $datatype )
{
return 1;
}
$integrate{$datatype}->( $newdata_ref, $alldata_ref );
return 0;
}
#*********************************************************************
sub _determine_data_type
{
my ( $newdata_ref ) = @_;
if( ref( $newdata_ref ) eq 'HASH' &&
exists $newdata_ref->{INFO} &&
exists $newdata_ref->{NODE} )
{
return 'user_nodes';
}
elsif( ref( $newdata_ref ) eq 'HASH' &&
exists $newdata_ref->{title} &&
exists $newdata_ref->{author} )
{
return 'node_content';
}
elsif( ref( $newdata_ref ) eq 'ARRAY' &&
ref( $newdata_ref->[0] ) eq 'HASH' )
{
return 'node_info';
}
elsif( ref( $newdata_ref ) eq 'ARRAY' &&
ref( $newdata_ref->[0] ) eq 'ARRAY' )
{
return 'node_titles';
}
else
{
Carp::carp "\nUnrecognized data type";
print "\n";
return undef;
}
}
sub _add_node_info
{
my ( $newdata_ref, $alldata_ref ) = @_;
foreach my $src_ref ( @{ $newdata_ref } )
{
my $node_id = $src_ref->{node_id};
my $dest_ref = \%{ $alldata_ref->{$node_id} };
my %data = ( lastupdate => $src_ref->{lastupdate},
nodetype => $src_ref->{nodetype},
root_node => $src_ref->{root_node},
title => $src_ref->{content},
createtime => $src_ref->{createtime},
node_id => $src_ref->{node_id},
author_user => $src_ref->{author_user},
author_name => $src_ref->{author_name},
parent_node => $src_ref->{parent_node} );
foreach my $key qw( root_node parent_node )
{
if( not defined $data{$key} )
{
# The root and parent nodes are undef if this node is
# not a reply, so skip them.
# We could set root and parent = $node_id in %data if
# undef, instead (but it may not be expected behavior)
delete $data{$key};
}
}
foreach my $key ( keys %data )
{
if( exists $dest_ref->{$key} &&
$data{$key} ne $dest_ref->{$key} )
{
_print_warning( $node_id, $key,
$dest_ref->{$key}, $data{$key} );
}
$dest_ref->{$key} = $data{$key};
}
}
}
sub _add_node_titles
{
my ( $newdata_ref, $alldata_ref ) = @_;
foreach my $src_ref ( @{ $newdata_ref } )
{
my $node_id = $src_ref->[0];
my $title = $src_ref->[1];
my $dest_ref = \%{ $alldata_ref->{$node_id} };
if( exists $dest_ref->{title} &&
$title ne $dest_ref->{title} )
{
_print_warning( $node_id, 'title',
$dest_ref->{title}, $title );
}
$dest_ref->{title} = $title;
}
}
sub _add_node_content
{
my ( $newdata_ref, $alldata_ref ) = @_;
# is the data in 'updated' in the same format as for 'lastupdate'?
# retain the 'created' key (in a diff format than 'createtime')
my $node_id = $newdata_ref->{id};
my %data = ( title => $newdata_ref->{title},
lastupdate => $newdata_ref->{updated},
created => $newdata_ref->{created},
content => $newdata_ref->{doctext}{content},
nodetype => $newdata_ref->{type}{content},
author_name => $newdata_ref->{author}{content},
author_user => $newdata_ref->{author}{id} );
my $dest_ref = \%{ $alldata_ref->{$node_id} };
foreach my $key ( keys %data )
{
if( exists $dest_ref->{$key} &&
$data{$key} ne $dest_ref->{$key} )
{
_print_warning( $node_id, $key,
$dest_ref->{$key}, $data{$key} );
}
$dest_ref->{$key} = $data{$key};
}
}
sub _add_user_nodes
{
my ( $newdata_ref, $alldata_ref ) = @_;
my $author_name = $newdata_ref->{INFO}->[0]->{foruser};
while( my( $node_id, $noderef ) = each %{ $newdata_ref->{NODE} } )
{
my %data = ( reputation => $noderef->{reputation},
created => $noderef->{createtime},
title => $noderef->{content},
lastupdate => $noderef->{lastupdate},
lastedit => $noderef->{lastedit} );
my $dest_ref = \%{ $alldata_ref->{$node_id} };
foreach my $key ( keys %data )
{
if( exists $dest_ref->{$key} &&
$data{$key} ne $dest_ref->{$key} )
{
_print_warning( $node_id, $key,
$dest_ref->{$key}, $data{$key} );
}
$dest_ref->{$key} = $data{$key};
}
}
}
sub _print_warning
{
my ( $node_id, $key, $dest_val, $src_val ) = @_;
print "Warning - data discrepancy for node ID $node_id:\n";
print " current $key = $dest_val\n";
print " new $key = $src_val\n";
print " The new data will replace the current data\n";
}
####
# Each row must contain the digits 1 through 9 in any order.
# Each column must contain the digits 1 through 9 in any order.
# The 9x9 grid holds nine 3x3 grids. Each of those 3x3 grids must
# contain the digits 1 through 9 in any order.
use strict;
use warnings;
use Data::Dumper;
use POSIX qw( ceil );
use List::Compare;
# $solution[$row][$col], 0 = unknown
# a dummy row and col will be added to @solution to allow indeces 1..9
my @solution = ( [ qw( 8 5 0 1 0 2 7 0 3 ) ],
[ qw( 3 0 0 0 4 0 0 0 0 ) ],
[ qw( 0 0 4 7 3 0 0 0 0 ) ],
[ qw( 4 0 0 0 0 0 8 5 0 ) ],
[ qw( 0 2 0 0 0 0 0 1 0 ) ],
[ qw( 0 1 5 0 0 0 0 0 4 ) ],
[ qw( 0 0 0 0 1 7 4 0 5 ) ],
[ qw( 0 0 0 0 2 0 0 0 1 ) ],
[ qw( 7 0 0 9 0 5 0 2 6 ) ] );
unshift( @solution, [] );
foreach my $row ( 1..9 )
{
unshift( @{ $solution[$row] }, 0 );
}
# the 3x3 grids are arranged into a 9x9 cell table as follows
# 1 2 3
# 4 5 6
# 7 8 9
# the 9x9 cell table has rows 1..9 and cols 1..9
# translate row and col indeces (concatenated) of the upper left cell in each 3x3 grid into an index
my %gridnum = ( 11 => 1, 12 => 2, 13 => 3,
21 => 4, 22 => 5, 23 => 6,
31 => 7, 32 => 8, 33 => 9 );
# $grid[1..9] = [ options left for this 3x3 grid ]
my @grids;
initialize_grids();
# $rows[1..9] = [ options left for this row ]
# $cols[1..9] = [ options left for this col ]
my @rows;
my @cols;
initialize_rows();
initialize_cols();
my $unsolved = ( 9 * 9 ) - num_hints();
while( $unsolved )
{
foreach my $row ( 1..9 )
{
foreach my $col ( 1..9 )
{
next if $solution[$row][$col];
# find intersection of @row and @col for this cell, and intersection with @grid = options left for this 3x3 grid
# if only 1 left, assign to @solution and subtract from @row and @col and @grid, $unsolved--
my $gridkey = join( '', POSIX::ceil( $row/3 ), POSIX::ceil( $col/3 ) );
my $gridnum = $gridnum{$gridkey};
my $lc_obj = List::Compare->new( $rows[$row], $cols[$col], $grids[$gridnum] );
my @options = $lc_obj->get_intersection();
if( scalar @options == 1 )
{
$solution[$row][$col] = $options[0];
foreach my $a_ref ( $rows[$row], $cols[$col], $grids[$gridnum] )
{
@{ $a_ref } = grep{ $_ != $options[0] } @{ $a_ref };
}
$unsolved--;
}
}
}
}
foreach my $row ( 1..9 )
{
print join( ' ', @{ $solution[$row] }[1..9] ), "\n";
}
sub initialize_grids
{
# determine what numbers are available as options for each 3x3 grid
# initialize each 3x3 grid
foreach my $gridnum ( 1..9 )
{
@{ $grids[$gridnum] } = ( 1..9 );
}
# filter out hints already in @solution
foreach my $row ( 1..9 )
{
foreach my $col ( 1..9 )
{
my $gridkey = join( '', POSIX::ceil( $row/3 ), POSIX::ceil( $col/3 ) );
my $gridnum = $gridnum{$gridkey};
@{ $grids[$gridnum] } = grep{ $_ != $solution[$row][$col] } @{ $grids[$gridnum] };
}
}
}
sub initialize_rows
{
# determine what numbers are available as options for each row
foreach my $row ( 1..9 )
{
@{ $rows[$row] } = ( 1..9 );
foreach my $col ( 1..9 )
{
@{ $rows[$row] } = grep{ $_ != $solution[$row][$col] } @{ $rows[$row] };
}
}
}
sub initialize_cols
{
# determine what numbers are available as options for each col
foreach my $col ( 1..9 )
{
@{ $cols[$col] } = ( 1..9 );
foreach my $row ( 1..9 )
{
@{ $cols[$col] } = grep{ $_ != $solution[$row][$col] } @{ $cols[$col] };
}
}
}
sub num_hints
{
my $hints = 0;
foreach my $row( 1..9 )
{
$hints += scalar grep{ $_ != 0 } @{ $solution[$row] };
}
return $hints;
}