Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

jeffa's scratchpad

by jeffa (Chancellor)
on Jun 01, 2004 at 16:56 UTC ( #358213=scratchpad: print w/ replies, xml ) Need Help??

Life without Perl?

/*------+---------+---------+---------+---------+---------+--------+*\ | | | Function: toInt | | Input: base to convert by (default is 10) | | Output: int | | Purpose: This function returns the integer value of the string. | | It can be used for binary, decimal, octal, and hex. | | | \*------+---------+---------+---------+---------+---------+--------+*/ int String::toInt(int base) { int intValue = 0; if (base != 2 && base != 8 && base != 10 && base != 16) return 0; if (base == 16) toUpper(); for (int i = 0; i < length; i++) { intValue *= base; if(base == 16 && data[i] >= 'A' && data[i] <= 'F') { intValue += (data[i] - 'A' + 10); } else intValue += (data[i] - '0'); } return intValue; } /*------+---------+---------+---------+---------+---------+--------+*\ | | | Function: toFloat | | Input: void | | Output: float | | Purpose: This function returns to float value of the string. | | | \*------+---------+---------+---------+---------+---------+--------+*/ float String::toFloat() { //Local Variables int i = 0; float floatValueLeft = 0; float floatValueRight = 0; while (data[i] != '.' && data[i] != '\0') { floatValueLeft *= 10; floatValueLeft += (data[i] - '0'); i++; } if (data[i] != '\0') { i = length - 1; while (data[i] != '.') { floatValueRight /= 10; floatValueRight += (data[i] - '0'); i--; } floatValueRight /= 10; } return floatValueLeft + floatValueRight; }

for Corion

use Attribute::Handlers; sub myfoo : attr { print Dumper \@_; }; sub foo { print Dumper \@_; }


for jimbus

sub new { my $class = shift; my $report = shift || "default"; my $system = shift || "none"; my $self = { logType => "both", fileSize => 100000000, fileExt => ".log", filePath => "/tmp/", fileCount => 3, dbAgeSize => 1, dbAgeUnit => "DAY", dbConnStr => 'dbi:mysql:reports:localhost', dbUser => "scott", dbPasswd => "tiger", status => "testing", entry => "", system => $system, name => $report, }; $self->{fileName} = $self->{filePath} . $report . $log->{fileExt}; return bless $self, $class; }


for diotalevi

#!/usr/bin/perl -w use strict; use MP3::Info; use Getopt::Long; use vars qw($tag $value); my %value; my $flag; my @field = qw(title artist album year comment genre tracknum); @value{@field} = ('') x @field; GetOptions(map { $_.'=s',\$value{$_} } keys %value); my $file = shift or USAGE() and exit; my $tag = get_mp3tag($file) or warn "no ID3 tag for '$file'"; for (keys %value) { next unless $value{$_}; $tag->{uc $_} = $value{$_}; $flag = 1; } set_mp3tag($file,$tag) if $flag; write_tag($tag); sub write_tag { my %tag = %{+shift}; write while ($tag,$value) = each %tag; } sub USAGE { print "USAGE: $0 [options] file\noptions:\n"; print map { "\t-$_\n" } @field; } format STDOUT = @<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< $tag,$value . __END__ =pod =head1 NAME id3_tweaker.pl - MP3::Info script =head1 DESCRIPTION This is a simple script that uses MP3::Info to alter the a single ID3 tag fields or multiple ID3 tag fields. There is no -help or -h option, just run the script by itself for the USAGE. =head1 SYNOPSIS for *nix: ./id3_tweaker.pl -year='1984' foo.mp3 for win32: perl id3_tweaker.pl -year='1984' foo.mp3 or run with the only argument being the file: ./id3_tweaker.pl foo.mp3 retrieve list of tags that can be altered: ./id3_tweaker.pl =cut

for hok_si_la

use strict; use warnings; use Data::Dumper; my @array = (1..5, 8..10, 15..30, 35..40); my @bucket; my $j = 0; for my $k (0 .. $#array) { if ($array[$k] == $array[$k+1] - 1) { push @{ $bucket[$j] }, $array[$k]; } else { $j++; } } my @ip = (sort { $#$b <=> $#$a } @bucket)[0]; print Dumper \@ip;


Here is the module:

package DMML; use strict; use warnings; use DBI; use Data::Dumper; our (@FIELDS,$OUTPUT); sub new { my $class = shift; my $self = {}; return bless $self, $class; } sub detail_report { my $self = shift; open DETAIL, '>', \$OUTPUT or die $!; return $self->write_report(format => 'DETAIL', @_); } sub summary_report { my $self = shift; open SUMMARY, '>', \$OUTPUT or die $!; return $self->write_report(format => 'DETAIL', @_); } sub write_report { my $self = shift; my %args = @_; $~ = $args{format}; for (@{ $args{records} }) { @FIELDS = @$_; write; } $~ = $args{format} . '_BOTTOM'; @FIELDS = @{ $args{total} }; write; return $OUTPUT; } format DETAIL_TOP = COUNT #PAGES FIRST LAST MEMBER# POSTAL A +DDRESS PRODUCT JOB# ---------------------------------------------------------------------- +-------------------------------------------------- . format DETAIL = @>>>>> @>>>>> @>>>>>>>> @>>>>>>>> @>>>>>>>> @>>>>>>>>>>>>>>>>>>>>> +>>>> @>>>>>>>>>>>>>>>>>>>>>>>>>> @>>>>>> @>>>>>> @FIELDS . format DETAIL_BOTTOM = @>>>>> @>>>>> @FIELDS . format SUMMARY_TOP = FormType #Kits #Pages ------------------------------------------ . format SUMMARY = @<<<<<<<<<<< @>>>>> @>>>>> @FIELDS . format SUMMARY_BOTTOM = ========================================== @<<<<<<<< @<<<< @>>>>>> @>>>>>> @FIELDS . 1;

And here is a script to call it:

use strict; use warnings; use DMML; use Data::Dumper; my $dmml = DMML->new; my @field = (([1..9]) x 10); my @total = (1,2); my $output = $dmml->detail_report( records => \@field, total => \@total, ); print Dumper $dmml->{OUTPUT};

testing one two three
[Mon Apr 26 08:06:25 2004]
package DVD::director_movie; use base qw(DVD::DBI); __PACKAGE__->table('director_movie'); __PACKAGE__->columns(Primary => qw/movie director/); __PACKAGE__->has_a(movie => 'DVD::movie'); __PACKAGE__->has_a(director => 'DVD::director'); __PACKAGE__->add_trigger(after_delete => sub { $_[0]->director->delete unless $_[0]->director->movies; }); 1;

For jdtoronto:

use DBI; use HTML::Template; my $dbh = DBI->connect(...); my $sth = $dbh->prepare('select id,title from movie'); $sth->execute; my $movies = $sth->fetchall_arrayref({}); my $template = HTML::Template->new(filehandle => \*DATA); $template->param(movies => $movies); print $template->output; __DATA__ <form> <select name="movies"> <tmpl_loop movies> <option value="<tmpl_var id>"><tmpl_var title></option> </tmpl_loop> </select> </form>


For DigitalKitty:

use Carp; sub AUTOLOAD { my ($self) = @_; $AUTOLOAD =~ /.*::(\w+)/ && exists $self->{$1} and return $self->{ +$1}; croak "No such attribute: $1"; }
It's not the fastest, but works with strict and it's fast enough for my needs. ;)


Note that this snippet has two problems:
  1. it does not allow you to capture multiple parameters that have the same name, such as foo=bar&foo=baz&foo=qux
  2. it does not decode encoded characters. In Perl, you could just use HTML::Entities. I am sure Java has some equivalent. Oh, by the way, this snippet is a horrible implementation of a problem that is solved much better by CGI.pm's param() method. I think Java has some class somewhere out there that solves this problem as well ... one of those crazy HTTP classes i think ...
use strict; use warnings; use Data::Dumper; my $str = 'foo=bar&baz=qux&one=1&two=2'; my %hash; my @pair = split '&',$str; for my $pair (@pair) { my ($key,$val) = split '=',$pair; $hash{$key} = $val; } print Dumper \%hash;

Mon Nov 17 15:46:14 2003

#!/usr/bin/perl use strict; use warnings; use Time::Piece; use HTML::Template; my $time = localtime; my $curr_mon = $time->_mon; my @month = $time->mon_list; my $tmpl = HTML::Template->new(filehandle => \*DATA); $tmpl->param(month => [ map { value => $_, label => $month[$_], curr => $curr_mon == $_, }, 0..$#month ]); print $tmpl->output; __DATA__ <tmpl_loop month> <select name="month"> <option value="<tmpl_var value>" <tmpl_if curr>selected="1"</tmpl_ +if>> <tmpl_var label> </option> </select> </tmpl_loop>

Mon Nov 17 15:35:36 2003

#!/usr/bin/perl use strict; use warnings; use Time::Piece; use CGI qw(popup_menu); my $time = localtime; my $curr_mon = $time->_mon; my @month = $time->mon_list; my %label = map {($month[$_] => $_)} 0..$#month; print popup_menu( -name => 'month', -values => \@month, -default => $month[$curr_mon], -labels => \%label, );

Sat Oct 11 10:25:58 2003

#!/usr/bin/perl use strict; use warnings; our $var = 5; increment_me($var) for 1..10; decrement_me($var) for 1..5; print_me($var); sub increment_me { $var = shift; $var++; } sub decrement_me { $var = shift; $var--; } sub print_me { $var = shift; print "$var\n"; }

Sat Oct 11 10:24:52 2003

#!/usr/bin/perl use strict; use warnings; my $var = My::Number->new; $var->increment_me for 1..10; $var->decrement_me for 1..5; $var->print_me; package My::Number; sub new { my $class = shift; my $self = { var => 0}; return bless $self, $class; } sub increment_me { my $self = shift; $self->{var}++; } sub decrement_me { my $self = shift; $self->{var}--; } sub print_me { my $self = shift; print $self->{var},"\n"; }

[Wed Sep 10 00:35:44 EDT 2003]

For sulfericacid:
Welcome to the wonderful world of RDMS's - Relational Database Management Systems. I never really bothered with DB files because i was taught SQL very shorly after learning about them. First off ... this is not easy stuff. I have been using SQL for about 4 years now and consider myself decent enough. The problem is not storing and retrieving data ... it's learning how to organize the data first.

For example, i store information about my DVD's in multiple database tables. I have one table for the DVD's themselves that contains information about that movie - it's title and release year for example. I also keep track of directors, writers, and genres. But none of that stuff belongs in the movie table - directors belongs in the directors table, and so forth. A third table is needed to join directors to the movies. Don't worry - i don't expect you to understand this just yet ... i just want you to realize that if you thought DB files were hard ... wait till you get into this stuff! But it's good that you already understand CGI and DB files - that knowledge will help.

OK! So let's try some stuff out. SSH to perlmonk.org and type the stuff in bold:

sulfericacid@perlmonk:~$ mysql -u sulfericacid -p
Enter password: your password here

Welcome to the MySQL monitor. Commands end with ; or \g.
Your MySQL connection id is 113558 to server version: 4.0.13-log

Type 'help;' or '\h' for help. Type '\c' to clear the buffer.

mysql> use sulfericacid;
Database changed
mysql> create table test(foo int, bar varchar(64));
Query OK, 0 rows affected (0.03 sec)

mysql> insert into test values(1,'foo');
Query OK, 1 row affected (0.00 sec)

mysql> insert into test values(2,'bar');
Query OK, 1 row affected (0.00 sec)

mysql> insert into test values(3,'baz');
Query OK, 1 row affected (0.00 sec)

mysql> select foo,bar from test;

+------+------+
| foo  | bar  |
+------+------+
|    1 | foo  |
|    2 | bar  |
|    3 | baz  |
+------+------+
3 rows in set (0.00 sec)

mysql> select * from test;

+------+------+
| foo  | bar  |
+------+------+
|    1 | foo  |
|    2 | bar  |
|    3 | baz  |
+------+------+
3 rows in set (0.00 sec)

mysql> select foo,bar from test order by bar;

+------+------+
| foo  | bar  |
+------+------+
|    2 | bar  |
|    3 | baz  |
|    1 | foo  |
+------+------+
3 rows in set (0.00 sec)

mysql> select bar from test order by bar desc;

+------+
| bar  |
+------+
| foo  |
| baz  |
| bar  |
+------+
3 rows in set (0.00 sec)

mysql> select bar from test where bar='bar';

+------+
| bar  |
+------+
| bar  |
+------+
1 row in set (0.00 sec)

mysql> select bar from test where bar like 'b%';

+------+
| bar  |
+------+
| bar  |
| baz  |
+------+
2 rows in set (0.00 sec)

mysql> select bar from test where foo > 1;

+------+
| bar  |
+------+
| bar  |
| baz  |
+------+
2 rows in set (0.01 sec)

And so on. There is a lot more - if you want to execute queries from a Perl script, you will have to learn DBI. Like i said, this is a long road, but you will like it once you learn this stuff. It is soooo much better than DB files - mainly because YOU don't have to worry about concurrency (that is, lock files). The database management system does it for you. Also, once you learn how to design tables "properly", you can decrease the size of the data that you store - but don't worry about that right now. You need to learn some basic SQL and DBI and we'll teach the rest one step at a time. ;)

This Space ...

Is for rent.


[Fri Aug 8 18:38:45 2003]
#!/usr/bin/perl use strict; use warnings; my $file = shift; my $chunk = 2**22; # two megs my $total = -s $file; my $length = length(int($total/$chunk)); open IN, $file or die $!; { local $/ = \$chunk; my $i = 0; while (<IN>) { open OUT,'>',sprintf("%0".$length."d-%s",$i++,$file); print OUT; } }

[Fri Aug 8 18:38:49 2003]
#!/usr/bin/perl use strict; use warnings; use File::Find::Rule; my $file = 'bigfile.txt'; my @files = File::Find::Rule ->file() ->name( qr/^\d+-$file\Z/) ->in( '.' ) ; open OUT, '>', "new_$file" or die $!; for (sort @files) { open IN, $_; print OUT while <IN>; }
Log In?
Username:
Password:

What's my password?
Create A New User
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (11)
As of 2014-09-17 08:53 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (70 votes), past polls