Perl バインディングの使用法

# Create a %ListOfDataTypes object and add a list of colors
   $newcolors = $database->run_class_method("%ListOfDataTypes","%New",undef);
   @color_list = qw(red blue green);
   for $color (@color_list) {
      $newcolors->Insert($color);
      print " added >$color<\n";
   };

# Add the list to a Sample.Person object
   $person = $database->openid("Sample.Person",$id,-1,0);
   $person->set("FavoriteColors",$newcolors);

# Get the list back from $person and print it out.
   $colors = $person->get("FavoriteColors");
   print "Number of colors: ",$colors->get("Size"), "\n";
   do {
      $color = $colors->GetNext($i);
      print " New Color #$i = $color\n" if defined($i);
   } until (!defined($i));
   
# Remove and replace the second element
   $colors->RemoveAt(2) if $colors->get("Size") > 0;
   $colors->InsertAt("purple",2);
   
# Show the changes to the collection
   print("Modified 'FavoriteColors' list:\n");
   do {
      $color = $colors->GetNext($i);
      print " Element #$i = $color\n" if defined($i);
   } until (!defined($i));

   Class Sample.List Extends %Persistent
   {
   Property CurrentList As %List;
   
   Method InitList() As %List { 
      q $LB(1,"hello",3.14) }
   
   Method TestList(NewList As %List) As %Integer {
      set $ZTRAP="ErrTestList"
      set ItemCount = $LISTLENGTH(NewList)
      if (ItemCount = 0) {set ItemCount = -1}
      q ItemCount
   ErrTestList
      set $ZERROR = ""
      set $ZTRAP = ""
      q 0 }
   }

   $listobj = $database->create_new("Sample.List",undef);
   $arrayref = $listobj->InitList();
   @array = @$arrayref;
   
   print "Initial List from Cache:\n";
   print "array address = $arrayref\n";
   print "array contents = @array\n";
   print "There are ",scalar(@array)," elements in the list:\n";
   for ($i=0;$i<scalar(@array);$i++) {
      print " element ",$i+1," = [$array[$i]]\n";
   }

   Initial List from Cache:
   array address = ARRAY(0x18d3d04)
   array contents = Cache to Perl: hello! 1 3.14
   There are 4 elements in the list:
      element 1 = [Cache to Perl: hello!]
      element 2 = [1]
      element 3 = []
      element 4 = [3.14]

   @oldarray = (1, undef, 2.78,"Just a small list.");
   $listobj->set("CurrentList",\@oldarray);
   $arrayref = $listobj->get("CurrentList");
   @newarray = @$arrayref;

   print "\n\nThis list is from property CurrentList:\n";
   print "There are ",scalar(@newarray)," elements in the list:\n";
   for ($i=0;$i<scalar(@newarray);$i++) {
      print " element ",$i+1," = [$newarray[$i-1]]\n";
   }
   print "\nThe old and new arrays ";
   if ("@oldarray" eq "@newarray")
       {print "match:\n"}
   else
      {print "DON'T match:\n"};
   print "   old:>@oldarray<\n",
         "   new:>@newarray<\n";

   This list is from property CurrentList:
   There are 4 elements in the list:
     element 1 = [Just a small list.]
     element 2 = [1]
     element 3 = []
     element 4 = [2.78]
   
   The old and new arrays match:
      old:>1  2.78 Just a small list.<
      new:>1  2.78 Just a small list.<

# Create a large array and print array information.
   $longitem = "1022 character element".(1234567890 x 100);
   @array =("This array is too long.");
   $cache_list_size = length($array[0]);
   for ($i=0;$i<33;$i++) {
        push(@array,$longitem);
        $cache_list_size += length($longitem);
   };
   print "\n\nNow for a HUGE list:\n";
   print "Total bytes required by Cache' list: more than $cache_list_size\n";
   print "There are ",scalar(@array)," elements in the ingoing list.\n\n";

# Check to see if the array will fit.
   $bool =  $listobj->TestList(\@array);
   print "TestList() reports that the array ";
   if ($bool) {print "is OK, and has $bool elements.\n";}
   else {print "will be damaged by the conversion.\n"};

# Pass the array to Cache', get it back, and display the results
   $listobj->set("CurrentList",\@array);
   $badarrayref = $listobj->get("CurrentList");
   @badarray = @$badarrayref;

   print "There are ",scalar(@badarray)," elements in the returned list:\n";
   for ($i=0;$i<scalar(@badarray);$i++) {
      $line = $badarray[$i];
      # long elements are shortened for readability.
      if (length($line)> 1000) {substr($line,10,980) = "..."};
      print "   element ",$i+1," = [$line]\n";
   }

   Now for a HUGE list:
   Total bytes required by Cache' list: more than 33749
   There are 34 elements in the ingoing list.
   
   TestList() reports that the array will be damaged by the conversion.
   There are 17 elements in the returned list:
      element 1 = [This array is too long.]
      element 2 = [1022 chara...90123456789012345678901234567890]
      element 3 = [1022 chara...90123456789012345678901234567890]
      element 4 = [1022 chara...90123456789012345678901234567890]
      element 5 = [1022 chara...90123456789012345678901234567890]
      element 6 = [1022 chara...90123456789012345678901234567890]
      element 7 = [1022 chara...90123456789012345678901234567890]
      element 8 = [1022 chara...90123456789012345678901234567890]
      element 9 = [1022 chara...90123456789012345678901234567890]
      element 10 = [1022 chara...90123456789012345678901234567890]
      element 11 = [1022 chara...90123456789012345678901234567890]
      element 12 = [1022 chara...90123456789012345678901234567890]
      element 13 = [1022 chara...90123456789012345678901234567890]
      element 14 = [1022 chara...90123456789012345678901234567890]
      element 15 = [1022 chara...90123456789012345678901234567890]
      element 16 = [1022 chara...90123456789012345678901234567890]
      element 17 = [1022 chara...90123456ray is too long.ï´√ȇ1022 c]

   Class User.PerlStatus Extends %Persistent{
      ClassMethod MyStatus() as %Status
      {
         q $$$ERROR(-137,"bad fine structure constant")
      }
   }

   # TestStatus.pl: illustrate handling a bad status return from COS 

   use Intersys::PERLBIND; 
   my $user="_SYSTEM"; 
   my $password="SYS"; 
   my $url = "localhost[1972]:USER";
   eval { 
      $conn = Intersys::PERLBIND::Connection->new($url,$user,$password,0);
      $database = Intersys::PERLBIND::Database->new($conn);
      $status=$database->run_class_method("User.PerlStatus", "MyStatus");
      # exception is thrown before we get here
      print "status=$status\n"; 
   }; 

   if ($@) { 
      print "Caught exception: $@\n"; 
   } else { 
      print "\nSample finished running\n"; 
   } 

   file=PERLBIND.xs line=71 err=-1 message=cbind_variant_set_buf()
   cpp_type=4 var.cpp_type=-1 var.obj.oref=1784835886
   class_name=%Library.RelationshipObject mtd_name=GetNext argnum=0