[Bio] / FigKernelPackages / P2Pupdate.pm Repository:
ViewVC logotype

Diff of /FigKernelPackages/P2Pupdate.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.49, Fri Jul 29 22:39:49 2005 UTC revision 1.50, Wed Aug 3 17:40:42 2005 UTC
# Line 1038  Line 1038 
1038    
1039  use Data::Dumper;  use Data::Dumper;
1040  use strict;  use strict;
1041    use Carp;
1042    use MIME::Base64;
1043    
1044  sub new  sub new
1045  {  {
1046      my($class, $qdir, $file, $fig) = @_;      my($class, $qdir, $file, $fig) = @_;
1047      my(@info);      my(@info);
1048    
1049        my $use_cache = defined($qdir);
1050    
1051      @info = FIG::file_head($file, 4);      @info = FIG::file_head($file, 4);
1052      if (!@info)      if (!@info)
1053      {      {
# Line 1063  Line 1067 
1067    
1068      my $self = {      my $self = {
1069          qdir => $qdir,          qdir => $qdir,
1070            use_cache => $use_cache,
1071          file => $file,          file => $file,
1072          name => $name,          name => $name,
1073          version => $version,          version => $version,
# Line 1276  Line 1281 
1281    
1282      $self->{reactions} = $reactions if $reactions ne "";      $self->{reactions} = $reactions if $reactions ne "";
1283    
1284        #
1285        # Additional sections. If $_ is //<something>, go ahead and process the blocks.
1286        #
1287        #
1288    
1289        my @blocks = ();
1290    
1291        if (m,^//(.*)$,)
1292        {
1293            chomp;
1294            my @cur_block;
1295            my $cur_tag = $1;
1296            while (<$fh>)
1297            {
1298                if (m,^//end$,)
1299                {
1300                    push(@blocks, [$cur_tag, \@cur_block]);
1301                }
1302                elsif (m,^//(.*)$,)
1303                {
1304                    chomp;
1305                    @cur_block = ();
1306                    $cur_tag = $1;
1307                }
1308                else
1309                {
1310                    push(@cur_block, $_);
1311                }
1312            }
1313        }
1314        $self->{blocks} = \@blocks;
1315  }  }
1316    
1317  #  #
# Line 1315  Line 1350 
1350    
1351      my $tran_peg;      my $tran_peg;
1352    
1353      if (-f $cached_translation_file and -s $cached_translation_file > 0)      if ($self->{use_cache} and -f $cached_translation_file and -s $cached_translation_file > 0)
1354      {      {
1355          #          #
1356          # Read the cached translations.          # Read the cached translations.
# Line 1348  Line 1383 
1383          # for use during installation.          # for use during installation.
1384          #          #
1385    
1386          if (open(my $fh, ">$self->{qdir}/peg_translation"))          if ($self->{use_cache} and open(my $fh, ">$self->{qdir}/peg_translation"))
1387          {          {
1388              for my $p (keys(%$tran_peg))              for my $p (keys(%$tran_peg))
1389              {              {
# Line 1633  Line 1668 
1668  #  #
1669  # We return a list of for-the-installer messages that will be presented when the install completes.  # We return a list of for-the-installer messages that will be presented when the install completes.
1670  #  #
1671    # If $assignments_file is set, assignments will be written to that file
1672    # instead of being installed.
1673    #
1674  sub install  sub install
1675  {  {
1676      my($self, $dont_assign) = @_;      my($self, $dont_assign, $imported_from, $assignments_file) = @_;
1677    
1678      my @messages;      my @messages;
1679    
# Line 1654  Line 1692 
1692      if (-d $sub_dir and (my $cur_ver = $fig->subsystem_version($sub_name)) >= $ver)      if (-d $sub_dir and (my $cur_ver = $fig->subsystem_version($sub_name)) >= $ver)
1693      {      {
1694          warn "Not importing $sub_name: current version $cur_ver >= imported version $ver";          warn "Not importing $sub_name: current version $cur_ver >= imported version $ver";
1695            push(@messages, "Not importing $sub_name: current version $cur_ver >= imported version $ver\n");
1696            return @messages;
1697      }      }
1698    
1699      warn "Importing $sub_name version $ver\n";      warn "Importing $sub_name version $ver\n";
# Line 1669  Line 1709 
1709      #      #
1710    
1711      my $fh;      my $fh;
1712      my $imported_from = "???";      $imported_from = "???" unless $imported_from ne '';
1713    
1714      open($fh, ">$sub_dir/VERSION") or die "Cannot open $sub_dir/VERSION for writing: $!";      open($fh, ">$sub_dir/VERSION") or die "Cannot open $sub_dir/VERSION for writing: $!";
1715      print $fh "$ver\n";      print $fh "$ver\n";
# Line 1734  Line 1774 
1774      close($ssa_fh);      close($ssa_fh);
1775    
1776      #      #
1777      # The subsystem itself is now in place.      # The subsystem itself is now in place. Depending on how we were
1778        # invoked, write the assignments to a file, or install them on
1779        # the system.
1780        #
1781    
1782        if (defined($assignments_file))
1783        {
1784            $self->write_assignments_to_file(\@messages, $tran_peg, $assignments_file);
1785        }
1786        else
1787        {
1788            $self->install_assignments(\@messages, $tran_peg, $dont_assign);
1789        }
1790    
1791        $self->install_blocks(\@messages, $sub_dir);
1792    
1793        return @messages;
1794    }
1795    
1796    #
1797    # Install any other block-data code that's in the package. Right now this is just
1798    # the diagrams.
1799    #
1800    sub install_blocks
1801    {
1802        my($self, $messages, $sub_dir) = @_;
1803        my $fig = $self->{fig};
1804    
1805        #
1806        # At this point, the rest of the subsystem is written to disk. We can
1807        # use the Subsys.pm mechanism to write this stuff out.
1808        #
1809    
1810        my $sub = $fig->get_subsystem($self->name());
1811    
1812        for my $block (@{$self->{blocks}})
1813        {
1814            my($block_hdr, $block_data) = @$block;
1815    
1816            if ($block_hdr =~ /^diagram:([^:]+):name\t(\S+)/)
1817            {
1818                #
1819                # The diagram output format ensures this is the first block, so just
1820                # create the diagram.
1821                #
1822    
1823                my $diagram_id = $1;
1824                my $diagram_name = $2;
1825    
1826                $sub->create_new_diagram(undef, $diagram_name, $diagram_id);
1827            }
1828            elsif ($block_hdr =~ m,^diagram:([^:]+):diagram=([^\s/]+)\t(\d+),)
1829            {
1830                my $diagram_id = $1;
1831                my $img_file = $2;
1832                my $size = $3;
1833    
1834                my $ddir = "$sub_dir/diagrams/$diagram_id";
1835    
1836                if (! -d $ddir)
1837                {
1838                    push(@$messages, "Invalid diagrams: diagram directory for $diagram_id did not exist while parsing diagram file\n");
1839                    next;
1840                }
1841    
1842                if (!open(FH, ">$ddir/$img_file"))
1843                {
1844                    push(@$messages, "Cannot open image file $ddir/$img_file for writing: $!\n");
1845                    next;
1846                }
1847    
1848                for my $line (@$block_data)
1849                {
1850                    $line =~ s/^B://;
1851                    my $dec = decode_base64($line);
1852                    print FH $dec;
1853                }
1854                close(FH);
1855    
1856                my $fsize = -s "$ddir/$img_file";
1857                if ($fsize != $size)
1858                {
1859                    push(@$messages, "Diagram image $img_file size $fsize does not match declared size $size\n");
1860                    warn "Diagram image $img_file size $fsize does not match declared size $size";
1861                }
1862            }
1863        }
1864    }
1865    
1866    
1867    
1868    sub write_assignments_to_file
1869    {
1870        my($self, $messages, $tran_peg, $filename) = @_;
1871        my $fig = $self->{fig};
1872    
1873        my $fh;
1874    
1875        for my $pegent (@{$self->{pegs}})
1876        {
1877            my($peg, $aliases, $org, $func) = @$pegent;
1878            my $tpeg = $tran_peg->{$peg};
1879    
1880            if (!$tpeg)
1881            {
1882                warn "Couldn't translate $peg (from $org)\n";
1883                push(@$messages, "Couldn't translate $peg (from $org)");
1884                next;
1885            }
1886    
1887            my $old = $fig->function_of($tpeg);
1888    
1889            if ($old ne $func)
1890            {
1891                #
1892                # Only open the file if we have assignments to write.
1893                #
1894    
1895                if (!defined($fh))
1896                {
1897                    open($fh, ">$filename") or confess "Error opening $filename for writing: $!";
1898                }
1899                print $fh "$tpeg\t$func\n";
1900            }
1901        }
1902        if (defined($fh))
1903        {
1904            close($fh);
1905        }
1906    }
1907    
1908    
1909    sub install_assignments
1910    {
1911        my($self, $messages, $tran_peg, $dont_assign) = @_;
1912        my $fig = $self->{fig};
1913    
1914      #      #
1915      # Enter the new assignments, saving the old assignments in the  spool dir.      # Enter the new assignments, saving the old assignments in the  spool dir.
1916      #      #
# Line 1758  Line 1934 
1934          if (!$tpeg)          if (!$tpeg)
1935          {          {
1936              warn "Couldn't translate $peg (from $org)\n";              warn "Couldn't translate $peg (from $org)\n";
1937              push(@messages, "Couldn't translate $peg (from $org)");              push(@$messages, "Couldn't translate $peg (from $org)");
1938              next;              next;
1939          }          }
1940    
# Line 1794  Line 1970 
1970          }          }
1971      }      }
1972      close($old_funcs_fh);      close($old_funcs_fh);
     return @messages;  
1973  }  }
1974    
1975  #  #

Legend:
Removed from v.1.49  
changed lines
  Added in v.1.50

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3