Have a set where all members are connected directly or indirectly. A-B means A and B are connected directly. Order of A-B or B-A immaterial. A-B and B-C means A and C are indirectly connected. A, B, C, ... are ID nos.

Now want to find the largest collection (sub set) where each is directly connected with each other - if X-Y, X-Z, Y-Z then X, Y and Z are directly connected. If more than one such sub set, then would like to have all such sub sets, if possible.

This seems more a Graph problem than a Set problem. Looked at all the Graph and Set modules but could not find anything. Googled too.

Surprised that this problem is not common. Help appreciated

Dear Perlmonks, I turn to you for guidance! Please help me see the light after the long dark of redirect horrors...

(read: I don't understand why this code is not able to fetch a redirect url).

I need to access an api, which is secured by a single sign on service, which then redirects to the actual api and provides a token for using it.

I wrote the following code, expecting it to fetch the location header of the redirect url (shortened it a bit for better readability):

#!/usr/bin/env perl
use WWW::Mechanize;
use HTTP::CookieJar::LWP ();
use IO::Socket::SSL qw();

my $uri ="https://sso.employer.com/serviceredirect/login?service=https
+://actualserviceurl.employer.com/my/service";

my $username = "username";
my $password = q(password);

my $fields = {
    username    => $username,
    password => $password,
};

my $m = WWW::Mechanize->new( cookie_jar => $cookie_jar, autocheck => 1
+, ssl_opts => { SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE, 
+verify_hostname => 0 }, env_proxy => 1, keep_alive => 1, timeout => 3
+0, agent => 'myagent' );

$m->max_redirect(2);
my $content = $m->post($uri);

$m->submit_form(
    form_number => 1,
    fields      => $fields,
    button      => 'submit'
);

print $content->headers()->as_string;
[download]

I'm able to fetch headers here, but only the ones for the login site.

No 302, no Location Header.

If I add "print $content->decoded_content();", I only get the java script from that site.

BUT, I know that it works in general, because when I add:

I can see that it's redirecting and even the Token I'm looking for (shortened too):

POST https://sso.employer.com/serviceredirect/login?service=https://ac
+tualserviceurl.employer.com/my/service
Accept-Encoding: gzip
User-Agent: myagent
Content-Length: 0
Content-Type: application/x-www-form-urlencoded

(no content)
HTTP/1.1 200 OK

[...]

HTTP/1.1 302 Found
Cache-Control: no-cache, no-store, max-age=0, must-revalidate
Date: Fri, 22 Nov 2019 13:20:31 GMT
Pragma: no-cache
Via: 1.1 login.1and1.org
Location: https://actualserviceurl.employer.com/my/service?ticket=xxxs
+uperlonggeneratedticketidxxx

[...]
[download]

It seems to me that mechanize stops processing the headers / doesn't recognize them to belong $content somehow, while it's generally working...

I'm really lost here.

What am I doing wrong?

I have a sub called TEST() which converts every sort of input to a number. It should return 0 if the input value is undefined or uninitialized or blank or contains letters only. But if it contains digits, it should return those digits only.

So, if I ask to convert "55a" then it returns "55" which is fine. But if I try to convert "a55" then it returns 0, which baffles me! It should return 55. Why does this happen?

Edit: It seems like I am able to access the value of $N from within the warning exception, but I cannot modify it. The changes do not stick. So, I guess the question is how can I export the value of $N from within the warning sub { } so that it would overwrite the value of $N in the TEST sub?

#!/usr/bin/perl -w

use strict;
use warnings;

my @TEST_VALUES = ('55a', 'a55');

foreach my $i (@TEST_VALUES)
{
  print "Calling TEST('$i'): ";
  print "\nTEST return value = ", TEST($i), "\n";
}
exit;

#######################################
sub TEST
{
  print " TEST() was called ";
  defined $_[0] or return 0;
  my $N = shift;
  print "with argument: '$N'\n";

  # If we get a warning, it's probably because $N
  # is not a number. So, we remove all non-digits
  # and then it becomes a number!
  local $SIG{__WARN__} = sub { print "\t\t(((warning '$N'->"; $N =~ tr
+|0-9||cd; $N = "0$N"; print "'$N')))\n"; };

  $N += 0;
  print "\nThe value of N is now '$N'\n";
  return int($N);
}
[download]

What is the best way to escape from multilevel, deeply nested calls to the main program (say with the call nesting level close to a hundred) that resulted in error somewhere close the most deep nesting level (unwinding of failed calls).

Can I use exceptions mechanism for this to jump immediately to the main program? If yes, how?

For example, in the example below (for demonstration purposes only) we need to exit from all levels if we detect a loop in recursion calls. And the required code is rather ugly and inefficient: checks need to be made both on entry and after each subroutine call in each module.

  use v5.10;
   use warnings;
   use strict 'subs';
   use feature 'state';
$global_failure=0;
$rc=d('d');
say "\nProgram ended";
say "Failure_code is $global_failure";
exit $rc;

sub d
{
state $recursion_level=0;
  $recursion_level++;
  if ($recursion_level>10){
     $global_failure++;
     return $recursion_level;
  } 
  print $_[0].$recursion_level;
  $rc=e('e');
  if( $rc ){
     $global_failure++;  
     $global_failure++;
     print '-'.$_[0].$recursion_level;
     $recursion_level--;
     return $recursion_level;
  }   
  $recursion_level--;
  return 0; 
}
sub e
{
state $recursion_level=0;
  $recursion_level++;
  if ($recursion_level>10){
     $global_failure++;
     print '-'.$_[0].$recursion_level;
     $recursion_level--;
     return $recursion_level;
  } 
  print $_[0].$recursion_level;
  $rc=f('f');
  if ($rc) {
    $global_failure++;
    print '-'.$_[0].$recursion_level;
    $recursion_level--;
    return $rc;
  } 
  $recursion_level--;
  return 0;
    
}
sub f
{
state $recursion_level=0;
  $recursion_level++;
  if ($recursion_level>10){
     $global_failure++;
     print '-'.$_[0].$recursion_level;
     $recursion_level--;
     return $recursion_level;
  } 
  print $_[0].$recursion_level;
  $rc=f('f');
  if ($rc) {
    $global_failure++;
    $recursion_level--;
    print '-'.$_[0].$recursion_level;
    return $rc;
  } 
  $recursion_level--;
  return 0;
} 
[download]

"Searched for: San Francisco_Microbiome" "Title","Amount","Phase","Program","Awards Year","Solicitation Year","Small Business Name","Small Business Address","Woman Owned","Principal Investigator Name","PI Phone","PI Email","Business Contact Name","BC Phone","BC Email","Abstract" "SBIR Phase I: Enhancing the skin microbiome for mosquito repellency: Next generation mosquito repellent derived from big data analysis","$225,000.00"

use strict;
use Spreadsheet::WriteExcel;
use Text::CSV_XS;

# Check for valid number of arguments
if ( ( $#ARGV < 1 ) || ( $#ARGV > 2 ) ) {
    die("Usage: csv2xls csvfile.txt newfile.xls\n");
}

# Open the Comma Separated Variable file
open( CSVFILE, $ARGV[0] ) or die "$ARGV[0]: $!";

# Create a new Excel workbook
my $workbook  = Spreadsheet::WriteExcel->new( $ARGV[1] );
my $worksheet = $workbook->add_worksheet();

# Create a new CSV parsing object
my $csv = Text::CSV_XS->new;

# Row and column are zero indexed
my $row = 0;

while (<CSVFILE>) {
    if ( $csv->parse($_) ) {
        my @Fld = $csv->fields;

        my $col = 0;
        foreach my $token (@Fld) {
            $worksheet->write( $row, $col, $token );
            $col++;
        }
        $row++;
    } else {
        my $err = $csv->error_input;
        print "Text::CSV_XS parse() failed on argument: ", $err, "\n";
    }
}
[download]

I am trying to add two elements to an existing PowerPoint if a specific term (in my example "transformation" is found: 1) a text object and with a red background (no transparency) and 2) a note/comment. I manage to do 1) but can't find the option to set the background but I fail completely on point 2). Any suggestion?

#!perl
use strict;
use warnings;

use utf8;
use Cwd;
use Win32::OLE;
use Win32::OLE 'CP_UTF8';
use Win32::OLE::Const 'Microsoft PowerPoint';
$Win32::OLE::Warn = 3;
$Win32::OLE::CP = CP_UTF8;

my $file = "original.pptx";
my $dir = getcwd();
my $filename = $dir . '\\' . $file; 

print ("Starting PowerPoint\n");
my $process = Win32::OLE->GetActiveObject('Powerpoint.Application')
   || Win32::OLE->new('Powerpoint.Application', 'Quit');

print ( "Opening '$filename'\n" );
my $ppt =  $process->Presentations->Open($filename);

$file =~ s/original/TCF6203/;
$filename = "$dir/$file";

my @activeslides = $process->ActivePresentation->Slides->in;
foreach my $slide (@activeslides) {
  my $name = $slide->{Name};
  foreach my $shape ($slide->Shapes->in){
    if ($shape->TextFrame->HasText){ #TO DO: to get all elements I sho
+uld create a loop here
      if ($shape->HasTextFrame){
        my $text  = $shape->TextFrame->TextRange->Text;
        print "$name\nText $text = ";
        if ($text =~ /transformation/){
          my $TextBox=$slide->Shapes->AddTextbox({Orientation=>1, 
                                      Left=>5, 
                                      Top=>5,
                                      Width=>250,
                                      Height=>250,
                                      });
            $TextBox->TextFrame->TextRange->{Text} ="Big Ole Test";
            #$slide->NotesPage->TextRange->{Text} ="Big Ole Test"; #CO
+MMENT OUT TO TRY TO ADD NOTE/COMMENT
          print "OK\n";
        } else {
          print "NOTHING TO DO\n";
        };
      }
    }
  }
}

print ( "Saving '$filename'\n" );
$ppt->SaveAs($filename);
[download]

Hi

Very newbie here so any help appreciated. We have the following API and information.

https://api.sixfold.com/v1/companies/{company_id}/carrier-shipments/{shipment_id}/allocation

application/json

{
"type": "vehicle",
"vehicle_id": "123"
}

[download]

What am I doing wrong below in the POST command? It returns "Forbidden", which in this case means there is something awry with the format. The headers seem to be OK.

use REST::Client;
use JSON;
use Data::Dumper;

my $client = REST::Client->new();
$client->POST ('https://api.sixfold.com/v1/companies/296/carrier-shipm
+ents/0005360404/allocation','{"type":"vehicle", "vehicle_id":"39257" 
+}',{Authorization => 'Bearer 096dd6e084d5f30fazzz', "Content-type" =>
+ 'application/json'}); 
print Dumper($client->responseContent());

[download]

my $r="abc|xyz";
my $rx=qr($r);
my $c="XYZ";

my $x1=($c=~/$rx/i);
my $x2=(lc($c)=~/$rx/i);
say "\$x1=$x1";    
say "\$x2=$x2";
[download]

Results in:

$x1=

$x2=1

Shouldn't the /i give us a case insensitive match?

Perl version: This is perl 5, version 28, subversion 0 (v5.28.0) built for MSWin32-x64-multi-thread

Running on Windows 10

Am I missing something obvious>

TIA

Comments? Should I just add them to TEST_REQUIRES and not worry about it? I bet I am being a bit too OCD, but I don't like installing things I don't use.

$ wget http://www.cpan.org/authors/01mailrc.txt.gz
URL transformed to HTTPS due to an HSTS policy
--2019-11-21 21:21:48--  https://www.cpan.org/authors/01mailrc.txt.gz
[download]