scripts/gearman2dot.pl

   1 #!/usr/bin/perl
   2 use warnings;
   3 use strict;
   4
   5 use autodie;
   6 use File::Find;
   7 use File::Slurp;
   8 use Data::Dump qw(dump);
   9
  10 my $dot;
  11 sub dot {
  12         $dot .= join("\n",@_) . "\n";
  13         warn "DOT ",@_,$/;
  14 }
  15
  16 sub print_job {
  17         my ( $name, $job ) = @_;
  18         warn "JOB $name ",dump($job),$/;
  19
  20         return unless exists $job->{task};
  21
  22         $name = $job->{name};
  23
  24         foreach my $taskset ( keys %{ $job->{task} } ) {
  25                 dot qq|subgraph cluster_${name}_$taskset {
  26                         style = filled; color=lightgray; label="$name"
  27                         node [style=filled,color=white];
  28                 |;
  29                 my @t = @{ $job->{task}->{$taskset} };
  30                 my $wait = $t[$#t] eq 'wait' && pop @t;
  31                 foreach my $f ( @t ) {
  32                         dot qq|"$name" -> "$f";|;
  33                         dot qq|"$f" -> "${name}";| if $wait;
  34                 }
  35                 dot "} //subgraph";
  36         }
  37 }
  38
  39 find(sub {
  40         my $name = $_;
  41         return if ! m/\.pm$/;
  42         open(my $fh, '<', $name);
  43         my $job;
  44         while(<$fh>) {
  45                 chomp;
  46                 if (/sub\s+(\w+)\s*:\s*Job/) {
  47                         print_job $name => $job;
  48                         $job = { name => $1 };
  49                 } elsif ( m/\$(\w+)->add_task\(\s*'(\w+)'/ ) {
  50                         push @{ $job->{task}->{$1} }, $2;
  51                 } elsif ( m/\$(\w+)->wait/ ) {
  52                         if ( exists $job->{task}->{$1} ) {
  53                                 push @{ $job->{task}->{$1} }, 'wait';
  54                         }
  55                 } elsif ( m/\$self->(do\w*)\(\s*'(\w+)'/ ) {
  56                         my ( $do, $what ) = ( $1, $2 );
  57                         push @{ $job->{$do} }, $what;
  58                         my $style = '';
  59                         $style = ' style=dotted ' if $do =~ s/_background.*//;
  60                         dot qq|"$job->{name}" -> "$what" [ $style ];|;
  61                 }
  62         }
  63         print_job $name => $job;
  64 }, 'lib');
  65
  66 print $dot;
  67
  68 open(my $d, '|-', 'dot -Tpng -o public/gearman.png');
  69 print $d "digraph {\n$dot\n}\n";
  70 close($d);