Beefy Boxes and Bandwidth Generously Provided by pair Networks
Your skill will accomplish
what the force of many cannot
 
PerlMonks  

The Monastery Gates

( #131=superdoc: print w/replies, xml ) Need Help??

Donations gladly accepted

If you're new here please read PerlMonks FAQ
and Create a new user.

New Questions
Win32::OLE and Task Scheduling - Invalid Query
2 direct replies — Read more / Contribute
by kambe
on Oct 20, 2018 at 18:21

    I am trying to use Win32::OLE to create a task on a Windows 10 system, something similar to href:https://onedrive.live.com/?authkey=%21ABowWrIzVQzcElo&cid=07CD1B37769E1B7D&id=7CD1B37769E1B7D%21102691&parId=7CD1B37769E1B7D%21102690&o=OneUp. I tried to manually validate the query by creating the same task by hand in the task scheduler GUI, and that seemed to work.

    Here's my test code:

    use File::Basename; use Win32; use Win32::OLE; $Win32::OLE::Warn = 3; use Data::Dumper; my ($me, $dirpath, $suffix) = fileparse($0, qr/\.[^.]*/); my ($system, $login, $domain, $sidbin, $sidtype, $sidtxt) = ""; $login = Win32::LoginName(); Win32::LookupAccountName($system, $login, $domain, $sidbin, $sidtype); my($Revision, $SubAuthorityCount,@IdentifierAuthorities) = unpack("CCn +nn", $sidbin); unless (($IdentifierAuthorities[0] || $IdentifierAuthorities[1])) { my($temp, $temp2, @SubAuthorities) = unpack("VVV$SubAuthorityCount +",$sidbin); $sidtxt = "S-$Revision-$IdentifierAuthorities[2]-".join("-",@SubAu +thorities); } die Win32::OLE->LastError() unless (my $service = Win32::OLE->CreateOb +ject('Schedule.Service')); $service->Connect; my $RootFolder = $service->GetFolder('\\'); die Win32::OLE->LastError() unless (my $TaskDefinition = $service->New +Task(0)); die Win32::OLE->LastError() unless (my $regInfo = $TaskDefinition->Reg +istrationInfo); $regInfo->{Description} = "Register a perl task as an event $me"; $regInfo->{Author} = "$domain\\$login"; $regInfo->{URI} = "$sidtxt\\$me"; die Win32::OLE->LastError() unless (my $settings = $TaskDefinition->Se +ttings); $settings->{Enabled} = 1; $settings->{AllowDemandStart} = 1; $settings->{DisallowStartIfOnBatteries} = 0; $settings->{StopIfGoingOnBatteries} = 0; $settings->{Hidden} = 0; my @Triggers; my $TriggerSet; die Win32::OLE->LastError() unless ($TriggerSet = $TaskDefinition->Tri +ggers); for (10000..10001) { die Win32::OLE->LastError() unless (push @Triggers, $TriggerSet->C +reate(0)); $Triggers[$#Triggers]->{Id} = $_; $Triggers[$#Triggers]->{Subscription} = "<QueryList> <Query Id=\"event$_\" Path=\"Microsoft-Windows-NetworkProfile/Operat +ional\"> <Select Path=\"Microsoft-Windows-NetworkProfile/Operational\">*[Sy +stem[(EventID=\"$_\")]]</Select> </Query> </QueryList>"; die Win32::OLE->LastError() unless (my $values = $Triggers[$#Triggers]->ValueQueries->Create +("eventId", "Event/System/EventID")); $Triggers[$#Triggers]->{Enabled} = 1; } die Win32::OLE->LastError() unless (my $Action = $TaskDefinition->Acti +ons()->Create(0)); $Action->{Path} = 'C:\Perl64\Bin\Perl.exe'; $Action->{Arguments} = "$0 -f event\${eventID}"; $RootFolder->RegisterTaskDefinition("OLE-Test",$TaskDefinition,6,undef +,undef,3); print Dumper $TaskDefinition->{XmlText};

    If I run the code with RegisterTaskDefinition with TASK_VALIDATE_ONLY flag set (third parameter = 1), I get a nice XML dump. So far so good. When I run the code with RegisterTaskDefinition with TASK_CREATE_OR_UPDATE (third parameter = 6), I get this error:

    OLE exception from "<Unknown Source>": (11,263):Subscription:<QueryList><Query Id="event10000" Path="Microsoft-Windows-NetworkProfile/Operational"><Select Path="Microsoft-Windows-NetworkProfile/Operational">*[System[(EventID= +"10000")]]</Select></Query></QueryList> Win32::OLE(0.1712) error 0x80073a99: "The specified query is invalid" in METHOD/PROPERTYGET "RegisterTaskDefinition" at OLE-test.pl line + 63.

    Anyone familiar enough with Win32::OLE, and the Windows task scheduler XML to explain what I'm doing wrong

Simple search and output
3 direct replies — Read more / Contribute
by rvaughans
on Oct 20, 2018 at 10:39
    Hello... VERY new to Perl. I have a test file that I need to do a search (STDIN) and display ALL the lines found with the inputted string/variable. MUCH thanks in advance!!!
OK to Include CHI File Data in module Tests ?
1 direct reply — Read more / Contribute
by localshop
on Oct 20, 2018 at 00:52
    Trying to refine WebService::GoogleAPI::Client which uses CHI to cache resources pulled from Google API Discovery. In the package tests I'd like to maximise the coverage but don't wish to impose a whole bunch of HTTP requests every time tests are run. I was thinking that by bundling in a CHI::Driver::File directory for use by the tests I could default to using this and perhaps provide a switch to allow live requests for local dev testing where needed.

    I am concerned that the cache files won't be portable across platforms but I can probably catch that out.

    1. is this approach missing any obvious bad practice
    2. are any CPAN modules that do this that I could review?
    3. any advice on testing against network resources or cached data appreciated.

    Another option that occurred to me after posting this question is to create my own CHI::Driver subclass and use that for testing with some hard coded values.

    Many thanks for any advice.

glob an array?
2 direct replies — Read more / Contribute
by morgon
on Oct 19, 2018 at 21:10
    Hi,

    just for curiosity...

    If I have an array of filenames and a glob-pattern (as e.g. "*.hubba"), is there a way to "glob" the array (i.e. get the list of all elements matching the glob-pattern) using the same logic "glob" would use, or would I have to translate the gob-pattern into a regex and do a grep?

    Many thanks!

First attempt at bringing in file for input/output
7 direct replies — Read more / Contribute
by catfish1116
on Oct 19, 2018 at 15:48
    I am taking baby steps to understanding out to read in, modify file(s) and then send modified file to output. Here is my attempt to just read in a file and send it to output.
    #!/bin/perl use v5.12; use warnings; my $in = $ARGV[0]; if (! defined $in) { die "Usage: $0 filename"; } my $out = $in; $out =~ s/(\.\w+)?$/out/; if (! open $in_fh, '<', $in ) { die "Can't open '$in': $!"; } if (! open $out_fh, '>', $out) { die "Can't write '$out': $!"; }

    Here is the errors that I received:

    Global symbol "$in_fh" requires explicit package name at ./exer_9_2 li +ne 14. Global symbol "$out_fh" requires explicit package name at ./exer_9_2 l +ine 1

    What 'package' am I missing?

    Catfish
Solved! I would have expected a syntax error here
6 direct replies — Read more / Contribute
by roboticus
on Oct 19, 2018 at 12:05

    Thanks, guys! That was a quick resolution. Indirect Object syntax was what tripped me up. As haukex suggests, I'll have to start using the Yadda, Yadda operator ... to ensure that I don't miss that in the future.

    Using that operator and a comment, I can either let the program run and execute and die only if I reach unfinished code:

    sub find_symbol { ... # got to here today! (20180520) }
    $ perl xyzzy.pl Foo! Unimplemented at xyzzy.pl line 13.

    Or if I'd rather have the program just fail without running, I can prefix my original comment with the operator (so long as I don't use a semicolon as the first character in my comment:

    sub find_symbol { ... got to here today! (20180520) }
    $ perl xyzzy.pl syntax error at xyzzy.pl line 12, near "... got to " Execution of xyzzy.pl aborted due to compilation errors.

    Really, though, not one Monty Python reference? 8^)

    Original post follows:


    Hello, gang:

    When I write experimental bits of code and don't get a chance to finish, I'll frequently mark my position with a few words and no comment marker with the intent that if I run the program, perl will tell me that bit(s) of my code are unfinished, and let me know where the unfinished bits are. This morning I decided to adapt a working program I've been using all week to add some new functionality, and when I looked at the code, I saw this bit:

    sub find_symbol { got to here today! (20180520) }

    What the heck? The code is working, but that subroutine just can't be right. So I looked over the program--It doesn't look like the code is commented out anywhere (I normally use "=h1 foo" and "=cut" to comment out blocks of code I don't want to use). I ran:

    $ perl -c LTSpice_to_graph.pl LTSpice_to_graph.pl syntax OK

    OK, then, *something* has to be masking this syntax error, right? So I copied the code to xyzzy.pl and started removing chunk after chunk, eventually coming up with:

    $ cat xyzzy.pl #!env perl use strict; use warnings; find_symbol(); sub find_symbol { got to here today } $ perl -c xyzzy.pl xyzzy.pl syntax OK $ perl -MO=Concise xyzzy.pl 6 <@> leave[1 ref] vKP/REFC ->(end) 1 <0> enter ->2 2 <;> nextstate(main 5 xyzzy.pl:5) v:*,&,{,x*,x&,x$,$ ->3 5 <1> entersub[t2] vKS/TARG,STRICT ->6 - <1> ex-list K ->5 3 <0> pushmark s ->4 - <1> ex-rv2cv sK/STRICT,1 ->- 4 <#> gv[*find_symbol] s/EARLYCV ->5 - <;> ex-nextstate(main 7 xyzzy.pl:10) v:*,&,{,x*,x&,x$,$ ->6 xyzzy.pl syntax OK

    So consider me baffled, I don't know what's going on here. Can anyone tell me what I'm not seeing?

    For the record:

    $ perl -version This is perl 5, version 26, subversion 2 (v5.26.2) built for x86_64-cy +gwin-threads-multi (with 7 registered patches, see perl -V for more detail)

    Interesting ... one more bit of information before I hit the preview button. I changed the contents of the subroutine to:

    sub find_symbol { I got to here today }

    and now I get what I expected to see:

    $ perl -c xyzzy.pl Bareword "today" not allowed while "strict subs" in use at xyzzy.pl li +ne 8. xyzzy.pl had compilation errors.

    Does anyone know what's happening here? My only (ill-informed) guess would be something to do with parsing the GOTO statement.

    ...roboticus

    When your only tool is a hammer, all problems look like your thumb.

diff vs diff -y
5 direct replies — Read more / Contribute
by MissPerl
on Oct 19, 2018 at 11:16
    I am not sure if anyone have the similar issue,
    $a = "/path/to/a/file"; $b = "/path/to/b/file"; $difference = system("$diff $a $b"); $difference2 = system("$diff -y $a $b");
    The $difference printed in html file only shows the difference - top & bottom (maybe 2 or 3 lines from 1000 lines).

    But the $difference2 printed in html file shows all the difference in 2 columns -left & right (1000 lines from 1000 lines).

    The output is actually fine, since I dont want to compare line by line, as sometime one has some extra lines while the other dont,

    So i want those extra lines which is in a and in b at the same file same time.

    Here, I am wondering if it is possible to have the sort of combination of both $diff and $diff -y, having 2 left/right columns of difference in some lines only (not showing every lines)
    if ($difference eq ''){ $difference = "Exactly Same.\n"; } push @table1, "<table id =\"Table1\">"; push @table1, "<tr><th>path A</th><th>A</th><th>path B</th><th>B</th>< +/tr>"; push @table1, "<tr><td colspan =\"4\">$difference</td></tr>";
    So that, $difference will shown in 2 columns with the line of differences in file.

    Any idea guys ?

Question about tr
3 direct replies — Read more / Contribute
by harangzsolt33
on Oct 19, 2018 at 01:17

    I am trying to learn how tr really works, and I think I still don't get it. I remember, reading the manual...it said that the character following tr is a separator character, and everything between the separators are characters that will get replaced with a new set of characters defined in the second group. Anyway, I am trying to write a little program that replaces the first 52 bytes of a character map with letters. In other words, in this programming exercise, I am trying to replace binary codes with tr, but tr is not handling these codes very well. For example, it gives an error when I try to convert chr(8) to "I"

    Here is my sample code:

    #!/usr/bin/perl use strict; use warnings; for (my $i = 0; $i < 52; $i++) { $a = chr($i); $a =~ tr|\0\1\2\3\4\5\6\7\8\t\n\0x0B\r\0x0D\0x0E\0x0F\0x10\0x11\0x12 +\0x13\0x14\0x15\0x16\0x17\0x18\0x19\0x1A\0x1B\0x1C\0x1D\0x1E\0x1F !"# +$%&'()*+,-./0123456789|ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrst +uvwxyz|; print "chr $i -> $a \n"; } exit;
regex not matching how I want it to :(
3 direct replies — Read more / Contribute
by glwa
on Oct 18, 2018 at 15:27
    usually I managed with regexes myself, but this time I am lost, so I decided to ask wiser people the question is why the following code:
    while ( $line=~/<a href=\"(.*?)\.htm\">/ig ) {
    on $line being
    <a href="test1.htm"> test1</a><br> <a href="test2.htm"> test2</a><br> +<a href="test3.htm"> test3</a><br>
    is matching
    test1"> test1</a><br> <a href="test2
    and not just
    test2
Loop through all directory and files and lines
4 direct replies — Read more / Contribute
by MissPerl
on Oct 18, 2018 at 09:25
    Hi fellow monks! CODE EDITED

    I want to go into first directory/i/j/*, then read all the files and all the lines inside every file. Eg, /somewhere/1/2/*

    Currently the script gave me no error, but the output was surprisingly all from the (else condition).

    I couldnt make sure, since there are a lot of files inside it, but there should at least have some cases match the (if ) condition.

    Can anyone have a look at the script i wrote and tell me if anything i have overlooked ?

    Each file, I want to find if any three of the strings exists, if it does, I'll store its filepath in store_location.

    Also the (i, j), was from an array with even number contents, odd number will be i; while even is j.
    # !/usr/bin/perl use strict; use warnings; use File::Glob 'bsd_glob'; my $store_location = '/path/to/file'; my $Dir1 = "/somewhere"; my $Dir2 = "/somewhereelse"; my @first_directory = ( bsd_glob("$Dir1/"), bsd_glob("$Dir2/") ); my @store_array = qw (1 2 3 4 5 6); foreach my $first (@first_directory){ while(my ($i,$j) = splice(@store_array,0,2)){ my $second_directory = "$first/$i/$j"; if (-e $second_directory and -d $second_directory){ my @third_directory = bsd_glob("$first/$i/$j/*"); foreach my $file (@third_directory){ open(FILE, "<" , $file) or die "Can't open file '$file +': $!"; while (<FILE>){ if (($_ =~ /TbhODK/) or ($_ =~ /octuov/) or ($_ =~ + /qas_uop/)) { open(my $filehand, '>>', $store_location) or d +ie "Fail to open file '$store_location' $!"; print $filehand "$first/$i/$j/$file \n"; close $filehand; } } } close FILE; } else{ open(my $filehand, '>>', $store_location) or die "Fail to +open file '$store_location' $!"; print $filehand "$first/$i/$j (fail to exist)\n"; close $filehand; } } }#first_directory
    Kindly let me know if it's unclear,I will improve the sentence.thank you perlmonks !

Date::Calc in years?
4 direct replies — Read more / Contribute
by Anonymous Monk
on Oct 18, 2018 at 05:13
    Hi Monks!
    My code below:
    use strict; use warnings; use Date::Calc qw(:all); my $date_birth = '1999-12-13'; my $date_death = '2080-05-21'; my @array_birth = split(/-/, $date_birth); my @array_death = split(/-/, $date_death); my $dd = Delta_Days(@array_birth, @array_death); my $years_alive = sprintf("%.1f", $dd/365); print $years_alive,"\n";
    works ok I would say, but I guess it is not 100% accurate (since I assume years of 365 days and I do not take into account months and days of birth and death.
    Can you help me fix it?
how to push multiples row of values into hash and do comparison
5 direct replies — Read more / Contribute
by darkmoon
on Oct 18, 2018 at 02:11

    Hi, I am new to perl. I have two files, I need to do comparison to find out the matching and non-matching data. I got two problems now: Question 1: one of my hashes can only capture the 2nd row of the 'num', i tried to use `push @{hash1{name1}},$x1,$y1,$x2,$y2` , but it still returning the 2nd row of the 'num'.

    File1 :
    name foo num 111 222 333 444 name jack num 999 111 222 333 num 333 444 555 777
    File2:
    name jack num 999 111 222 333 num 333 444 555 777 name foo num 666 222 333 444
    This is my code:
    #!/usr/bin/perl use strict; use warnings; use Data::Dumper; my $input1=$ARGV[0]; my $input2=$ARGV[1]; my %hash1; my %hash2; my $name1; my $name2; my $x1; my $x2; my $y2; my $y1; open my $fh1,'<', $input1 or die "Cannot open file : $!\n"; while (<$fh1>) { chomp; if(/^name\s+(\S+)/) { $name1 = $1; } if(/^num\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) { $x1 = $1; $y1 = $2; $x2 = $3; $y2 = $4; } $hash1{$name1}=[$x1,$y1,$x2,$y2]; } close $fh1; print Dumper (\%hash1); open my $fh2,'<', $input2 or die "Cannot open file : $!\n"; while (<$fh2>) { chomp; if(/^name\s+(\S+)/) { $name2 = $1; } if(/^num\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) { $x1 = $1; $y1 = $2; $x2 = $3; $y2 = $4; } $hash2{$name2}=[$x1,$y1,$x2,$y2]; } close $fh2; print Dumper (\%hash2);
    My output:
    $VAR1 = { 'jack' => [ '333', '444', '555', '777' ], 'foo' => [ '111', '222', '333', '444' ] }; $VAR1 = { 'jack' => [ '333', '444', '555', '777' ], 'foo' => [ '666', '222', '333', '444' ] };
    My expected Output:
    $VAR1 = { 'jack' => [ '999', '111', '222', '333', '333', '444', '555', '777' ], 'foo' => [ '111', '222', '333', '444' ] }; $VAR1 = { 'jack' => [ '999', '111', '222', '333', '333', '444', '555', '777' ], 'foo' => [ '666', '222', '333', '444' ] };

    Question 2: I tried to use this foreach loop to do the matching of keys and values and print out in a table format. I tried this :

    print "\t\tFIle1\t\t\t\t\tFile2\n"; print "Name\tX1\tY1\tX2\tY2\t\t\tX1\tY1\tX2\tY2\n"; foreach my $k1(keys %hash1) { foreach my $k2(keys %hash2) { if($hash1{$name} eq $hash2{$name2}) { if($hash1{$x1}{$y1}{$x2}{$y2} == $hash2 +{$x1}{$y1}{$x2}{$y2}) { print "$name\$x1\$y1\$x +2\$y2\n"; } } } }

    but Im getting the header only.

    File1 File2 Name X1 Y1 X2 Y2 X1 Y1 X2 Y2
    my desired output for matching :
    File1 File2 Name x1 y1 x2 y2 x1 y1 x2 y2 jack 999 111 222 333 999 111 222 333 333 444 555 777 333 444 555 777
    Any help?
New Cool Uses for Perl
Cheat at Scrabble
1 direct reply — Read more / Contribute
by 1nickt
on Oct 21, 2018 at 09:51

    Calculates the highest score possible from the letters given, taking into account any bonuses on the squares to be covered.

    (Rudimentary tool that does not handle combinations with the words already on the board).

    My local newspaper has a Scrabble-based game that involves simply finding the highest scoring word from seven letters and bonus tile positions provided. Note: quite often the highest scoring word according to the newspaper is not found in my words list :-(

    Specify double- and triple-word bonuses with -dw and -tw, and double- and triple-letter bonuses with -dl=N and -tl=N where N is the letter position.

    Examples:

    $ perl scrabble.pl eoaprzn Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. zap : 14 $ perl scrabble.pl eoaprzn -dw Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. zap : 28 $ perl scrabble.pl eoaprzn -tl=3 Found 13,699 1-7 letter strings in eoaprzn. Found 57 words in eoaprzn. raze : 33

    use strict; use warnings; use feature 'say'; use Path::Tiny; use Algorithm::Permute; use Number::Format 'format_number'; use List::Util 'uniq'; use Getopt::Long; my @dl; my @tl; my $dw; my $tw; my $debug; GetOptions( 'dl=i' => \@dl, 'tl=i' => \@tl, 'dw' => \$dw, 'tw' => \$tw, 'v' => \$debug, ); my $input = shift or die 'Died: No input!'; my $length = length $input; my @input_chars = split '', $input; my $words_file = '/usr/share/dict/words'; my %words = map { $_ => 1 } path( $words_file )->lines({chomp => + 1}); my %worth = ( a => 1, b => 3, c => 3, d => 2, e => 1, f => 4, g => 2, h => 4, i => 1, j => 8, k => 5, l => 1, m => 3, n => 1, o => 1, p => 3, q => 10, r => 1, s => 1, t => 1, u => 1, v => 2, w => 2, x => 8, y => 4, z => 10, ); my @partials; for (1 .. $length) { my $P = Algorithm::Permute->new( \@input_chars, $_ ); while (my @res = $P->next) { push @partials, join '', @res; } } @partials = uniq @partials; say sprintf 'Found %s 1-%s letter strings in %s.', format_number(scalar @partials), $length, $input; my %found = map { $_ => calc_score($_) } grep { $words{$_} } @partials + ; say sprintf 'Found %s words in %s.', format_number(scalar keys %found) +, $input; for ( sort { $found{$b} <=> $found{$a} } keys %found ) { say "$_ : $found{$_}"; last if not $debug; } ############### sub calc_score { my $word = shift; my $val; $val += $worth{$_} for split '', $word; $val += 50 if length $word == 7; return $val + calc_bonus($word, $val); } sub calc_bonus { my ($word, $val) = @_; my @chars = split '', $word; my $bonus = 0; for (@dl) { $bonus += $worth{ $chars[$_ - 1] } if $chars[$_ - 1]; } for (@tl) { $bonus += 2 * $worth{ $chars[$_ - 1] } if $chars[$_ - 1]; } $bonus += $val if $dw; $bonus += 2 * $val if $tw; return $bonus; } __END__


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 musing on the Monastery: (3)
As of 2018-10-21 19:11 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    When I need money for a bigger acquisition, I usually ...














    Results (119 votes). Check out past polls.

    Notices?