Beefy Boxes and Bandwidth Generously Provided by pair Networks vroom
Pathologically Eclectic Rubbish Lister
 
PerlMonks  

Don Coyote's scratchpad

by Don Coyote (Monk)
on Jul 01, 2010 at 17:29 UTC ( #847567=scratchpad: print w/ replies, xml ) Need Help??

chdir `pwd`

doh!


glad you mentioned this [id://taint]

honing my understanding and skills, I have a script which accesses a mounted windows system and clears out temporary folders. Great for learning about recursion etc...

I set about providing myself with some default filepaths and mountpoints, lest i decide not to provide them as arguments to my script. The starting directories are in the file and the script runs through the paths and recursively unlinks the files under those directories.

I developed a nice little help parser

die 'do not run this code'; #get arguments; my ($filepathlist,$mountpoint)= @ARGV; die 'usage & defaults' if $filepathlist =~ /^-{0,2}h(elp)?\s*$/;

and set my default paths

die 'do not run this code'; $filepathlist = 'home/Documents/directorieslist' unless $filepathlist; $mountpoint = '/mountpoint/windows/' unless $mountpoint; push @dirpaths readdir($filepathlist); # homemade file::find with custom unlinking behaviour # simplified for this example sub recursivelyunlinkfiles{ while(my $path = shift @dirpaths){ unlink if -f $mountpoint.$path; &recursevilyunlinkfiles if -d $mountpoint.$path; } }

so this works if no arguments are provided and sets the filepath if one argument is provided, using the default mountpoint.

I went back to clear up the edge case of an orphaned hyphen whilst requesting the usage info. At which point I realised the tremendous disaster which lay ahead, had I tested this on a singular argument consisting of either a filepath or mountpiont. Of course I had put die statements everywhere like a keen domino course constructor interspersing the frail light blocks with large heavy lumps of immutable iron, because debugger runs the code.

Can you see what might conceivably go wrong here?

#use default file, but changed my muntpoint recently; > perl ./fileunliker.pl path/to/mount

What my dynamic and helpful code did not yet consider was that a mountpoint is a directory path, And had i tested sending no directorypath through, the mountpoint would have been used.

My script would have readdir the mountpath and then recursed through my mounted os system, happilly unlinking several years of 'i must back this up soon' data

pass me some more rope please anyone?


Pod. I put pod =head2 headings above each of the exportable routines in the code. I am not sure this is any easier to read, but you can see which pod relates to which part of code. I then cut and paste your pod over into the relevant spaces, and where there were conflicts just pasted your pod as is. This may help to show where the function descriptions and general module implementation descriptions and examples need to be refined.

Tabs. extending the import routine may have been overkill. using deparse to get at teh child elements may not be overkill, rather it may be necessary, but in reality highlights ineffective code.

I quite like the idea of extending the import and using a pragma to set a module variable. But for simplicity sake, i have converted this into a settable variable.

The idea is that whenever you would call $tab in the module code to open a tag you now call the tab ascenscion routine, $ref to (CODE) to return the increased level, and the the same for descenscion, but a different $ref to (CODE)

This still does not work perfectly, as it now only indents the parent element itself rather than the child elements. This is probably far simpler than trying to deparse code during sub calls to see what the user may have in store for us, which we probably should not be doing anyway. And, I'm just getting my head round inheritance and callbacks right now...

again code untested, figurative...

package HTML::LadyAleenaStyle; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw(title script heading anchor paragraph sparagraph l +ist definition_list table form fieldset legend label selection input textarea div pre); use HTML::Entities qw(encode_entities); use Base::Data qw(data_file get_hash); use Base::Nifty qw(sline line); =head1 NAME B<HTML::Element> generates HTML tags for most of the HTML elements. =head1 SYNOPSIS To use B<Element> to print HTML tags, use the following. use Base::HTML::Element qw( title heading script anchor paragraph sparagraph list definition_l +ist table form fieldset selection input textarea div pre ); ## Module Vars =head3 C<indentation> To print readable html, set the indentation to the level. Can be 0 - 9 +. Each level constitutes a tab space multiplier applied to child elements (according to dominterpretation?). Default i +s no indentation in output or 0 level. $HTML::LadyAleenaStyle::inlvl = 7; Each child element will be indented seven tab stops from the relevant +parent element =cut $HTML::LadyAleenaStyle::inlvl = 0 unless $HTML::LadyAleenaStyle::inlvl +; # default indentation none; ### set module variables if required in calling script. sub in_depth { state $level = 0; # requires Perl version 5.10 return ( sub { $level += $HTML::LadyAleenaStyle::inlvl }, sub { $level -= $HTML::LadyAleenaStyle::inlvl }, ); } my ($ina,$ind) = in_depth; # now replace the $tab variables throughought the element subs with ca +lls to # &$ina for ascending tab depth, # &$ind for descending tab depth, # for example in sub div: # # sub div{ # # my ($tab,$code,$opt) = @_; # my $tag = 'div'; # my $open = open_tag($tag,$opt,[@ics,@java]); # # line(&$ina,qq(<$open>)); # &$code; # line(&$ind,qq(</$tag>)); # } #

all the code here

package HTML::LadyAleenaStyle; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw(title script heading anchor paragraph sparagraph l +ist definition_list table form fieldset legend label selection input textarea div pre); use HTML::Entities qw(encode_entities); use Base::Data qw(data_file get_hash); use Base::Nifty qw(sline line); =head1 NAME B<HTML::Element> generates HTML tags for most of the HTML elements. =head1 SYNOPSIS To use B<Element> to print HTML tags, use the following. use Base::HTML::Element qw( title heading script anchor paragraph sparagraph list definition_l +ist table form fieldset selection input textarea div pre ); ## Module Vars =head3 C<indentation> To print readable html, set the indentation to the level. Can be 0 - 9 +. Each level constitutes a tab space multiplier applied to child elements (according to dominterpretation?). Default i +s no indentation in output or 0 level. $HTML::LadyAleenaStyle::inlvl = 7; Each child element will be indented seven tab stops from the relevant +parent element =cut $HTML::LadyAleenaStyle::inlvl = 0 unless $HTML::LadyAleenaStyle::inlvl +; # default indentation none; ### set module variables if required in calling script. sub in_depth { state $level = 0; # requires Perl version 5.10 return ( sub { $level += $HTML::LadyAleenaStyle::inlvl }, sub { $level -= $HTML::LadyAleenaStyle::inlvl }, ); } my ($ina,$ind) = in_depth; # now replace the $tab variables throughought the element subs with ca +lls to # &$ina for ascending tab depth, # &$ind for descending tab depth, # for example in sub div: # # sub div{ # # my ($tab,$code,$opt) = @_; # my $tag = 'div'; # my $open = open_tag($tag,$opt,[@ics,@java]); # # line(&$ina,qq(<$open>)); # &$code; # line(&$ind,qq(</$tag>)); # } # ## Module Subs } sub get_attributes { my ($options, $valid) = @_; my @attributes; for (@{$valid}) { my $value = $options->{$_}; push @attributes, qq($_="$value") if defined($options->{$_}); } return join(' ',('',@attributes)); } sub open_tag { my ($tag,$opt,$attributes) = @_; my $tag_attributes = get_attributes($opt,$attributes); return $tag.$tag_attributes; } sub plain_element { my ($tag,$attributes,$tab,$value,$opt) = @_; my $open = open_tag($tag,$opt,$attributes); return sline($tab,"<$open>$value</$tag>"); } ## lexical vars #? maybe should be package variables? unless restricti +ng access, then should be constants? my @ics = ('id','class','style'); my @java = qw(onclick ondblclick onkeypress onkeydown onkeyup onmouseo +ver onmousedown onmouseup onmousemove onmouseout); =head1 FUNCTIONS All of the functions C<print> the elements with the exception of C<anc +hor> which returns the anchor and C<sparagraph> which returns a paragraph for use in other functions. As with the Perl community, the HTML community expects some indentatio +n so tabs, the first parameter of every function, are included with each element except where noted. The last parameter of every element is a hash with named options excep +t where noted. Most elements have the C<id>, C<class>, C<style>, and scripting options (such as C<onclick>). Only t +he options specific to the element will be noted. =cut # Start elements =head2 C<anchor> B<C<anchor>> has a value and the optional parameters C<href>, C<target +>, and C<title>. C<anchor> does not not get a C<tab>. anchor('Anchor text', { href => 'link location', target => 'where the link opens', title => 'alternate text', id => 'anchor_id', class => 'anchor_classes', style => 'anchor_styles' }); =cut sub anchor { my ($value,$opt) = @_; my $tag = 'a'; my $open = open_tag($tag,$opt,['href','target','title',@ics,@java]); return "<$open>$value</$tag>"; } =head2 C<title> B<C<title>> has a value but no options. title($tab, 'My page title'); =cut sub title { my ($tab,$value,$opt) = @_; my $tag = 'title'; my $open = $tag; line($tab,"<$open>$value</$tag>"); } =head2 C<script> B<C<script>> has optional parameters which are C<type> and C<src>. script($tab,{ type => 'text/javascript', # or other type src => 'script.ext' }); =cut sub script { my ($tab,$opt) = @_; my $tag = 'script'; my $open = open_tag($tag,$opt,['type','src']); line($tab,"<$open></$tag>"); } =head2 C<heading> B<C<heading>> has the heading level, value, and optional parameters. heading($tab, 2, 'My second level heading', { id => 'heading_id', class => 'heading_classes', style => 'heading_styles' }); =cut sub heading { my ($tab,$level,$value,$opt) = @_; my $tag = 'h'.$level; print plain_element($tag,[@ics,@java],$tab,$value,$opt); } ###### Begin paragraphs =head2 paragraphs B<C<paragraph>> and B<C<sparagraph>> have a value and the optional par +ameter C<separator>. B<C<paragraph>> prints the paragraph(s), and B<C<sparagraph>> returns +the paragraph(s). The C<separator> option allows you to input more than one paragraph per use of this function. =head2 C<sparagraph> pod to do =cut sub sparagraph { my ($tab,$value,$opt) = @_; my $tag = 'p'; my $open = open_tag($tag,$opt,[@ics,@java]); my $sep = $opt->{separator} ? $opt->{separator} : "\n"; my $line; for (grep(length,split(/$sep/,$value))) { $line .= sline($tab,qq(<$open>)); $line .= sline($tab + 1,$_); $line .= sline($tab,qq(</$tag>)); } return $line; } =head2 C<paragraph> paragraph($tab, 'My paragraph(s)', { id => 'paragraph_id', class => 'paragraph_classes', style => 'paragraph_styles' separator => 'paragraph_separator' }); =cut sub paragraph { print sparagraph(@_); } #### End paragraphs #### Begin elements for ordered and unordered lists. =head3 Setting up the list items If you do not want your list items formatted, you can pass your array +as is. If you want your list items formatted, the formatted items are also array references with the optional parameter +C<inlist>. 'unformatted value', ['formatted value', { id => 'item_id', class => 'item_class', style => 'item_style', inlist => ['u', \@inner_list, { list options }] }], 'another unformatted value' =cut =head2 C<item> pod to do =cut sub item { my ($tab,$value,$opt) = @_; my $tag = 'li'; my $open = open_tag($tag,$opt,[@ics,@java]); line($tab,qq(<$open>)); line($tab + 1,$value); if ($opt->{inlist}) { list($tab + 1, @{$opt->{inlist}}); } line($tab,qq(</$tag>)); } =head2 C<list> B<C<list>> has type, list, and the optional parameters. C<type> is C<u> for an unordered list or C<o> for an ordered list. The + C<list> parameter is an array reference. list($tab, 'u', \@list, { id => 'list_id', class => 'list_class' style => 'list_style, }); =cut sub list { my ($tab,$type,$list,$opt) = @_; my $tag = $type.'l'; my $open = open_tag($tag,$opt,[@ics,@java]); line($tab,qq(<$open>)); for my $item (@$list) { if (ref($item) eq 'ARRAY') { item($tab + 1,$item->[0],$item->[1]); } else { item($tab + 1,$item); } } line($tab,qq(</$tag>)); } sub definition_list{ placeholder } #? is there a definition_list sub +? #### End elements for ordered and unordered lists. #### Begin elements for definition lists. =head2 C<term> pod to do =cut sub term { print plain_element('dt',[@ics,@java],@_); } =head2 C<definition> pod to do =cut sub definition { my ($tab,$value,$opt) = @_; my $tag = 'dd'; my $open = open_tag($tag,$opt,[@ics,@java]); line($tab,qq(<$open>)); line($tab + 1,$value); line($tab,qq(</$tag>)); } # I will be rewriting definition_list to get rid of the data gathering + within it. =head2 C<definition_list> I<I have to tear out some code to make it work like the others.> pod to do =cut sub definition_list { my ($tab,$opt) = @_; my $tag = 'dl'; my $open = open_tag($tag,$opt,[@ics,@java]); my %definition_list = get_hash( file => $opt->{file} ? $opt->{file} : data_file, headings => [@{$opt->{headings}}], sorted => 'yes', ); line($tab,qq(<$open>)); my $term = shift @{$opt->{headings}}; for my $term (sort {$definition_list{$a}{sort_number} <=> $definitio +n_list{$b}{sort_number}} keys %definition_list) { term($tab + 1,$term); if (@{$opt->{headings}} == 1) { definition($tab + 2,$definition_list{$term}{$opt->{headings}->[0 +]}); } else { for my $heading (@{$opt->{headings}}) { my $upheading = ucfirst $heading; definition($tab + 2,qq(<b>$upheading:</b> ).encode_entities($d +efinition_list{$term}{$heading})); } } } line($tab,qq(</$tag>)); } # End elements for definition lists. # Begin elemeents for tables. =head3 Setting up the caption C<caption> is a value, as seen above, or an array refernce. The C<capt +ion> has the optional parameter C<align>. ['table caption', { id => 'caption_id', class => 'caption_class', style => 'caption_style', align => 'caption_align' }], =cut =head2 C<caption> pod to do =cut sub caption { print plain_element('caption',['align',@ics,@java],@_); } =head4 Setting up the cells If you do not want your cells formatted, you can pass your array as is +. If you want your cells formatted, the formatted cells are also array references with optional parameters C<list> and C +<type_override>. The C<list> option is the same as the C<inlist> option for L<list items|/Setting up the list items>. +If you need to override the row type, use C<type_override>. 'unformatted value', ['formatted value', { id => 'cell_id', class => 'cell_class', style => 'cell_style', }], ['list', { id => 'cell_with_list_id', class => 'cell_class', style => 'cell_style', list => ['u', \@list_in_cell, { list options }] }], ['formatted value', { id => 'cell_id', class => 'cell_class', style => 'cell_style', type_override => 'h', }], 'another unformatted value' =cut =head2 C<cell> pod to do =cut sub cell { my ($tab,$type,$value,$opt) = @_; $type = $opt->{type_override} ? $opt->{type_override} : $type; my $tag = 't'.$type; my $open = open_tag($tag,$opt,['colspan','rowspan',@ics,@java]); line($tab,qq(<$open>)); if ($value eq 'list') { list($tab + 1,@{$opt->{list}}); } else { line($tab + 1,$value); } line($tab,qq(</$tag>)); } =head3 Setting up the rows Each C<row> is an array reference with C<type>, C<cells>, and optional + parameters. You need to know type of cells are in the row. =over =item * C<header> is a row with only headings. There is only one row allowed i +n C<header>. =item * C<data> is a group of rows with only data. =item * C<whead> is a group of rows with a heading then data. =back rows => [ ['header',\@headings, { id => 'header_row_id', class => 'header_row_class', style => 'header_row_style }], ['data',\@data { id => 'data_row_id', class => 'data_row_class', style => 'data_row_style }], ['whead',\@data_with_heading], ], =cut =head2 C<row> pod to do =cut sub row { my ($tab,$type,$cells,$opt) = @_; my $tag = 'tr'; my $open = open_tag($tag,$opt,[@ics,@java]); my %types = ( header => 'h', data => 'd', whead => 'd' ); line($tab,qq(<$open>)); if ($type eq 'whead') { my $cell = shift @{$cells}; if (ref($cell) eq 'ARRAY') { cell($tab + 1,'h',ucfirst $cell->[0], { class => 'row_header', $ +cell->[1] }); } else { cell($tab + 1,'h',ucfirst $cell, { class => 'row_header' }); } } my $cell_type = $types{$type}; for my $cell (@{$cells}) { if (ref($cell) eq 'ARRAY') { cell($tab + 1,$cell_type,$cell->[0],$cell->[1]); } else { cell($tab + 1,$cell_type,$cell); } } line($tab,qq(</$tag>)); } =head3 Setting up the columns Each C<column> is an array reference of hash references and each has t +he optional parameter C<span>. { id => 'col_id', class => 'col_class', style => 'col_style' span => 2, }, =cut =head2 C<col> pod to do =cut sub col { my ($tab,$opt) = @_; my $tag = 'col'; my $open = open_tag($tag,$opt,['span',@ics,@java]); line($tab,qq(<$open>)); } =head2 C<cols> pod to do =cut sub cols { my ($tab,$cols) = @_; col($tab,$_) for @{$cols}; } =head2 C<table> Before you go any further, if you plan on using a table for layout, B< +I<STOP!>> Tables are for tabular data, use L<div|/div> elements to lay out your webpage. B<C<table>> has the optional parameters of C<caption>, C<cols>, and C< +rows>. C<cols> and C<rows> are array references. table($tab, { id => 'table_id', class => 'table_class', style => 'table_style', caption => 'table caption', cols => \@cols, rows => \@rows, }); =cut sub table { my ($tab,$opt) = @_; my $tag = 'table'; my $open = open_tag($tag,$opt,[@ics,@java]); line($tab,qq(<$open>)); if ($opt->{caption}) { if (ref($opt->{caption}) eq 'ARRAY') { caption($tab + 1, $opt->{caption}->[0],$opt->{caption}->[1]); } else { caption($tab + 1, $opt->{caption}); } } if ($opt->{cols}) { col($tab + 1, $_) for @{$opt->{cols}}; } for my $rowgroup (@{$opt->{rows}}) { my $type = $rowgroup->[0]; my @rows = $rowgroup->[1]; my $attributes = $rowgroup->[2]; if ($type eq 'header') { row($tab + 1, $type , @rows, $attributes); } else { for my $row (@rows) { row($tab + 1, $type , $_, $attributes) for @$row; } } } line($tab,qq(</$tag>)); } # End elements for tables. # Start elements for forms. =head2 C<label> pod to do =cut sub label { print plain_element('label',['for',@ics,@java],@_); } =head2 C<option> pod to do =cut sub option { print plain_element('option',['value',@ics,@java],@_); } =head3 C<selection> B<C<selection>> has options and the optional parameters C<name>, C<mul +tiple>, and C<label>. selection($tab, \@options, { name => 'select_name', multiple => 'multiple', label => ['label text', { for => 'select_name', id => 'label_id', class => 'label_class', style => 'label_style' } id => 'select_id', class => 'select_class', style => 'select_style' }); =head4 Setting up the options If you do not want your options formatted, all you need to do is pass +the text and C<value> of the option. If you want formatting, you need to pass the other optional parameters. ['unformatted option', { value => 'unformatted' }], ['formatted option', { value => 'formatted', id => 'option_id', class => 'option_class', style => 'option_style' }] =cut =head2 C<selection> pod to do =cut sub selection { my ($tab,$options,$opt) = @_; my $tag = 'select'; my $open = open_tag($tag,$opt,['name','multiple',@ics,@java]); label($tab,@{$opt->{label}}) if ($opt->{label} && $opt->{place_label +} eq 'before'); line($tab,qq(<$open>)); for (@$options) { option($tab + 1,@$_); } line($tab,qq(</$tag>)); label($tab,@{$opt->{label}}) if ($opt->{label} && $opt->{place_label +} eq 'after'); } =head2 C<textarea> pod to do =cut sub textarea { my ($tab,$value,$opt) = @_; my $tag = 'textarea'; my $open = open_tag($tag,$opt,['name','rows','cols',@ics,@java]); label($tab,@{$opt->{label}}) if ($opt->{label} && $opt->{place_label +} eq 'before'); line($tab,"<$open>$value</$tag>"); label($tab,@{$opt->{label}}) if ($opt->{label} && $opt->{place_label +} eq 'after'); } # I have to rewrite input so it can print a list of inputs for check b +oxes and radio boxes. =head2 C<input> pod to do =cut sub input { my ($tab,$opt) = @_; my $tag = 'input'; my $open = open_tag($tag,$opt,['type','value','name',@ics,@java]); my $text = $opt->{text} ? "$opt->{text} " : ''; label($tab,@{$opt->{label}}) if ($opt->{label} && $opt->{place_label +} eq 'before'); line($tab,"$text<$open>"); label($tab,@{$opt->{label}}) if ($opt->{label} && $opt->{place_label +} eq 'after'); } =head2 C<legend> pod to do =cut sub legend { print plain_element('legend',[@ics,@java],@_); } ## fieldset sub under 'tables' subs, fieldset pod under forms pod. =head3 C<fieldset> B<C<fieldset>> has code and the optional paramter C<legend>. C<code> i +s an anonymous subroutine. fieldset($tab, sub { ... fieldset elements ... }, { legend => 'legend_text', id => 'fieldset_id', class => 'fieldset_class', style => 'fieldset_style' }); =cut =head2 C<fieldset> pod to do =cut sub fieldset { my ($tab,$code,$opt) = @_; my $tag = 'fieldset'; my $open = open_tag($tag,$opt,[@ics,@java]); line($tab,qq(<$open>)); legend($tab,$opt->{legend}) if $opt->{legend}; &$code; line($tab,qq(</$tag>)); } =head2 forms =cut ##?? =head3 C<form> B<C<form>> has code and the optional paramters C<action> and C<method> +. C<code> is an anonymous subroutine. form($tab, sub { ... form elements ... }, { action => 'form_action', method => 'form_method', id => 'form_id', class => 'form_class', style => 'form_style' }); =cut =head2 C<form> pod to do =cut sub form { my ($tab,$code,$opt) = @_; my $tag = 'form'; my $open = open_tag($tag,$opt,['action','method',@ics,@java]); line($tab,qq(<$open>)); &$code; line($tab,qq(</$tag>)); } # End elements for forms. =head2 C<div> B<C<div>> code and optional parameters. C<code> is an anonymous sub. div($tab, sub { print "Text with out any formatting, great for data dumping." }, { id => 'div_id', class => 'div_class', style => 'div_style' }); =cut sub div { my ($tab,$code,$opt) = @_; my $tag = 'div'; my $open = open_tag($tag,$opt,[@ics,@java]); line($tab,qq(<$open>)); &$code; line($tab,qq(</$tag>)); } =head2 C<pre> B<C<pre>> has code but no optional parameters. The C<tab> will be igno +red and C<code> is an anonymous sub. pre($tab, sub { print "Text without any formatting, great for data dumping." }); =cut sub pre { my ($tab,$code) = @_; line(0,'<pre>'); &$code; line(0,'</pre>'); } # End elements =head1 AUTHOR Written by Lady Aleena (Lady underscore Aleena at xecu dot net) with a + lot of help from the L<PerlMonks|http://www.perlmonks.org>. =cut 1;

#!usr/bin/perl -Tw use warnings; use strict; opendir my $dh, './testdir/'; #assume all files, no sub dirs my @filelist = readdir($dh); close($dh); my $rep = qr'<>'; while (my $basefile = shift @filelist ){ print $basefile; next unless $basefile =~ m/^((\w+\s*)+\.(pl|txt))$/; $basefile = './testdir/'.$1; print $basefile; open (my $fh, '+<', $basefile); while (<$fh>){ my $line = $_ =~ s/$rep/\`\<\>\`/g; s/$_//; print $fh $line; } # close($fh); # readline on closed filehandle at line 12' } close($dh); exit 0;


Keep Focused!

  1. How do I know if I am writing scalable code
    • differnece between iterative and recursive techniques?
    • are there certain operaqtions considered scalable and others not
    • benchmarking only shows the results, what are the methods?
    • recall a node suggesting using arrays when they should be rather than defaulting to using hashes out of habit, due to scalability, benchmarking was used. More a call to taste the recipes?
  2. How do I safely sanitise user submitted file content? & what is bitwork?
    • Taint checking, may be bypassed using the regex $1 technique.
    • Not really wanting to bypass the mecahanism I was troubled by this for a learning period
    • on reread the proper way to sanitise input is to use a suid script
    • Taintmode switches perl into a suid perl -(clarify)
    • taint checking tutorials are concerned with filenames, i want to process user file content
    • suid gets into a murky realm of bitmodes
    • what exactly is a bitmode
    • bitshifting, returning bits, operating on filebits etc
    • there are a lot of examples of bitshifting, but i do not seem to be able to find what bitshifting actually is, and what it is actually operating on
  3. install perldoc
    • determine installed filepaths so as not to overwrite manually installed directories, if using an automated install
    • have used provided site directories to store personal pl files, now unsure what is what.
    • can i get perldoc from cpan, or is perldoc a kernel module?
    • is Perl-Doc perldoc, Perl-Doc is a framework for perldoc, but is it perldoc, the synopsis is vague

Set up a recursive routine to assign existing values of a hash reference to the existing keys of the hashref. Recursion happens when you find one of the values is itself a hashref, when the routine is called on itself again. You may need to check for duplicated values across the different depths though. This is untested but, you get the idea.

my $newhashref = {}; sub rechash { my $href = shift; foreach (keys %$href){ &rechash if ( ref($href->{$_}) && ref($href->{$_}) eq 'HASH'); +#update - use constant.. or debug this one day... $newhashref{$_} = $href->{$_}; } return $newhashref } my $ref_to_onelevelhash = rechash $ref_to_multilevelhash;


As for your code, the best place to start is by adding a couple of pragmas to your script. Please you ask and if I please to tell you these? Would it be so much to ask the names or would it be a farce to tell of what these pragmas are and when or where they may dwell? Why for a beginner the best place to begin is the start of the script with a couple of the most delightful pragmas known to exist. their names? their names? oh yes! my dear friend. Now, remember to put them at the beginning and not at the end. They're both written with u's and by you and if you don't use them someone will sue! So dont hesitate and stop your yawning the first of the pragmas is use warnings! did you get that? did you write that in your script? There's no time to waste here now type use strict! There by golly and close by gosh we got this programme under the cosh!


started on go to VV below VV

intersting undef

use strict;use warnings; #my $grainsofsilica = {a => 'A'}; #my $bucketofwater = {}; #if (defined $grainsofsilica && defined $bucketofwater) #{print 'the reference to the anonymous hash %$grainsofsilica ('.$grai +nsofsilica.') is defined and dereferences to show this content #-->'.%$grainsofsilica.' added to $bucketofwater i should get 3? $buck +etow+$gra='.(%$grainsofsilica.%$bucketofwater) }; # #print %$grainsofsilica; #my %g=(); #if (defined %g) {print %g} #-------- #defined(%hash) is deprecated #maybe you should omit defined #my %b=(); #print if defined %b; #--------- # ##prints newline - syntax error? #my $c='sure?'; #print $c if defined; #------ # ##prints newline - def syntactic #my $c='sure?'; #print if defined $c; #------ #Use of uniitialised value $_ in print. # ##prints newline - def syntactic #my $c='sure?'; #if defined $c print; #----- #syntax err near if defined #my $c='sure?'; #if (defined $c){ print $c}; #-------- #sure? ## :) #my $t; #if (defined $t){print $t}; #------ # ##prints newline #my $t; #if (defined $t){print 'ca',$t}; #------ # ##prints newline ##undef is being returned, evaluated to false and printed? #my $u = undef; #print $u; #------ #Use of uninitialized variable. # ##newline before command prompt ## ok strawberry or os adds an extra newline at end of script on windo +ws i guess. print undef; #----- #Use of uninitialised variable # ## yep #if (defined undef){print 'undef'} #------ #Use of uninitialised value ## cant 'defined' undef too #my $grain = {}; #if (defined $grain){print $grain} #----- #Use of uninitialised value #HASH(0x3e81a4) ## no newline - Oo i have been printing undef after all? my $grain = {}; if (defined %$grain){print %$grain} #------- # ##newline again. ## interesting though only a warning of uninitialised value, no sateme +nt of deprecation. #exit 0; #----- # ##newline after program #exit 1; #----- # ##newline afer program #exit; #----- # ##newline after program # #----- # ##newline after program #1; #------ # ##newline after program. ## #*removes use strict & use warnings ## ok this is now passing an empty file called ## experibition.pl ## to strawberry perl on xp # # # # #------ # ##newline returned at EOF!!! exit 0;

^^ below ^^

seems thats the point though. The ref has been assigned so is defined.

Inspired by if (defined %hash) deprecated?

Well my program dies, spurning me with the fact of deprecation, but it then goes on to suggest maybe I just omit defined() from the expression. However, it was too late, for the exploration had begun...

Hashing algorithm based random number generators! Low brow chemistry! And the non-destruction of allocated whatsmejiggerybits even though the program has exited. :O ???

Having followed the defined deprecated thread today, i followed up on the thinking about how the defined operator works on references to hashes. Could we maybe set up an empty anonymous hash and then call defined on the reference to bypass the deprecation? Well no not really, and for what are fairly obvious reasons once considered. However the exercise led me to a realisation for which I feel this is worthy of a wee meditation.

Let's go..

use strict; use warnings; my $grainsofsilica = {}; if(defined $grainsofsilica){ print %$grainsofsilica,'hi' } exit 0; ------- #an empty line is printed

This prints nothing but doesnt fail, so the defined operator has bypassed its own deprecation right? Well no, as you see the defined operator is working on the reference which is a scalar which is defined. It is defined as an empty anonymous hash.

And you cannot, remove the definition of the scalar as an anonymous hash as this does two things, removes the assignment of any anonymous hash. And leaves you with an undefined scalar.

perl -e "print undef if defined;" ---- #prints an empty line

taking five


Hello, I have been looking at this, and I believe I have a solution.

The main problem I faced was that the auto-vivified hashes/arrays initialise undefined. So I could not determine to fill out an undefined array as all would be undefined. I gather this is why you are iterating through the snps arrays first then trying to map the indexes of those to the indexes of the snp_bins.

Not being able to determine by whether an array was defined or not, I slept on it and in the morning decided that using your method to initially map the indexed array but then retro filling the undefined arrays with '1 1,' using an auto decrement unless/until loop may work.

I had to hammer at the loops for a bit, and the flow control assumes that the SAMPLE line is always line '1' of the data file. But it does what I think you need it to do.

#!/usr/bin/perl -T use strict; use warnings; my (@snp_bins, %data); open my $in_file, "<", "./dnata"; while (<$in_file>) { chomp; if ($. == 1 ) { # line number my ( $placeholder, @coords ) = split /,/; @snp_bins = map int( $_ / 100_000 ), @coords; next; } if ($. >= 2){ my ( $id, @snpspairs ) = split /,/; foreach my $oasis (@snp_bins){ my $os = $oasis; @{ $data{$id}[$os] } = @snpspairs; $os -= 1; unless ( defined( @{ $data{$id}[$os] } ) ){ until( ( defined( @{ $data{$id}[$os] } ) ) ||( $os == -1 ) ){ @{ $data{$id}[$os] } = '1 1,' x 100 ; # do x 10 for readability on output!! $os--; next if ($os == -1); } } } } } foreach my $k (keys %data){ print $k," : ",@{ $data{$k} }->[0],$/; print $k," 0: ",@{ $data{$k}->[0] },$/; print $k," 161: ",@{ $data{$k}->[161] },$/; print $k," 162: ",join (',',@{ $data{$k}->[162]}),$/; print $k," 162:5 ",@{ $data{$k}->[162]}[5],$/; }

There may be better ways to control the flow re the line numbers and of course the flow depends on if /^SAMPLE/ lines occur more than once throughout the file. Also I expect my loop exits could be improved upon. However this should get the ball rolling.

Coyote

Answer in progress ^^

scratchpad VV

#!/usr/bin/perl -T use strict; use warnings; my (@snp_bins, %data); open my $in_file, "<", "./dnata"; while (<$in_file>) { chomp; print $/,$.,$_,$/; if ($. == 1 ) { my ( $placeholder, @coords ) = split /,/; @snp_bins = map int( $_ / 100_000 ), @coords; print '@snp_bins: '. @snp_bins . qq(@snp_bins \n); # if($. < 2){ next }; # print "anything"; next; } if ($. >= 2){ my ( $id, @snpspairs ) = split /,/; print qq($id \n length(@snpspairs) \n); # my $os; foreach my $oasis (@snp_bins){ my $os = $oasis; # print " os1 (oasis) : ",$os," "; @{ $data{$id}[$os] } = @snpspairs; $os -= 1; # print "\n os2 (os - =1) : ",$os," "; #print $/,$os," : : ",defined( @{ $data{$id}[$os] } ) ? "def" : "und" +,$/; unless ( defined( @{ $data{$id}[$os] } ) ){ until( ( defined( @{ $data{$id}[$os] } ) ) || ( $os == -1 ) ){ # print "\n os3b : ",$os," ",@{ $data{$id}[$os] }; @{ $data{$id}[$os] } = '1 1,' x 10 ; # print " os3a : ",$os," ",@{ $data{$id}[$os] }; $os--; next if ($os == -1); } } } } } foreach my $k (keys %data){ print $k," : ",@{ $data{$k} }->[0],$/; print $k," 0: ",@{ $data{$k}->[0] },$/; print $k," 161: ",@{ $data{$k}->[161] },$/; print $k," 162: ",join (',',@{ $data{$k}->[162]}),$/; print $k," 162:5 ",@{ $data{$k}->[162]}[5],$/; } # print "\n : ", %data{'HG600640'} ; # foreach my $snp (@snps) { # (@snps[0..$#snps-1] # $snp =~ s/$snp/$snp,/; # put commas back in (preserve c +sv format ) #next # } # print "snpbins: @snp_bins ",$#snp_bins,"\n"; # print "snps: @snps \n"; # for ( 0..$#snp_bins ) { # # my $index = qq($_); # print 'index: ',$index; # #print "\n", @{ $data{$id}->[$snp_bins[$_]]}; # if( defined( @{ $data{$id}[$snp_bins[$_]] } )) { # print " def :"; # for (0..$#snps){ # push( @{ $data{$id}[$snp_bins[$index]] }, $snps[$_]); # } # see note [1] # print @{ $data{$id}[$snp_bins[$index]] },"\n"; # }else{ # replace 'undef' elements with flag data # print " undef :$_\n"; # for(0..99){ # push @{ $data{$id}[$snp_bins[$index]] }, '1 1,'; # } # # print $index, @{ $data{$id}[$snp_bins[$index]] }; # } #print $#snp_bins, ": "; # print "$snp_bins[$index] \n"; # print " $snps[$index] \n"; # } # } # } # print @{$data{'HG600640'}[161]}[0..6], "\n"; # print @{$data{'HG600640'}[162]}[0..6], "\n"; #foreach my $key (keys %data){ #print $key,": ","\n"; #} #my $k = 'HG600640'; # #print $data{$k}->[0];

The problem I think you have is that even though you are iterating through $snp_bin array from 0 -162. For each of these you are testing @snps array if it has a value, which it must always have, because you are in the else loop that determined the line does not match /^SAMPLE/. You do not test the snp_bins index array to see if it is defined. you populate the snp_bins array with the snps array when it is defined, which works correctly. You then say but if the snp array has no value populate the undefined snp_bin with "1 1," list. As I mentioned though, snps at this point will always be true.

you should in my opinion, test each snp_bin array to see if it is defined. If not, populate with "1 1," list, else fill out the index with the snps array as per the initial if condition previously. Basically, I think that that section of code should flow something like this

for ( 0 .. $#snp_bins ) { my $index = $_; if ( defined( @{ $data{$id}[ $snp_bins[$_] ] ) { for (0..$#snps){ push( @{ $data{$id}[ $snp_bins[$index] ] }, snps[$_]); } # see note [1] }else { # replace 'undef' elements with flag data my @ones = "1 1," x 100; push( @{ $data{$id}[ $snp_bins[$_] ] }, @ones ) } }

Problem - auto vivified data types are always undefined until 'filled'

solution: auto-decrement IS magical!

please provide a sample of the data that includes a sample which becomes undefined and the code snippet which does this

You may find it easier to apply the '1 1,' mapping instead of setting them as undefined initially?

foreach my $index ( 0 .. $#snp_bins ) { if ( $snps[$index] ) { push( @{ $data{$id}[ $snp_bins[$index] ] }, $snps[$index] +); # see note [1] } else { # replace 'undef' elements with f +lag data my @ones_array; foreach ( 1 .. 100) { push @ones_array, "1 1,"; } push( @{ $data{$id}[ $snp_bins[$index] ] }, @ones_arra +y ) }
xxxxxxxxxxxxxxxx for (0..$#snps){ defined @{ $data{$id}[ $snp_bins[$_] ] } ? push @{ $data{$id}[ $snp_bins[$_] ] }, $snps[$_] : @{ $data{$id}[ $snp_bins[$_] ] }->[0..99] = "1 1," x 100; } xxxxxxxxxxxxxxxxxxxx
foreach my $idkey (keys %data){ for (0..$#{ $data{$idkey} } ){ defined @{ $data{$idkey}[ $_ ] } ? ???????????????? push @{ $data{$id}[ $snp_bins[$_] ] }, $snps[$_] : @{ $data{$id}[ $snp_bins[$_] ] }->[0..99] = "1 1," x 100; } }
@{ $data{$id}[ $snp_bins[$_] ] } = map @snps, 0..$#{ $data{$idkey}[ $_ + ] }, : @{ $data{$id}[ $snp_bins[$_] ] }->[0..99] = "1 1," x 100;
foreach my $idkey (keys %data){ for (0..$#{ $data{$idkey} } ){ if ( !defined @{ $data{$idkey}[ $_ ] } ) { @{ $data{$id}[$_] }->[0..99] = "1 1," x 100; } } }
hash { HG06004 => [ #hash $data{$idkey} => #Array snps_bins [0] = [ undef ] #Array snps = undef .. [162] = [ #Array snps [0] '0 0,' [1] '0 0,' [2] '0 1,' ] [163] = [ #Array snps [0] '0 0,' [1] '0 0,' [2] '0 1,' ] [ }
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 cooling their heels in the Monastery: (13)
As of 2014-04-24 12:23 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (565 votes), past polls